1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2009, 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 #ifndef MAX_FIXED_MODE_SIZE
57 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
60 /* Convention_Stdcall should be processed in a specific way on Windows targets
61 only. The macro below is a helper to avoid having to check for a Windows
62 specific attribute throughout this unit. */
64 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
65 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
67 #define Has_Stdcall_Convention(E) (0)
70 /* Stack realignment for functions with foreign conventions is provided on a
71 per back-end basis now, as it is handled by the prologue expanders and not
72 as part of the function's body any more. It might be requested by way of a
73 dedicated function type attribute on the targets that support it.
75 We need a way to avoid setting the attribute on the targets that don't
76 support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
78 It is defined on targets where the circuitry is available, and indicates
79 whether the realignment is needed for 'main'. We use this to decide for
80 foreign subprograms as well.
82 It is not defined on targets where the circuitry is not implemented, and
83 we just never set the attribute in these cases.
85 Whether it is defined on all targets that would need it in theory is
86 not entirely clear. We currently trust the base GCC settings for this
89 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
90 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
95 struct incomplete
*next
;
100 /* These variables are used to defer recursively expanding incomplete types
101 while we are processing an array, a record or a subprogram type. */
102 static int defer_incomplete_level
= 0;
103 static struct incomplete
*defer_incomplete_list
;
105 /* This variable is used to delay expanding From_With_Type types until the
107 static struct incomplete
*defer_limited_with
;
109 /* These variables are used to defer finalizing types. The element of the
110 list is the TYPE_DECL associated with the type. */
111 static int defer_finalize_level
= 0;
112 static VEC (tree
,heap
) *defer_finalize_list
;
114 /* A hash table used to cache the result of annotate_value. */
115 static GTY ((if_marked ("tree_int_map_marked_p"),
116 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
125 static void relate_alias_sets (tree
, tree
, enum alias_set_op
);
127 static tree
substitution_list (Entity_Id
, Entity_Id
, tree
, bool);
128 static bool allocatable_size_p (tree
, bool);
129 static void prepend_one_attribute_to (struct attrib
**,
130 enum attr_type
, tree
, tree
, Node_Id
);
131 static void prepend_attributes (Entity_Id
, struct attrib
**);
132 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
133 static bool is_variable_size (tree
);
134 static tree
elaborate_expression_1 (Node_Id
, Entity_Id
, tree
, tree
,
136 static tree
make_packable_type (tree
, bool);
137 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool);
138 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
140 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
141 static bool array_type_has_nonaliased_component (Entity_Id
, tree
);
142 static bool compile_time_known_address_p (Node_Id
);
143 static void components_to_record (tree
, Node_Id
, tree
, int, bool, tree
*,
144 bool, bool, bool, bool);
145 static Uint
annotate_value (tree
);
146 static void annotate_rep (Entity_Id
, tree
);
147 static tree
compute_field_positions (tree
, tree
, tree
, tree
, unsigned int);
148 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
149 static void set_rm_size (Uint
, tree
, Entity_Id
);
150 static tree
make_type_from_size (tree
, tree
, bool);
151 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
152 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT
);
153 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
154 static int compatible_signatures_p (tree ftype1
, tree ftype2
);
155 static void rest_of_type_decl_compilation_no_defer (tree
);
157 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
158 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
159 and associate the ..._DECL node with the input GNAT defining identifier.
161 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
162 initial value (in GCC tree form). This is optional for a variable. For
163 a renamed entity, GNU_EXPR gives the object being renamed.
165 DEFINITION is nonzero if this call is intended for a definition. This is
166 used for separate compilation where it is necessary to know whether an
167 external declaration or a definition must be created if the GCC equivalent
168 was not created previously. The value of 1 is normally used for a nonzero
169 DEFINITION, but a value of 2 is used in special circumstances, defined in
173 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
175 Entity_Id gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
177 Entity_Kind kind
= Ekind (gnat_entity
);
178 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
179 This node will be associated with the GNAT node by calling at the end
180 of the `switch' statement. */
181 tree gnu_decl
= NULL_TREE
;
182 /* Contains the GCC type to be used for the GCC node. */
183 tree gnu_type
= NULL_TREE
;
184 /* Contains the GCC size tree to be used for the GCC node. */
185 tree gnu_size
= NULL_TREE
;
186 /* Contains the GCC name to be used for the GCC node. */
188 /* True if we have already saved gnu_decl as a GNAT association. */
190 /* True if we incremented defer_incomplete_level. */
191 bool this_deferred
= false;
192 /* True if we incremented force_global. */
193 bool this_global
= false;
194 /* True if we should check to see if elaborated during processing. */
195 bool maybe_present
= false;
196 /* True if we made GNU_DECL and its type here. */
197 bool this_made_decl
= false;
198 /* True if debug info is requested for this entity. */
199 bool debug_info_p
= (Needs_Debug_Info (gnat_entity
)
200 || debug_info_level
== DINFO_LEVEL_VERBOSE
);
201 /* True if this entity is to be considered as imported. */
202 bool imported_p
= (Is_Imported (gnat_entity
)
203 && No (Address_Clause (gnat_entity
)));
205 = ((Known_Esize (gnat_entity
)
206 && UI_Is_In_Int_Range (Esize (gnat_entity
)))
207 ? MIN (UI_To_Int (Esize (gnat_entity
)),
208 IN (kind
, Float_Kind
)
209 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
)
210 : IN (kind
, Access_Kind
) ? POINTER_SIZE
* 2
211 : LONG_LONG_TYPE_SIZE
)
212 : LONG_LONG_TYPE_SIZE
);
213 unsigned int align
= 0;
214 struct attrib
*attr_list
= NULL
;
216 /* Since a use of an Itype is a definition, process it as such if it
217 is not in a with'ed unit. */
219 && Is_Itype (gnat_entity
)
220 && !present_gnu_tree (gnat_entity
)
221 && In_Extended_Main_Code_Unit (gnat_entity
))
223 /* Ensure that we are in a subprogram mentioned in the Scope chain of
224 this entity, our current scope is global, or we encountered a task
225 or entry (where we can't currently accurately check scoping). */
226 if (!current_function_decl
227 || DECL_ELABORATION_PROC_P (current_function_decl
))
229 process_type (gnat_entity
);
230 return get_gnu_tree (gnat_entity
);
233 for (gnat_temp
= Scope (gnat_entity
);
235 gnat_temp
= Scope (gnat_temp
))
237 if (Is_Type (gnat_temp
))
238 gnat_temp
= Underlying_Type (gnat_temp
);
240 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
242 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
244 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
245 && Present (Protected_Body_Subprogram (gnat_temp
)))
246 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
248 if (Ekind (gnat_temp
) == E_Entry
249 || Ekind (gnat_temp
) == E_Entry_Family
250 || Ekind (gnat_temp
) == E_Task_Type
251 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
252 && present_gnu_tree (gnat_temp
)
253 && (current_function_decl
254 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
256 process_type (gnat_entity
);
257 return get_gnu_tree (gnat_entity
);
261 /* This abort means the entity has an incorrect scope, i.e. that its
262 scope does not correspond to the subprogram it is declared in. */
266 /* If the entiy is not present, something went badly wrong. */
267 gcc_assert (Present (gnat_entity
));
269 /* If we've already processed this entity, return what we got last time.
270 If we are defining the node, we should not have already processed it.
271 In that case, we will abort below when we try to save a new GCC tree
272 for this object. We also need to handle the case of getting a dummy
273 type when a Full_View exists. */
274 if (present_gnu_tree (gnat_entity
)
275 && (!definition
|| (Is_Type (gnat_entity
) && imported_p
)))
277 gnu_decl
= get_gnu_tree (gnat_entity
);
279 if (TREE_CODE (gnu_decl
) == TYPE_DECL
280 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
281 && IN (kind
, Incomplete_Or_Private_Kind
)
282 && Present (Full_View (gnat_entity
)))
285 = gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 0);
286 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
287 save_gnu_tree (gnat_entity
, gnu_decl
, false);
293 /* If this is a numeric or enumeral type, or an access type, a nonzero
294 Esize must be specified unless it was specified by the programmer. */
295 gcc_assert (!Unknown_Esize (gnat_entity
)
296 || Has_Size_Clause (gnat_entity
)
297 || (!IN (kind
, Numeric_Kind
)
298 && !IN (kind
, Enumeration_Kind
)
299 && (!IN (kind
, Access_Kind
)
300 || kind
== E_Access_Protected_Subprogram_Type
301 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
302 || kind
== E_Access_Subtype
)));
304 /* RM_Size must be specified for all discrete and fixed-point types. */
305 gcc_assert (!IN (kind
, Discrete_Or_Fixed_Point_Kind
)
306 || !Unknown_RM_Size (gnat_entity
));
308 /* Get the name of the entity and set up the line number and filename of
309 the original definition for use in any decl we make. */
310 gnu_entity_id
= get_entity_name (gnat_entity
);
311 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
313 /* If we get here, it means we have not yet done anything with this
314 entity. If we are not defining it here, it must be external,
315 otherwise we should have defined it already. */
316 gcc_assert (definition
|| Is_Public (gnat_entity
) || type_annotate_only
317 || kind
== E_Discriminant
|| kind
== E_Component
319 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
320 || IN (kind
, Type_Kind
));
322 /* For cases when we are not defining (i.e., we are referencing from
323 another compilation unit) public entities, show we are at global level
324 for the purpose of computing scopes. Don't do this for components or
325 discriminants since the relevant test is whether or not the record is
326 being defined. But do this for Imported functions or procedures in
328 if ((!definition
&& Is_Public (gnat_entity
)
329 && !Is_Statically_Allocated (gnat_entity
)
330 && kind
!= E_Discriminant
&& kind
!= E_Component
)
331 || (Is_Imported (gnat_entity
)
332 && (kind
== E_Function
|| kind
== E_Procedure
)))
333 force_global
++, this_global
= true;
335 /* Handle any attributes directly attached to the entity. */
336 if (Has_Gigi_Rep_Item (gnat_entity
))
337 prepend_attributes (gnat_entity
, &attr_list
);
339 /* Machine_Attributes on types are expected to be propagated to subtypes.
340 The corresponding Gigi_Rep_Items are only attached to the first subtype
341 though, so we handle the propagation here. */
342 if (Is_Type (gnat_entity
) && Base_Type (gnat_entity
) != gnat_entity
343 && !Is_First_Subtype (gnat_entity
)
344 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
345 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)), &attr_list
);
350 /* If this is a use of a deferred constant without address clause,
351 get its full definition. */
353 && No (Address_Clause (gnat_entity
))
354 && Present (Full_View (gnat_entity
)))
357 = gnat_to_gnu_entity (Full_View (gnat_entity
), gnu_expr
, 0);
362 /* If we have an external constant that we are not defining, get the
363 expression that is was defined to represent. We may throw that
364 expression away later if it is not a constant. Do not retrieve the
365 expression if it is an aggregate or allocator, because in complex
366 instantiation contexts it may not be expanded */
368 && Present (Expression (Declaration_Node (gnat_entity
)))
369 && !No_Initialization (Declaration_Node (gnat_entity
))
370 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
372 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
374 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
376 /* Ignore deferred constant definitions without address clause since
377 they are processed fully in the front-end. If No_Initialization
378 is set, this is not a deferred constant but a constant whose value
379 is built manually. And constants that are renamings are handled
383 && No (Address_Clause (gnat_entity
))
384 && !No_Initialization (Declaration_Node (gnat_entity
))
385 && No (Renamed_Object (gnat_entity
)))
387 gnu_decl
= error_mark_node
;
392 /* Ignore constant definitions already marked with the error node. See
393 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
396 && present_gnu_tree (gnat_entity
)
397 && get_gnu_tree (gnat_entity
) == error_mark_node
)
399 maybe_present
= true;
406 /* We used to special case VMS exceptions here to directly map them to
407 their associated condition code. Since this code had to be masked
408 dynamically to strip off the severity bits, this caused trouble in
409 the GCC/ZCX case because the "type" pointers we store in the tables
410 have to be static. We now don't special case here anymore, and let
411 the regular processing take place, which leaves us with a regular
412 exception data object for VMS exceptions too. The condition code
413 mapping is taken care of by the front end and the bitmasking by the
420 /* The GNAT record where the component was defined. */
421 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
423 /* If the variable is an inherited record component (in the case of
424 extended record types), just return the inherited entity, which
425 must be a FIELD_DECL. Likewise for discriminants.
426 For discriminants of untagged records which have explicit
427 stored discriminants, return the entity for the corresponding
428 stored discriminant. Also use Original_Record_Component
429 if the record has a private extension. */
430 if (Present (Original_Record_Component (gnat_entity
))
431 && Original_Record_Component (gnat_entity
) != gnat_entity
)
434 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
435 gnu_expr
, definition
);
440 /* If the enclosing record has explicit stored discriminants,
441 then it is an untagged record. If the Corresponding_Discriminant
442 is not empty then this must be a renamed discriminant and its
443 Original_Record_Component must point to the corresponding explicit
444 stored discriminant (i.e. we should have taken the previous
446 else if (Present (Corresponding_Discriminant (gnat_entity
))
447 && Is_Tagged_Type (gnat_record
))
449 /* A tagged record has no explicit stored discriminants. */
450 gcc_assert (First_Discriminant (gnat_record
)
451 == First_Stored_Discriminant (gnat_record
));
453 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
454 gnu_expr
, definition
);
459 else if (Present (CR_Discriminant (gnat_entity
))
460 && type_annotate_only
)
462 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
463 gnu_expr
, definition
);
468 /* If the enclosing record has explicit stored discriminants, then
469 it is an untagged record. If the Corresponding_Discriminant
470 is not empty then this must be a renamed discriminant and its
471 Original_Record_Component must point to the corresponding explicit
472 stored discriminant (i.e. we should have taken the first
474 else if (Present (Corresponding_Discriminant (gnat_entity
))
475 && (First_Discriminant (gnat_record
)
476 != First_Stored_Discriminant (gnat_record
)))
479 /* Otherwise, if we are not defining this and we have no GCC type
480 for the containing record, make one for it. Then we should
481 have made our own equivalent. */
482 else if (!definition
&& !present_gnu_tree (gnat_record
))
484 /* ??? If this is in a record whose scope is a protected
485 type and we have an Original_Record_Component, use it.
486 This is a workaround for major problems in protected type
488 Entity_Id Scop
= Scope (Scope (gnat_entity
));
489 if ((Is_Protected_Type (Scop
)
490 || (Is_Private_Type (Scop
)
491 && Present (Full_View (Scop
))
492 && Is_Protected_Type (Full_View (Scop
))))
493 && Present (Original_Record_Component (gnat_entity
)))
496 = gnat_to_gnu_entity (Original_Record_Component
503 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
504 gnu_decl
= get_gnu_tree (gnat_entity
);
510 /* Here we have no GCC type and this is a reference rather than a
511 definition. This should never happen. Most likely the cause is
512 reference before declaration in the gnat tree for gnat_entity. */
516 case E_Loop_Parameter
:
517 case E_Out_Parameter
:
520 /* Simple variables, loop variables, Out parameters, and exceptions. */
523 bool used_by_ref
= false;
525 = ((kind
== E_Constant
|| kind
== E_Variable
)
526 && Is_True_Constant (gnat_entity
)
527 && !Treat_As_Volatile (gnat_entity
)
528 && (((Nkind (Declaration_Node (gnat_entity
))
529 == N_Object_Declaration
)
530 && Present (Expression (Declaration_Node (gnat_entity
))))
531 || Present (Renamed_Object (gnat_entity
))));
532 bool inner_const_flag
= const_flag
;
533 bool static_p
= Is_Statically_Allocated (gnat_entity
);
534 bool mutable_p
= false;
535 tree gnu_ext_name
= NULL_TREE
;
536 tree renamed_obj
= NULL_TREE
;
537 tree gnu_object_size
;
539 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
541 if (kind
== E_Exception
)
542 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
545 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
548 /* Get the type after elaborating the renamed object. */
549 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
551 /* For a debug renaming declaration, build a pure debug entity. */
552 if (Present (Debug_Renaming_Link (gnat_entity
)))
555 gnu_decl
= build_decl (VAR_DECL
, gnu_entity_id
, gnu_type
);
556 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
557 if (global_bindings_p ())
558 addr
= gen_rtx_CONST (VOIDmode
, const0_rtx
);
560 addr
= stack_pointer_rtx
;
561 SET_DECL_RTL (gnu_decl
, gen_rtx_MEM (Pmode
, addr
));
562 gnat_pushdecl (gnu_decl
, gnat_entity
);
566 /* If this is a loop variable, its type should be the base type.
567 This is because the code for processing a loop determines whether
568 a normal loop end test can be done by comparing the bounds of the
569 loop against those of the base type, which is presumed to be the
570 size used for computation. But this is not correct when the size
571 of the subtype is smaller than the type. */
572 if (kind
== E_Loop_Parameter
)
573 gnu_type
= get_base_type (gnu_type
);
575 /* Reject non-renamed objects whose types are unconstrained arrays or
576 any object whose type is a dummy type or VOID_TYPE. */
578 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
579 && No (Renamed_Object (gnat_entity
)))
580 || TYPE_IS_DUMMY_P (gnu_type
)
581 || TREE_CODE (gnu_type
) == VOID_TYPE
)
583 gcc_assert (type_annotate_only
);
586 return error_mark_node
;
589 /* If an alignment is specified, use it if valid. Note that
590 exceptions are objects but don't have alignments. We must do this
591 before we validate the size, since the alignment can affect the
593 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
595 gcc_assert (Present (Alignment (gnat_entity
)));
596 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
597 TYPE_ALIGN (gnu_type
));
598 gnu_type
= maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
599 "PAD", false, definition
, true);
602 /* If we are defining the object, see if it has a Size value and
603 validate it if so. If we are not defining the object and a Size
604 clause applies, simply retrieve the value. We don't want to ignore
605 the clause and it is expected to have been validated already. Then
606 get the new type, if any. */
608 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
609 gnat_entity
, VAR_DECL
, false,
610 Has_Size_Clause (gnat_entity
));
611 else if (Has_Size_Clause (gnat_entity
))
612 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
617 = make_type_from_size (gnu_type
, gnu_size
,
618 Has_Biased_Representation (gnat_entity
));
620 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
621 gnu_size
= NULL_TREE
;
624 /* If this object has self-referential size, it must be a record with
625 a default value. We are supposed to allocate an object of the
626 maximum size in this case unless it is a constant with an
627 initializing expression, in which case we can get the size from
628 that. Note that the resulting size may still be a variable, so
629 this may end up with an indirect allocation. */
630 if (No (Renamed_Object (gnat_entity
))
631 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
633 if (gnu_expr
&& kind
== E_Constant
)
635 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
636 if (CONTAINS_PLACEHOLDER_P (size
))
638 /* If the initializing expression is itself a constant,
639 despite having a nominal type with self-referential
640 size, we can get the size directly from it. */
641 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
642 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
645 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
646 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
647 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
648 || DECL_READONLY_ONCE_ELAB
649 (TREE_OPERAND (gnu_expr
, 0))))
650 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
653 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
658 /* We may have no GNU_EXPR because No_Initialization is
659 set even though there's an Expression. */
660 else if (kind
== E_Constant
661 && (Nkind (Declaration_Node (gnat_entity
))
662 == N_Object_Declaration
)
663 && Present (Expression (Declaration_Node (gnat_entity
))))
665 = TYPE_SIZE (gnat_to_gnu_type
667 (Expression (Declaration_Node (gnat_entity
)))));
670 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
675 /* If the size is zero bytes, make it one byte since some linkers have
676 trouble with zero-sized objects. If the object will have a
677 template, that will make it nonzero so don't bother. Also avoid
678 doing that for an object renaming or an object with an address
679 clause, as we would lose useful information on the view size
680 (e.g. for null array slices) and we are not allocating the object
683 && integer_zerop (gnu_size
)
684 && !TREE_OVERFLOW (gnu_size
))
685 || (TYPE_SIZE (gnu_type
)
686 && integer_zerop (TYPE_SIZE (gnu_type
))
687 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
688 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
689 || !Is_Array_Type (Etype (gnat_entity
)))
690 && !Present (Renamed_Object (gnat_entity
))
691 && !Present (Address_Clause (gnat_entity
)))
692 gnu_size
= bitsize_unit_node
;
694 /* If this is an object with no specified size and alignment, and
695 if either it is atomic or we are not optimizing alignment for
696 space and it is composite and not an exception, an Out parameter
697 or a reference to another object, and the size of its type is a
698 constant, set the alignment to the smallest one which is not
699 smaller than the size, with an appropriate cap. */
700 if (!gnu_size
&& align
== 0
701 && (Is_Atomic (gnat_entity
)
702 || (!Optimize_Alignment_Space (gnat_entity
)
703 && kind
!= E_Exception
704 && kind
!= E_Out_Parameter
705 && Is_Composite_Type (Etype (gnat_entity
))
706 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
708 && No (Renamed_Object (gnat_entity
))
709 && No (Address_Clause (gnat_entity
))))
710 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
712 /* No point in jumping through all the hoops needed in order
713 to support BIGGEST_ALIGNMENT if we don't really have to.
714 So we cap to the smallest alignment that corresponds to
715 a known efficient memory access pattern of the target. */
716 unsigned int align_cap
= Is_Atomic (gnat_entity
)
718 : get_mode_alignment (ptr_mode
);
720 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
721 || compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) >= 0)
724 align
= ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type
), 1));
726 /* But make sure not to under-align the object. */
727 if (align
<= TYPE_ALIGN (gnu_type
))
730 /* And honor the minimum valid atomic alignment, if any. */
731 #ifdef MINIMUM_ATOMIC_ALIGNMENT
732 else if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
733 align
= MINIMUM_ATOMIC_ALIGNMENT
;
737 /* If the object is set to have atomic components, find the component
738 type and validate it.
740 ??? Note that we ignore Has_Volatile_Components on objects; it's
741 not at all clear what to do in that case. */
743 if (Has_Atomic_Components (gnat_entity
))
745 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
746 ? TREE_TYPE (gnu_type
) : gnu_type
);
748 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
749 && TYPE_MULTI_ARRAY_P (gnu_inner
))
750 gnu_inner
= TREE_TYPE (gnu_inner
);
752 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
755 /* Now check if the type of the object allows atomic access. Note
756 that we must test the type, even if this object has size and
757 alignment to allow such access, because we will be going
758 inside the padded record to assign to the object. We could fix
759 this by always copying via an intermediate value, but it's not
760 clear it's worth the effort. */
761 if (Is_Atomic (gnat_entity
))
762 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
764 /* If this is an aliased object with an unconstrained nominal subtype,
765 make a type that includes the template. */
766 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
767 && Is_Array_Type (Etype (gnat_entity
))
768 && !type_annotate_only
)
771 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity
))));
774 = build_unc_object_type_from_ptr (gnu_fat
, gnu_type
,
775 concat_id_with_name (gnu_entity_id
,
779 #ifdef MINIMUM_ATOMIC_ALIGNMENT
780 /* If the size is a constant and no alignment is specified, force
781 the alignment to be the minimum valid atomic alignment. The
782 restriction on constant size avoids problems with variable-size
783 temporaries; if the size is variable, there's no issue with
784 atomic access. Also don't do this for a constant, since it isn't
785 necessary and can interfere with constant replacement. Finally,
786 do not do it for Out parameters since that creates an
787 size inconsistency with In parameters. */
788 if (align
== 0 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
789 && !FLOAT_TYPE_P (gnu_type
)
790 && !const_flag
&& No (Renamed_Object (gnat_entity
))
791 && !imported_p
&& No (Address_Clause (gnat_entity
))
792 && kind
!= E_Out_Parameter
793 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
794 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
795 align
= MINIMUM_ATOMIC_ALIGNMENT
;
798 /* Make a new type with the desired size and alignment, if needed.
799 But do not take into account alignment promotions to compute the
800 size of the object. */
801 gnu_object_size
= gnu_size
? gnu_size
: TYPE_SIZE (gnu_type
);
802 if (gnu_size
|| align
> 0)
803 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
804 "PAD", false, definition
,
805 gnu_size
? true : false);
807 /* If this is a renaming, avoid as much as possible to create a new
808 object. However, in several cases, creating it is required.
809 This processing needs to be applied to the raw expression so
810 as to make it more likely to rename the underlying object. */
811 if (Present (Renamed_Object (gnat_entity
)))
813 bool create_normal_object
= false;
815 /* If the renamed object had padding, strip off the reference
816 to the inner object and reset our type. */
817 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
818 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
820 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
821 /* Strip useless conversions around the object. */
822 || (TREE_CODE (gnu_expr
) == NOP_EXPR
823 && gnat_types_compatible_p
824 (TREE_TYPE (gnu_expr
),
825 TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))))
827 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
828 gnu_type
= TREE_TYPE (gnu_expr
);
831 /* Case 1: If this is a constant renaming stemming from a function
832 call, treat it as a normal object whose initial value is what
833 is being renamed. RM 3.3 says that the result of evaluating a
834 function call is a constant object. As a consequence, it can
835 be the inner object of a constant renaming. In this case, the
836 renaming must be fully instantiated, i.e. it cannot be a mere
837 reference to (part of) an existing object. */
840 tree inner_object
= gnu_expr
;
841 while (handled_component_p (inner_object
))
842 inner_object
= TREE_OPERAND (inner_object
, 0);
843 if (TREE_CODE (inner_object
) == CALL_EXPR
)
844 create_normal_object
= true;
847 /* Otherwise, see if we can proceed with a stabilized version of
848 the renamed entity or if we need to make a new object. */
849 if (!create_normal_object
)
851 tree maybe_stable_expr
= NULL_TREE
;
854 /* Case 2: If the renaming entity need not be materialized and
855 the renamed expression is something we can stabilize, use
856 that for the renaming. At the global level, we can only do
857 this if we know no SAVE_EXPRs need be made, because the
858 expression we return might be used in arbitrary conditional
859 branches so we must force the SAVE_EXPRs evaluation
860 immediately and this requires a function context. */
861 if (!Materialize_Entity (gnat_entity
)
862 && (!global_bindings_p ()
863 || (staticp (gnu_expr
)
864 && !TREE_SIDE_EFFECTS (gnu_expr
))))
867 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
871 gnu_decl
= maybe_stable_expr
;
872 /* ??? No DECL_EXPR is created so we need to mark
873 the expression manually lest it is shared. */
874 if (global_bindings_p ())
875 mark_visited (&gnu_decl
);
876 save_gnu_tree (gnat_entity
, gnu_decl
, true);
881 /* The stabilization failed. Keep maybe_stable_expr
882 untouched here to let the pointer case below know
883 about that failure. */
886 /* Case 3: If this is a constant renaming and creating a
887 new object is allowed and cheap, treat it as a normal
888 object whose initial value is what is being renamed. */
889 if (const_flag
&& Is_Elementary_Type (Etype (gnat_entity
)))
892 /* Case 4: Make this into a constant pointer to the object we
893 are to rename and attach the object to the pointer if it is
894 something we can stabilize.
896 From the proper scope, attached objects will be referenced
897 directly instead of indirectly via the pointer to avoid
898 subtle aliasing problems with non-addressable entities.
899 They have to be stable because we must not evaluate the
900 variables in the expression every time the renaming is used.
901 The pointer is called a "renaming" pointer in this case.
903 In the rare cases where we cannot stabilize the renamed
904 object, we just make a "bare" pointer, and the renamed
905 entity is always accessed indirectly through it. */
908 gnu_type
= build_reference_type (gnu_type
);
909 inner_const_flag
= TREE_READONLY (gnu_expr
);
912 /* If the previous attempt at stabilizing failed, there
913 is no point in trying again and we reuse the result
914 without attaching it to the pointer. In this case it
915 will only be used as the initializing expression of
916 the pointer and thus needs no special treatment with
917 regard to multiple evaluations. */
918 if (maybe_stable_expr
)
921 /* Otherwise, try to stabilize and attach the expression
922 to the pointer if the stabilization succeeds.
924 Note that this might introduce SAVE_EXPRs and we don't
925 check whether we're at the global level or not. This
926 is fine since we are building a pointer initializer and
927 neither the pointer nor the initializing expression can
928 be accessed before the pointer elaboration has taken
929 place in a correct program.
931 These SAVE_EXPRs will be evaluated at the right place
932 by either the evaluation of the initializer for the
933 non-global case or the elaboration code for the global
934 case, and will be attached to the elaboration procedure
935 in the latter case. */
939 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
942 renamed_obj
= maybe_stable_expr
;
944 /* Attaching is actually performed downstream, as soon
945 as we have a VAR_DECL for the pointer we make. */
949 = build_unary_op (ADDR_EXPR
, gnu_type
, maybe_stable_expr
);
951 gnu_size
= NULL_TREE
;
957 /* Make a volatile version of this object's type if we are to make
958 the object volatile. We also interpret 13.3(19) conservatively
959 and disallow any optimizations for an object covered by it. */
960 if ((Treat_As_Volatile (gnat_entity
)
961 || (Is_Exported (gnat_entity
)
962 /* Exclude exported constants created by the compiler,
963 which should boil down to static dispatch tables and
964 make it possible to put them in read-only memory. */
965 && (Comes_From_Source (gnat_entity
) || !const_flag
))
966 || Is_Imported (gnat_entity
)
967 || Present (Address_Clause (gnat_entity
)))
968 && !TYPE_VOLATILE (gnu_type
))
969 gnu_type
= build_qualified_type (gnu_type
,
970 (TYPE_QUALS (gnu_type
)
971 | TYPE_QUAL_VOLATILE
));
973 /* If we are defining an aliased object whose nominal subtype is
974 unconstrained, the object is a record that contains both the
975 template and the object. If there is an initializer, it will
976 have already been converted to the right type, but we need to
977 create the template if there is no initializer. */
980 && TREE_CODE (gnu_type
) == RECORD_TYPE
981 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
982 /* Beware that padding might have been introduced
983 via maybe_pad_type above. */
984 || (TYPE_IS_PADDING_P (gnu_type
)
985 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
987 && TYPE_CONTAINS_TEMPLATE_P
988 (TREE_TYPE (TYPE_FIELDS (gnu_type
))))))
991 = TYPE_IS_PADDING_P (gnu_type
)
992 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
993 : TYPE_FIELDS (gnu_type
);
996 = gnat_build_constructor
1000 build_template (TREE_TYPE (template_field
),
1001 TREE_TYPE (TREE_CHAIN (template_field
)),
1006 /* Convert the expression to the type of the object except in the
1007 case where the object's type is unconstrained or the object's type
1008 is a padded record whose field is of self-referential size. In
1009 the former case, converting will generate unnecessary evaluations
1010 of the CONSTRUCTOR to compute the size and in the latter case, we
1011 want to only copy the actual data. */
1013 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1014 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1015 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1016 && TYPE_IS_PADDING_P (gnu_type
)
1017 && (CONTAINS_PLACEHOLDER_P
1018 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
1019 gnu_expr
= convert (gnu_type
, gnu_expr
);
1021 /* If this is a pointer and it does not have an initializing
1022 expression, initialize it to NULL, unless the object is
1025 && (POINTER_TYPE_P (gnu_type
) || TYPE_FAT_POINTER_P (gnu_type
))
1026 && !Is_Imported (gnat_entity
) && !gnu_expr
)
1027 gnu_expr
= integer_zero_node
;
1029 /* If we are defining the object and it has an Address clause, we must
1030 either get the address expression from the saved GCC tree for the
1031 object if it has a Freeze node, or elaborate the address expression
1032 here since the front-end has guaranteed that the elaboration has no
1033 effects in this case. */
1034 if (definition
&& Present (Address_Clause (gnat_entity
)))
1037 = present_gnu_tree (gnat_entity
)
1038 ? get_gnu_tree (gnat_entity
)
1039 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
)));
1041 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1043 /* Ignore the size. It's either meaningless or was handled
1045 gnu_size
= NULL_TREE
;
1046 /* Convert the type of the object to a reference type that can
1047 alias everything as per 13.3(19). */
1049 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1050 gnu_address
= convert (gnu_type
, gnu_address
);
1052 const_flag
= !Is_Public (gnat_entity
)
1053 || compile_time_known_address_p (Expression (Address_Clause
1056 /* If this is a deferred constant, the initializer is attached to
1058 if (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
1061 (Expression (Declaration_Node (Full_View (gnat_entity
))));
1063 /* If we don't have an initializing expression for the underlying
1064 variable, the initializing expression for the pointer is the
1065 specified address. Otherwise, we have to make a COMPOUND_EXPR
1066 to assign both the address and the initial value. */
1068 gnu_expr
= gnu_address
;
1071 = build2 (COMPOUND_EXPR
, gnu_type
,
1073 (MODIFY_EXPR
, NULL_TREE
,
1074 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1080 /* If it has an address clause and we are not defining it, mark it
1081 as an indirect object. Likewise for Stdcall objects that are
1083 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1084 || (Is_Imported (gnat_entity
)
1085 && Has_Stdcall_Convention (gnat_entity
)))
1087 /* Convert the type of the object to a reference type that can
1088 alias everything as per 13.3(19). */
1090 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1091 gnu_size
= NULL_TREE
;
1093 /* No point in taking the address of an initializing expression
1094 that isn't going to be used. */
1095 gnu_expr
= NULL_TREE
;
1097 /* If it has an address clause whose value is known at compile
1098 time, make the object a CONST_DECL. This will avoid a
1099 useless dereference. */
1100 if (Present (Address_Clause (gnat_entity
)))
1102 Node_Id gnat_address
1103 = Expression (Address_Clause (gnat_entity
));
1105 if (compile_time_known_address_p (gnat_address
))
1107 gnu_expr
= gnat_to_gnu (gnat_address
);
1115 /* If we are at top level and this object is of variable size,
1116 make the actual type a hidden pointer to the real type and
1117 make the initializer be a memory allocation and initialization.
1118 Likewise for objects we aren't defining (presumed to be
1119 external references from other packages), but there we do
1120 not set up an initialization.
1122 If the object's size overflows, make an allocator too, so that
1123 Storage_Error gets raised. Note that we will never free
1124 such memory, so we presume it never will get allocated. */
1126 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1127 global_bindings_p () || !definition
1130 && ! allocatable_size_p (gnu_size
,
1131 global_bindings_p () || !definition
1134 gnu_type
= build_reference_type (gnu_type
);
1135 gnu_size
= NULL_TREE
;
1139 /* In case this was a aliased object whose nominal subtype is
1140 unconstrained, the pointer above will be a thin pointer and
1141 build_allocator will automatically make the template.
1143 If we have a template initializer only (that we made above),
1144 pretend there is none and rely on what build_allocator creates
1145 again anyway. Otherwise (if we have a full initializer), get
1146 the data part and feed that to build_allocator.
1148 If we are elaborating a mutable object, tell build_allocator to
1149 ignore a possibly simpler size from the initializer, if any, as
1150 we must allocate the maximum possible size in this case. */
1154 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1156 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1157 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1160 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1162 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1163 && 1 == VEC_length (constructor_elt
,
1164 CONSTRUCTOR_ELTS (gnu_expr
)))
1168 = build_component_ref
1169 (gnu_expr
, NULL_TREE
,
1170 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1174 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1175 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
))
1176 && !Is_Imported (gnat_entity
))
1177 post_error ("?Storage_Error will be raised at run-time!",
1180 gnu_expr
= build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1181 0, 0, gnat_entity
, mutable_p
);
1185 gnu_expr
= NULL_TREE
;
1190 /* If this object would go into the stack and has an alignment larger
1191 than the largest stack alignment the back-end can honor, resort to
1192 a variable of "aligning type". */
1193 if (!global_bindings_p () && !static_p
&& definition
1194 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1196 /* Create the new variable. No need for extra room before the
1197 aligned field as this is in automatic storage. */
1199 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1200 TYPE_SIZE_UNIT (gnu_type
),
1201 BIGGEST_ALIGNMENT
, 0);
1203 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1204 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1205 false, false, false, NULL
, gnat_entity
);
1207 /* Initialize the aligned field if we have an initializer. */
1210 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1212 (gnu_new_var
, NULL_TREE
,
1213 TYPE_FIELDS (gnu_new_type
), false),
1217 /* And setup this entity as a reference to the aligned field. */
1218 gnu_type
= build_reference_type (gnu_type
);
1221 (ADDR_EXPR
, gnu_type
,
1222 build_component_ref (gnu_new_var
, NULL_TREE
,
1223 TYPE_FIELDS (gnu_new_type
), false));
1225 gnu_size
= NULL_TREE
;
1231 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1232 | TYPE_QUAL_CONST
));
1234 /* Convert the expression to the type of the object except in the
1235 case where the object's type is unconstrained or the object's type
1236 is a padded record whose field is of self-referential size. In
1237 the former case, converting will generate unnecessary evaluations
1238 of the CONSTRUCTOR to compute the size and in the latter case, we
1239 want to only copy the actual data. */
1241 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1242 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1243 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1244 && TYPE_IS_PADDING_P (gnu_type
)
1245 && (CONTAINS_PLACEHOLDER_P
1246 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
1247 gnu_expr
= convert (gnu_type
, gnu_expr
);
1249 /* If this name is external or there was a name specified, use it,
1250 unless this is a VMS exception object since this would conflict
1251 with the symbol we need to export in addition. Don't use the
1252 Interface_Name if there is an address clause (see CD30005). */
1253 if (!Is_VMS_Exception (gnat_entity
)
1254 && ((Present (Interface_Name (gnat_entity
))
1255 && No (Address_Clause (gnat_entity
)))
1256 || (Is_Public (gnat_entity
)
1257 && (!Is_Imported (gnat_entity
)
1258 || Is_Exported (gnat_entity
)))))
1259 gnu_ext_name
= create_concat_name (gnat_entity
, 0);
1261 /* If this is constant initialized to a static constant and the
1262 object has an aggregate type, force it to be statically
1263 allocated. This will avoid an initialization copy. */
1264 if (!static_p
&& const_flag
1265 && gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1266 && AGGREGATE_TYPE_P (gnu_type
)
1267 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1268 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1269 && TYPE_IS_PADDING_P (gnu_type
)
1270 && !host_integerp (TYPE_SIZE_UNIT
1271 (TREE_TYPE (TYPE_FIELDS (gnu_type
))), 1)))
1274 gnu_decl
= create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1275 gnu_expr
, const_flag
,
1276 Is_Public (gnat_entity
),
1277 imported_p
|| !definition
,
1278 static_p
, attr_list
, gnat_entity
);
1279 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1280 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1281 if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1283 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1284 if (global_bindings_p ())
1286 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1287 record_global_renaming_pointer (gnu_decl
);
1291 if (definition
&& DECL_SIZE_UNIT (gnu_decl
)
1292 && get_block_jmpbuf_decl ()
1293 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl
)) != INTEGER_CST
1294 || (flag_stack_check
== GENERIC_STACK_CHECK
1295 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1296 STACK_CHECK_MAX_VAR_SIZE
) > 0)))
1297 add_stmt_with_node (build_call_1_expr
1298 (update_setjmp_buf_decl
,
1299 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1300 get_block_jmpbuf_decl ())),
1303 /* If we are defining an Out parameter and we're not optimizing,
1304 create a fake PARM_DECL for debugging purposes and make it
1305 point to the VAR_DECL. Suppress debug info for the latter
1306 but make sure it will still live on the stack so it can be
1307 accessed from within the debugger through the PARM_DECL. */
1308 if (kind
== E_Out_Parameter
&& definition
&& !optimize
)
1310 tree param
= create_param_decl (gnu_entity_id
, gnu_type
, false);
1311 gnat_pushdecl (param
, gnat_entity
);
1312 SET_DECL_VALUE_EXPR (param
, gnu_decl
);
1313 DECL_HAS_VALUE_EXPR_P (param
) = 1;
1315 debug_info_p
= false;
1317 DECL_IGNORED_P (param
) = 1;
1318 TREE_ADDRESSABLE (gnu_decl
) = 1;
1321 /* If this is a public constant or we're not optimizing and we're not
1322 making a VAR_DECL for it, make one just for export or debugger use.
1323 Likewise if the address is taken or if either the object or type is
1324 aliased. Make an external declaration for a reference, unless this
1325 is a Standard entity since there no real symbol at the object level
1327 if (TREE_CODE (gnu_decl
) == CONST_DECL
1328 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1329 && ((Is_Public (gnat_entity
)
1330 && !Present (Address_Clause (gnat_entity
)))
1332 || Address_Taken (gnat_entity
)
1333 || Is_Aliased (gnat_entity
)
1334 || Is_Aliased (Etype (gnat_entity
))))
1337 = create_true_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1338 gnu_expr
, true, Is_Public (gnat_entity
),
1339 !definition
, static_p
, NULL
,
1342 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1344 /* As debugging information will be generated for the variable,
1345 do not generate information for the constant. */
1346 DECL_IGNORED_P (gnu_decl
) = 1;
1349 /* If this is declared in a block that contains a block with an
1350 exception handler, we must force this variable in memory to
1351 suppress an invalid optimization. */
1352 if (Has_Nested_Block_With_Handler (Scope (gnat_entity
))
1353 && Exception_Mechanism
!= Back_End_Exceptions
)
1354 TREE_ADDRESSABLE (gnu_decl
) = 1;
1356 gnu_type
= TREE_TYPE (gnu_decl
);
1358 /* Back-annotate Alignment and Esize of the object if not already
1359 known, except for when the object is actually a pointer to the
1360 real object, since alignment and size of a pointer don't have
1361 anything to do with those of the designated object. Note that
1362 we pick the values of the type, not those of the object, to
1363 shield ourselves from low-level platform-dependent adjustments
1364 like alignment promotion. This is both consistent with all the
1365 treatment above, where alignment and size are set on the type of
1366 the object and not on the object directly, and makes it possible
1367 to support confirming representation clauses in all cases. */
1369 if (!used_by_ref
&& Unknown_Alignment (gnat_entity
))
1370 Set_Alignment (gnat_entity
,
1371 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
1373 if (!used_by_ref
&& Unknown_Esize (gnat_entity
))
1375 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1376 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1378 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
))));
1380 Set_Esize (gnat_entity
, annotate_value (gnu_object_size
));
1386 /* Return a TYPE_DECL for "void" that we previously made. */
1387 gnu_decl
= TYPE_NAME (void_type_node
);
1390 case E_Enumeration_Type
:
1391 /* A special case, for the types Character and Wide_Character in
1392 Standard, we do not list all the literals. So if the literals
1393 are not specified, make this an unsigned type. */
1394 if (No (First_Literal (gnat_entity
)))
1396 gnu_type
= make_unsigned_type (esize
);
1397 TYPE_NAME (gnu_type
) = gnu_entity_id
;
1399 /* Set TYPE_STRING_FLAG for Ada Character and Wide_Character types.
1400 This is needed by the DWARF-2 back-end to distinguish between
1401 unsigned integer types and character types. */
1402 TYPE_STRING_FLAG (gnu_type
) = 1;
1406 /* Normal case of non-character type, or non-Standard character type */
1408 /* Here we have a list of enumeral constants in First_Literal.
1409 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1410 the list to be places into TYPE_FIELDS. Each node in the list
1411 is a TREE_LIST node whose TREE_VALUE is the literal name
1412 and whose TREE_PURPOSE is the value of the literal.
1414 Esize contains the number of bits needed to represent the enumeral
1415 type, Type_Low_Bound also points to the first literal and
1416 Type_High_Bound points to the last literal. */
1418 Entity_Id gnat_literal
;
1419 tree gnu_literal_list
= NULL_TREE
;
1421 if (Is_Unsigned_Type (gnat_entity
))
1422 gnu_type
= make_unsigned_type (esize
);
1424 gnu_type
= make_signed_type (esize
);
1426 TREE_SET_CODE (gnu_type
, ENUMERAL_TYPE
);
1428 for (gnat_literal
= First_Literal (gnat_entity
);
1429 Present (gnat_literal
);
1430 gnat_literal
= Next_Literal (gnat_literal
))
1432 tree gnu_value
= UI_To_gnu (Enumeration_Rep (gnat_literal
),
1435 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1436 gnu_type
, gnu_value
, true, false, false,
1437 false, NULL
, gnat_literal
);
1439 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1440 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1441 gnu_value
, gnu_literal_list
);
1444 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1446 /* Note that the bounds are updated at the end of this function
1447 because to avoid an infinite recursion when we get the bounds of
1448 this type, since those bounds are objects of this type. */
1452 case E_Signed_Integer_Type
:
1453 case E_Ordinary_Fixed_Point_Type
:
1454 case E_Decimal_Fixed_Point_Type
:
1455 /* For integer types, just make a signed type the appropriate number
1457 gnu_type
= make_signed_type (esize
);
1460 case E_Modular_Integer_Type
:
1461 /* For modular types, make the unsigned type of the proper number of
1462 bits and then set up the modulus, if required. */
1464 enum machine_mode mode
;
1468 if (Is_Packed_Array_Type (gnat_entity
))
1469 esize
= UI_To_Int (RM_Size (gnat_entity
));
1471 /* Find the smallest mode at least ESIZE bits wide and make a class
1474 for (mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
1475 GET_MODE_BITSIZE (mode
) < esize
;
1476 mode
= GET_MODE_WIDER_MODE (mode
))
1479 gnu_type
= make_unsigned_type (GET_MODE_BITSIZE (mode
));
1480 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
1481 = (Is_Packed_Array_Type (gnat_entity
)
1482 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
1484 /* Get the modulus in this type. If it overflows, assume it is because
1485 it is equal to 2**Esize. Note that there is no overflow checking
1486 done on unsigned type, so we detect the overflow by looking for
1487 a modulus of zero, which is otherwise invalid. */
1488 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1490 if (!integer_zerop (gnu_modulus
))
1492 TYPE_MODULAR_P (gnu_type
) = 1;
1493 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1494 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1495 convert (gnu_type
, integer_one_node
));
1498 /* If we have to set TYPE_PRECISION different from its natural value,
1499 make a subtype to do do. Likewise if there is a modulus and
1500 it is not one greater than TYPE_MAX_VALUE. */
1501 if (TYPE_PRECISION (gnu_type
) != esize
1502 || (TYPE_MODULAR_P (gnu_type
)
1503 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type
), gnu_high
)))
1505 tree gnu_subtype
= make_node (INTEGER_TYPE
);
1507 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1508 TREE_TYPE (gnu_subtype
) = gnu_type
;
1509 TYPE_MIN_VALUE (gnu_subtype
) = TYPE_MIN_VALUE (gnu_type
);
1510 TYPE_MAX_VALUE (gnu_subtype
)
1511 = TYPE_MODULAR_P (gnu_type
)
1512 ? gnu_high
: TYPE_MAX_VALUE (gnu_type
);
1513 TYPE_PRECISION (gnu_subtype
) = esize
;
1514 TYPE_UNSIGNED (gnu_subtype
) = 1;
1515 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1516 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype
)
1517 = (Is_Packed_Array_Type (gnat_entity
)
1518 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
1519 layout_type (gnu_subtype
);
1521 gnu_type
= gnu_subtype
;
1526 case E_Signed_Integer_Subtype
:
1527 case E_Enumeration_Subtype
:
1528 case E_Modular_Integer_Subtype
:
1529 case E_Ordinary_Fixed_Point_Subtype
:
1530 case E_Decimal_Fixed_Point_Subtype
:
1532 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1533 that we do not want to call build_range_type since we would
1534 like each subtype node to be distinct. This will be important
1535 when memory aliasing is implemented.
1537 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1538 parent type; this fact is used by the arithmetic conversion
1541 We elaborate the Ancestor_Subtype if it is not in the current
1542 unit and one of our bounds is non-static. We do this to ensure
1543 consistent naming in the case where several subtypes share the same
1544 bounds by always elaborating the first such subtype first, thus
1548 && Present (Ancestor_Subtype (gnat_entity
))
1549 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1550 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1551 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1552 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1555 gnu_type
= make_node (INTEGER_TYPE
);
1556 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1558 /* Set the precision to the Esize except for bit-packed arrays and
1559 subtypes of Standard.Boolean. */
1560 if (Is_Packed_Array_Type (gnat_entity
)
1561 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1563 esize
= UI_To_Int (RM_Size (gnat_entity
));
1564 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1566 else if (TREE_CODE (TREE_TYPE (gnu_type
)) == BOOLEAN_TYPE
)
1569 TYPE_PRECISION (gnu_type
) = esize
;
1571 TYPE_MIN_VALUE (gnu_type
)
1572 = convert (TREE_TYPE (gnu_type
),
1573 elaborate_expression (Type_Low_Bound (gnat_entity
),
1575 get_identifier ("L"), definition
, 1,
1576 Needs_Debug_Info (gnat_entity
)));
1578 TYPE_MAX_VALUE (gnu_type
)
1579 = convert (TREE_TYPE (gnu_type
),
1580 elaborate_expression (Type_High_Bound (gnat_entity
),
1582 get_identifier ("U"), definition
, 1,
1583 Needs_Debug_Info (gnat_entity
)));
1585 /* One of the above calls might have caused us to be elaborated,
1586 so don't blow up if so. */
1587 if (present_gnu_tree (gnat_entity
))
1589 maybe_present
= true;
1593 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1594 = Has_Biased_Representation (gnat_entity
);
1596 /* This should be an unsigned type if the lower bound is constant
1597 and non-negative or if the base type is unsigned; a signed type
1599 TYPE_UNSIGNED (gnu_type
)
1600 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type
))
1601 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type
)) == INTEGER_CST
1602 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type
)) >= 0)
1603 || TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1604 || Is_Unsigned_Type (gnat_entity
));
1606 layout_type (gnu_type
);
1608 /* Inherit our alias set from what we're a subtype of. Subtypes
1609 are not different types and a pointer can designate any instance
1610 within a subtype hierarchy. */
1611 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1613 /* If the type we are dealing with is to represent a packed array,
1614 we need to have the bits left justified on big-endian targets
1615 and right justified on little-endian targets. We also need to
1616 ensure that when the value is read (e.g. for comparison of two
1617 such values), we only get the good bits, since the unused bits
1618 are uninitialized. Both goals are accomplished by wrapping the
1619 modular value in an enclosing struct. */
1620 if (Is_Packed_Array_Type (gnat_entity
)
1621 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1623 tree gnu_field_type
= gnu_type
;
1626 TYPE_RM_SIZE_NUM (gnu_field_type
)
1627 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
1628 gnu_type
= make_node (RECORD_TYPE
);
1629 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1631 /* Propagate the alignment of the modular type to the record.
1632 This means that bitpacked arrays have "ceil" alignment for
1633 their size, which may seem counter-intuitive but makes it
1634 possible to easily overlay them on modular types. */
1635 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_field_type
);
1636 TYPE_PACKED (gnu_type
) = 1;
1638 /* Create a stripped-down declaration of the original type, mainly
1640 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1641 NULL
, true, debug_info_p
, gnat_entity
);
1643 /* Don't notify the field as "addressable", since we won't be taking
1644 it's address and it would prevent create_field_decl from making a
1646 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1647 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1649 finish_record_type (gnu_type
, gnu_field
, 0, false);
1650 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1651 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1653 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1656 /* If the type we are dealing with has got a smaller alignment than the
1657 natural one, we need to wrap it up in a record type and under-align
1658 the latter. We reuse the padding machinery for this purpose. */
1659 else if (Known_Alignment (gnat_entity
)
1660 && UI_Is_In_Int_Range (Alignment (gnat_entity
))
1661 && (align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
)
1662 && align
< TYPE_ALIGN (gnu_type
))
1664 tree gnu_field_type
= gnu_type
;
1667 gnu_type
= make_node (RECORD_TYPE
);
1668 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "PAD");
1670 TYPE_ALIGN (gnu_type
) = align
;
1671 TYPE_PACKED (gnu_type
) = 1;
1673 /* Create a stripped-down declaration of the original type, mainly
1675 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1676 NULL
, true, debug_info_p
, gnat_entity
);
1678 /* Don't notify the field as "addressable", since we won't be taking
1679 it's address and it would prevent create_field_decl from making a
1681 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1682 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1684 finish_record_type (gnu_type
, gnu_field
, 0, false);
1685 TYPE_IS_PADDING_P (gnu_type
) = 1;
1686 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1688 relate_alias_sets (gnu_type
, gnu_field_type
, ALIAS_SET_COPY
);
1691 /* Otherwise reset the alignment lest we computed it above. */
1697 case E_Floating_Point_Type
:
1698 /* If this is a VAX floating-point type, use an integer of the proper
1699 size. All the operations will be handled with ASM statements. */
1700 if (Vax_Float (gnat_entity
))
1702 gnu_type
= make_signed_type (esize
);
1703 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1704 SET_TYPE_DIGITS_VALUE (gnu_type
,
1705 UI_To_gnu (Digits_Value (gnat_entity
),
1710 /* The type of the Low and High bounds can be our type if this is
1711 a type from Standard, so set them at the end of the function. */
1712 gnu_type
= make_node (REAL_TYPE
);
1713 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1714 layout_type (gnu_type
);
1717 case E_Floating_Point_Subtype
:
1718 if (Vax_Float (gnat_entity
))
1720 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1726 && Present (Ancestor_Subtype (gnat_entity
))
1727 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1728 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1729 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1730 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1733 gnu_type
= make_node (REAL_TYPE
);
1734 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1735 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1737 TYPE_MIN_VALUE (gnu_type
)
1738 = convert (TREE_TYPE (gnu_type
),
1739 elaborate_expression (Type_Low_Bound (gnat_entity
),
1740 gnat_entity
, get_identifier ("L"),
1742 Needs_Debug_Info (gnat_entity
)));
1744 TYPE_MAX_VALUE (gnu_type
)
1745 = convert (TREE_TYPE (gnu_type
),
1746 elaborate_expression (Type_High_Bound (gnat_entity
),
1747 gnat_entity
, get_identifier ("U"),
1749 Needs_Debug_Info (gnat_entity
)));
1751 /* One of the above calls might have caused us to be elaborated,
1752 so don't blow up if so. */
1753 if (present_gnu_tree (gnat_entity
))
1755 maybe_present
= true;
1759 layout_type (gnu_type
);
1761 /* Inherit our alias set from what we're a subtype of, as for
1762 integer subtypes. */
1763 relate_alias_sets (gnu_type
, TREE_TYPE (gnu_type
), ALIAS_SET_COPY
);
1767 /* Array and String Types and Subtypes
1769 Unconstrained array types are represented by E_Array_Type and
1770 constrained array types are represented by E_Array_Subtype. There
1771 are no actual objects of an unconstrained array type; all we have
1772 are pointers to that type.
1774 The following fields are defined on array types and subtypes:
1776 Component_Type Component type of the array.
1777 Number_Dimensions Number of dimensions (an int).
1778 First_Index Type of first index. */
1783 tree gnu_template_fields
= NULL_TREE
;
1784 tree gnu_template_type
= make_node (RECORD_TYPE
);
1785 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
1786 tree gnu_fat_type
= make_node (RECORD_TYPE
);
1787 int ndim
= Number_Dimensions (gnat_entity
);
1789 = (Convention (gnat_entity
) == Convention_Fortran
) ? ndim
- 1 : 0;
1791 = (Convention (gnat_entity
) == Convention_Fortran
) ? - 1 : 1;
1793 tree
*gnu_index_types
= (tree
*) alloca (ndim
* sizeof (tree
*));
1794 tree
*gnu_temp_fields
= (tree
*) alloca (ndim
* sizeof (tree
*));
1795 tree gnu_comp_size
= 0;
1796 tree gnu_max_size
= size_one_node
;
1797 tree gnu_max_size_unit
;
1798 Entity_Id gnat_ind_subtype
;
1799 Entity_Id gnat_ind_base_subtype
;
1800 tree gnu_template_reference
;
1803 TYPE_NAME (gnu_template_type
)
1804 = create_concat_name (gnat_entity
, "XUB");
1806 /* Make a node for the array. If we are not defining the array
1807 suppress expanding incomplete types. */
1808 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
1811 defer_incomplete_level
++, this_deferred
= true;
1813 /* Build the fat pointer type. Use a "void *" object instead of
1814 a pointer to the array type since we don't have the array type
1815 yet (it will reference the fat pointer via the bounds). */
1816 tem
= chainon (chainon (NULL_TREE
,
1817 create_field_decl (get_identifier ("P_ARRAY"),
1819 gnu_fat_type
, 0, 0, 0, 0)),
1820 create_field_decl (get_identifier ("P_BOUNDS"),
1822 gnu_fat_type
, 0, 0, 0, 0));
1824 /* Make sure we can put this into a register. */
1825 TYPE_ALIGN (gnu_fat_type
) = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
1827 /* Do not finalize this record type since the types of its fields
1828 are still incomplete at this point. */
1829 finish_record_type (gnu_fat_type
, tem
, 0, true);
1830 TYPE_IS_FAT_POINTER_P (gnu_fat_type
) = 1;
1832 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1833 is the fat pointer. This will be used to access the individual
1834 fields once we build them. */
1835 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
1836 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
1837 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
1838 gnu_template_reference
1839 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
1840 TREE_READONLY (gnu_template_reference
) = 1;
1842 /* Now create the GCC type for each index and add the fields for
1843 that index to the template. */
1844 for (index
= firstdim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1845 gnat_ind_base_subtype
1846 = First_Index (Implementation_Base_Type (gnat_entity
));
1847 index
< ndim
&& index
>= 0;
1849 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1850 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1852 char field_name
[10];
1853 tree gnu_ind_subtype
1854 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype
)));
1855 tree gnu_base_subtype
1856 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1858 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1860 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1861 tree gnu_min_field
, gnu_max_field
, gnu_min
, gnu_max
;
1863 /* Make the FIELD_DECLs for the minimum and maximum of this
1864 type and then make extractions of that field from the
1866 sprintf (field_name
, "LB%d", index
);
1867 gnu_min_field
= create_field_decl (get_identifier (field_name
),
1869 gnu_template_type
, 0, 0, 0, 0);
1870 field_name
[0] = 'U';
1871 gnu_max_field
= create_field_decl (get_identifier (field_name
),
1873 gnu_template_type
, 0, 0, 0, 0);
1875 Sloc_to_locus (Sloc (gnat_entity
),
1876 &DECL_SOURCE_LOCATION (gnu_min_field
));
1877 Sloc_to_locus (Sloc (gnat_entity
),
1878 &DECL_SOURCE_LOCATION (gnu_max_field
));
1879 gnu_temp_fields
[index
] = chainon (gnu_min_field
, gnu_max_field
);
1881 /* We can't use build_component_ref here since the template
1882 type isn't complete yet. */
1883 gnu_min
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1884 gnu_template_reference
, gnu_min_field
,
1886 gnu_max
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1887 gnu_template_reference
, gnu_max_field
,
1889 TREE_READONLY (gnu_min
) = TREE_READONLY (gnu_max
) = 1;
1891 /* Make a range type with the new ranges, but using
1892 the Ada subtype. Then we convert to sizetype. */
1893 gnu_index_types
[index
]
1894 = create_index_type (convert (sizetype
, gnu_min
),
1895 convert (sizetype
, gnu_max
),
1896 build_range_type (gnu_ind_subtype
,
1899 /* Update the maximum size of the array, in elements. */
1901 = size_binop (MULT_EXPR
, gnu_max_size
,
1902 size_binop (PLUS_EXPR
, size_one_node
,
1903 size_binop (MINUS_EXPR
, gnu_base_max
,
1906 TYPE_NAME (gnu_index_types
[index
])
1907 = create_concat_name (gnat_entity
, field_name
);
1910 for (index
= 0; index
< ndim
; index
++)
1912 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
1914 /* Install all the fields into the template. */
1915 finish_record_type (gnu_template_type
, gnu_template_fields
, 0, false);
1916 TYPE_READONLY (gnu_template_type
) = 1;
1918 /* Now make the array of arrays and update the pointer to the array
1919 in the fat pointer. Note that it is the first field. */
1920 tem
= gnat_to_gnu_type (Component_Type (gnat_entity
));
1922 /* Try to get a smaller form of the component if needed. */
1923 if ((Is_Packed (gnat_entity
)
1924 || Has_Component_Size_Clause (gnat_entity
))
1925 && !Is_Bit_Packed_Array (gnat_entity
)
1926 && !Has_Aliased_Components (gnat_entity
)
1927 && !Strict_Alignment (Component_Type (gnat_entity
))
1928 && TREE_CODE (tem
) == RECORD_TYPE
1929 && !TYPE_IS_FAT_POINTER_P (tem
)
1930 && host_integerp (TYPE_SIZE (tem
), 1))
1931 tem
= make_packable_type (tem
, false);
1933 if (Has_Atomic_Components (gnat_entity
))
1934 check_ok_for_atomic (tem
, gnat_entity
, true);
1936 /* Get and validate any specified Component_Size, but if Packed,
1937 ignore it since the front end will have taken care of it. */
1939 = validate_size (Component_Size (gnat_entity
), tem
,
1941 (Is_Bit_Packed_Array (gnat_entity
)
1942 ? TYPE_DECL
: VAR_DECL
),
1943 true, Has_Component_Size_Clause (gnat_entity
));
1945 /* If the component type is a RECORD_TYPE that has a self-referential
1946 size, use the maximum size. */
1947 if (!gnu_comp_size
&& TREE_CODE (tem
) == RECORD_TYPE
1948 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem
)))
1949 gnu_comp_size
= max_size (TYPE_SIZE (tem
), true);
1951 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_entity
))
1954 tem
= make_type_from_size (tem
, gnu_comp_size
, false);
1956 tem
= maybe_pad_type (tem
, gnu_comp_size
, 0, gnat_entity
,
1957 "C_PAD", false, definition
, true);
1958 /* If a padding record was made, declare it now since it will
1959 never be declared otherwise. This is necessary to ensure
1960 that its subtrees are properly marked. */
1961 if (tem
!= orig_tem
)
1962 create_type_decl (TYPE_NAME (tem
), tem
, NULL
, true,
1963 debug_info_p
, gnat_entity
);
1966 if (Has_Volatile_Components (gnat_entity
))
1967 tem
= build_qualified_type (tem
,
1968 TYPE_QUALS (tem
) | TYPE_QUAL_VOLATILE
);
1970 /* If Component_Size is not already specified, annotate it with the
1971 size of the component. */
1972 if (Unknown_Component_Size (gnat_entity
))
1973 Set_Component_Size (gnat_entity
, annotate_value (TYPE_SIZE (tem
)));
1975 gnu_max_size_unit
= size_binop (MAX_EXPR
, size_zero_node
,
1976 size_binop (MULT_EXPR
, gnu_max_size
,
1977 TYPE_SIZE_UNIT (tem
)));
1978 gnu_max_size
= size_binop (MAX_EXPR
, bitsize_zero_node
,
1979 size_binop (MULT_EXPR
,
1980 convert (bitsizetype
,
1984 for (index
= ndim
- 1; index
>= 0; index
--)
1986 tem
= build_array_type (tem
, gnu_index_types
[index
]);
1987 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
1988 if (array_type_has_nonaliased_component (gnat_entity
, tem
))
1989 TYPE_NONALIASED_COMPONENT (tem
) = 1;
1992 /* If an alignment is specified, use it if valid. But ignore it for
1993 types that represent the unpacked base type for packed arrays. If
1994 the alignment was requested with an explicit user alignment clause,
1996 if (No (Packed_Array_Type (gnat_entity
))
1997 && Known_Alignment (gnat_entity
))
1999 gcc_assert (Present (Alignment (gnat_entity
)));
2001 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
2003 if (Present (Alignment_Clause (gnat_entity
)))
2004 TYPE_USER_ALIGN (tem
) = 1;
2007 TYPE_CONVENTION_FORTRAN_P (tem
)
2008 = (Convention (gnat_entity
) == Convention_Fortran
);
2009 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
2011 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2012 corresponding fat pointer. */
2013 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
)
2014 = TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
2015 SET_TYPE_MODE (gnu_type
, BLKmode
);
2016 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
2017 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
2019 /* If the maximum size doesn't overflow, use it. */
2020 if (TREE_CODE (gnu_max_size
) == INTEGER_CST
2021 && !TREE_OVERFLOW (gnu_max_size
))
2023 = size_binop (MIN_EXPR
, gnu_max_size
, TYPE_SIZE (tem
));
2024 if (TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2025 && !TREE_OVERFLOW (gnu_max_size_unit
))
2026 TYPE_SIZE_UNIT (tem
)
2027 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2028 TYPE_SIZE_UNIT (tem
));
2030 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
2031 tem
, NULL
, !Comes_From_Source (gnat_entity
),
2032 debug_info_p
, gnat_entity
);
2034 /* Give the fat pointer type a name. */
2035 create_type_decl (create_concat_name (gnat_entity
, "XUP"),
2036 gnu_fat_type
, NULL
, true,
2037 debug_info_p
, gnat_entity
);
2039 /* Create the type to be used as what a thin pointer designates: an
2040 record type for the object and its template with the field offsets
2041 shifted to have the template at a negative offset. */
2042 tem
= build_unc_object_type (gnu_template_type
, tem
,
2043 create_concat_name (gnat_entity
, "XUT"));
2044 shift_unc_components_for_thin_pointers (tem
);
2046 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
2047 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
2049 /* Give the thin pointer type a name. */
2050 create_type_decl (create_concat_name (gnat_entity
, "XUX"),
2051 build_pointer_type (tem
), NULL
, true,
2052 debug_info_p
, gnat_entity
);
2056 case E_String_Subtype
:
2057 case E_Array_Subtype
:
2059 /* This is the actual data type for array variables. Multidimensional
2060 arrays are implemented in the gnu tree as arrays of arrays. Note
2061 that for the moment arrays which have sparse enumeration subtypes as
2062 index components create sparse arrays, which is obviously space
2063 inefficient but so much easier to code for now.
2065 Also note that the subtype never refers to the unconstrained
2066 array type, which is somewhat at variance with Ada semantics.
2068 First check to see if this is simply a renaming of the array
2069 type. If so, the result is the array type. */
2071 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
2072 if (!Is_Constrained (gnat_entity
))
2077 int array_dim
= Number_Dimensions (gnat_entity
);
2079 = ((Convention (gnat_entity
) == Convention_Fortran
)
2080 ? array_dim
- 1 : 0);
2082 = (Convention (gnat_entity
) == Convention_Fortran
) ? -1 : 1;
2083 Entity_Id gnat_ind_subtype
;
2084 Entity_Id gnat_ind_base_subtype
;
2085 tree gnu_base_type
= gnu_type
;
2086 tree
*gnu_index_type
= (tree
*) alloca (array_dim
* sizeof (tree
*));
2087 tree gnu_comp_size
= NULL_TREE
;
2088 tree gnu_max_size
= size_one_node
;
2089 tree gnu_max_size_unit
;
2090 bool need_index_type_struct
= false;
2091 bool max_overflow
= false;
2093 /* First create the gnu types for each index. Create types for
2094 debugging information to point to the index types if the
2095 are not integer types, have variable bounds, or are
2096 wider than sizetype. */
2098 for (index
= first_dim
, gnat_ind_subtype
= First_Index (gnat_entity
),
2099 gnat_ind_base_subtype
2100 = First_Index (Implementation_Base_Type (gnat_entity
));
2101 index
< array_dim
&& index
>= 0;
2103 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
2104 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
2106 tree gnu_index_subtype
2107 = get_unpadded_type (Etype (gnat_ind_subtype
));
2109 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_subtype
));
2111 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_subtype
));
2112 tree gnu_base_subtype
2113 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
2115 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
2117 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
2118 tree gnu_base_type
= get_base_type (gnu_base_subtype
);
2119 tree gnu_base_base_min
2120 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_type
));
2121 tree gnu_base_base_max
2122 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_type
));
2126 /* If the minimum and maximum values both overflow in
2127 SIZETYPE, but the difference in the original type
2128 does not overflow in SIZETYPE, ignore the overflow
2130 if ((TYPE_PRECISION (gnu_index_subtype
)
2131 > TYPE_PRECISION (sizetype
)
2132 || TYPE_UNSIGNED (gnu_index_subtype
)
2133 != TYPE_UNSIGNED (sizetype
))
2134 && TREE_CODE (gnu_min
) == INTEGER_CST
2135 && TREE_CODE (gnu_max
) == INTEGER_CST
2136 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2138 (fold_build2 (MINUS_EXPR
, gnu_index_subtype
,
2139 TYPE_MAX_VALUE (gnu_index_subtype
),
2140 TYPE_MIN_VALUE (gnu_index_subtype
)))))
2142 TREE_OVERFLOW (gnu_min
) = 0;
2143 TREE_OVERFLOW (gnu_max
) = 0;
2146 /* Similarly, if the range is null, use bounds of 1..0 for
2147 the sizetype bounds. */
2148 else if ((TYPE_PRECISION (gnu_index_subtype
)
2149 > TYPE_PRECISION (sizetype
)
2150 || TYPE_UNSIGNED (gnu_index_subtype
)
2151 != TYPE_UNSIGNED (sizetype
))
2152 && TREE_CODE (gnu_min
) == INTEGER_CST
2153 && TREE_CODE (gnu_max
) == INTEGER_CST
2154 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2155 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype
),
2156 TYPE_MIN_VALUE (gnu_index_subtype
)))
2157 gnu_min
= size_one_node
, gnu_max
= size_zero_node
;
2159 /* Now compute the size of this bound. We need to provide
2160 GCC with an upper bound to use but have to deal with the
2161 "superflat" case. There are three ways to do this. If we
2162 can prove that the array can never be superflat, we can
2163 just use the high bound of the index subtype. If we can
2164 prove that the low bound minus one can't overflow, we
2165 can do this as MAX (hb, lb - 1). Otherwise, we have to use
2166 the expression hb >= lb ? hb : lb - 1. */
2167 gnu_high
= size_binop (MINUS_EXPR
, gnu_min
, size_one_node
);
2169 /* See if the base array type is already flat. If it is, we
2170 are probably compiling an ACVC test, but it will cause the
2171 code below to malfunction if we don't handle it specially. */
2172 if (TREE_CODE (gnu_base_min
) == INTEGER_CST
2173 && TREE_CODE (gnu_base_max
) == INTEGER_CST
2174 && !TREE_OVERFLOW (gnu_base_min
)
2175 && !TREE_OVERFLOW (gnu_base_max
)
2176 && tree_int_cst_lt (gnu_base_max
, gnu_base_min
))
2177 gnu_high
= size_zero_node
, gnu_min
= size_one_node
;
2179 /* If gnu_high is now an integer which overflowed, the array
2180 cannot be superflat. */
2181 else if (TREE_CODE (gnu_high
) == INTEGER_CST
2182 && TREE_OVERFLOW (gnu_high
))
2184 else if (TYPE_UNSIGNED (gnu_base_subtype
)
2185 || TREE_CODE (gnu_high
) == INTEGER_CST
)
2186 gnu_high
= size_binop (MAX_EXPR
, gnu_max
, gnu_high
);
2190 (sizetype
, build_binary_op (GE_EXPR
, integer_type_node
,
2194 gnu_index_type
[index
]
2195 = create_index_type (gnu_min
, gnu_high
, gnu_index_subtype
,
2198 /* Also compute the maximum size of the array. Here we
2199 see if any constraint on the index type of the base type
2200 can be used in the case of self-referential bound on
2201 the index type of the subtype. We look for a non-"infinite"
2202 and non-self-referential bound from any type involved and
2203 handle each bound separately. */
2205 if ((TREE_CODE (gnu_min
) == INTEGER_CST
2206 && !TREE_OVERFLOW (gnu_min
)
2207 && !operand_equal_p (gnu_min
, gnu_base_base_min
, 0))
2208 || !CONTAINS_PLACEHOLDER_P (gnu_min
)
2209 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2210 && !TREE_OVERFLOW (gnu_base_min
)))
2211 gnu_base_min
= gnu_min
;
2213 if ((TREE_CODE (gnu_max
) == INTEGER_CST
2214 && !TREE_OVERFLOW (gnu_max
)
2215 && !operand_equal_p (gnu_max
, gnu_base_base_max
, 0))
2216 || !CONTAINS_PLACEHOLDER_P (gnu_max
)
2217 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2218 && !TREE_OVERFLOW (gnu_base_max
)))
2219 gnu_base_max
= gnu_max
;
2221 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2222 && TREE_OVERFLOW (gnu_base_min
))
2223 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2224 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2225 && TREE_OVERFLOW (gnu_base_max
))
2226 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2227 max_overflow
= true;
2229 gnu_base_min
= size_binop (MAX_EXPR
, gnu_base_min
, gnu_min
);
2230 gnu_base_max
= size_binop (MIN_EXPR
, gnu_base_max
, gnu_max
);
2233 = size_binop (MAX_EXPR
,
2234 size_binop (PLUS_EXPR
, size_one_node
,
2235 size_binop (MINUS_EXPR
, gnu_base_max
,
2239 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2240 && TREE_OVERFLOW (gnu_this_max
))
2241 max_overflow
= true;
2244 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2246 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype
))
2247 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype
))
2249 || TREE_CODE (gnu_index_subtype
) != INTEGER_TYPE
2250 || (TREE_TYPE (gnu_index_subtype
)
2251 && (TREE_CODE (TREE_TYPE (gnu_index_subtype
))
2253 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype
)
2254 || (TYPE_PRECISION (gnu_index_subtype
)
2255 > TYPE_PRECISION (sizetype
)))
2256 need_index_type_struct
= true;
2259 /* Then flatten: create the array of arrays. For an array type
2260 used to implement a packed array, get the component type from
2261 the original array type since the representation clauses that
2262 can affect it are on the latter. */
2263 if (Is_Packed_Array_Type (gnat_entity
)
2264 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2266 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2267 for (index
= array_dim
- 1; index
>= 0; index
--)
2268 gnu_type
= TREE_TYPE (gnu_type
);
2270 /* One of the above calls might have caused us to be elaborated,
2271 so don't blow up if so. */
2272 if (present_gnu_tree (gnat_entity
))
2274 maybe_present
= true;
2280 gnu_type
= gnat_to_gnu_type (Component_Type (gnat_entity
));
2282 /* One of the above calls might have caused us to be elaborated,
2283 so don't blow up if so. */
2284 if (present_gnu_tree (gnat_entity
))
2286 maybe_present
= true;
2290 /* Try to get a smaller form of the component if needed. */
2291 if ((Is_Packed (gnat_entity
)
2292 || Has_Component_Size_Clause (gnat_entity
))
2293 && !Is_Bit_Packed_Array (gnat_entity
)
2294 && !Has_Aliased_Components (gnat_entity
)
2295 && !Strict_Alignment (Component_Type (gnat_entity
))
2296 && TREE_CODE (gnu_type
) == RECORD_TYPE
2297 && !TYPE_IS_FAT_POINTER_P (gnu_type
)
2298 && host_integerp (TYPE_SIZE (gnu_type
), 1))
2299 gnu_type
= make_packable_type (gnu_type
, false);
2301 /* Get and validate any specified Component_Size, but if Packed,
2302 ignore it since the front end will have taken care of it. */
2304 = validate_size (Component_Size (gnat_entity
), gnu_type
,
2306 (Is_Bit_Packed_Array (gnat_entity
)
2307 ? TYPE_DECL
: VAR_DECL
), true,
2308 Has_Component_Size_Clause (gnat_entity
));
2310 /* If the component type is a RECORD_TYPE that has a
2311 self-referential size, use the maximum size. */
2313 && TREE_CODE (gnu_type
) == RECORD_TYPE
2314 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2315 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
2317 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_entity
))
2321 = make_type_from_size (gnu_type
, gnu_comp_size
, false);
2322 orig_gnu_type
= gnu_type
;
2323 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0,
2324 gnat_entity
, "C_PAD", false,
2326 /* If a padding record was made, declare it now since it
2327 will never be declared otherwise. This is necessary
2328 to ensure that its subtrees are properly marked. */
2329 if (gnu_type
!= orig_gnu_type
)
2330 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
,
2331 true, debug_info_p
, gnat_entity
);
2334 if (Has_Volatile_Components (Base_Type (gnat_entity
)))
2335 gnu_type
= build_qualified_type (gnu_type
,
2336 (TYPE_QUALS (gnu_type
)
2337 | TYPE_QUAL_VOLATILE
));
2340 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2341 TYPE_SIZE_UNIT (gnu_type
));
2342 gnu_max_size
= size_binop (MULT_EXPR
,
2343 convert (bitsizetype
, gnu_max_size
),
2344 TYPE_SIZE (gnu_type
));
2346 for (index
= array_dim
- 1; index
>= 0; index
--)
2348 gnu_type
= build_array_type (gnu_type
, gnu_index_type
[index
]);
2349 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2350 if (array_type_has_nonaliased_component (gnat_entity
, gnu_type
))
2351 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2354 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2355 if (need_index_type_struct
)
2356 TYPE_STUB_DECL (gnu_type
)
2357 = create_type_stub_decl (gnu_entity_id
, gnu_type
);
2359 /* If we are at file level and this is a multi-dimensional array, we
2360 need to make a variable corresponding to the stride of the
2361 inner dimensions. */
2362 if (global_bindings_p () && array_dim
> 1)
2364 tree gnu_str_name
= get_identifier ("ST");
2367 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2368 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2369 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2370 gnu_str_name
= concat_id_with_name (gnu_str_name
, "ST"))
2372 tree eltype
= TREE_TYPE (gnu_arr_type
);
2374 TYPE_SIZE (gnu_arr_type
)
2375 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
2376 TYPE_SIZE (gnu_arr_type
),
2377 gnu_str_name
, definition
, 0);
2379 /* ??? For now, store the size as a multiple of the
2380 alignment of the element type in bytes so that we
2381 can see the alignment from the tree. */
2382 TYPE_SIZE_UNIT (gnu_arr_type
)
2384 (MULT_EXPR
, sizetype
,
2385 elaborate_expression_1
2386 (gnat_entity
, gnat_entity
,
2387 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
2388 TYPE_SIZE_UNIT (gnu_arr_type
),
2389 size_int (TYPE_ALIGN (eltype
)
2391 concat_id_with_name (gnu_str_name
, "A_U"),
2393 size_int (TYPE_ALIGN (eltype
) / BITS_PER_UNIT
));
2395 /* ??? create_type_decl is not invoked on the inner types so
2396 the MULT_EXPR node built above will never be marked. */
2397 mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type
));
2401 /* If we need to write out a record type giving the names of
2402 the bounds, do it now. Make sure to reference the index
2403 types themselves, not just their names, as the debugger
2404 may fall back on them in some cases. */
2405 if (need_index_type_struct
&& debug_info_p
)
2407 tree gnu_bound_rec
= make_node (RECORD_TYPE
);
2408 tree gnu_field_list
= NULL_TREE
;
2411 TYPE_NAME (gnu_bound_rec
)
2412 = create_concat_name (gnat_entity
, "XA");
2414 for (index
= array_dim
- 1; index
>= 0; index
--)
2416 tree gnu_index
= TYPE_INDEX_TYPE (gnu_index_type
[index
]);
2417 tree gnu_index_name
= TYPE_NAME (gnu_index
);
2419 if (TREE_CODE (gnu_index_name
) == TYPE_DECL
)
2420 gnu_index_name
= DECL_NAME (gnu_index_name
);
2422 gnu_field
= create_field_decl (gnu_index_name
, gnu_index
,
2424 0, NULL_TREE
, NULL_TREE
, 0);
2425 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2426 gnu_field_list
= gnu_field
;
2429 finish_record_type (gnu_bound_rec
, gnu_field_list
, 0, false);
2430 add_parallel_type (TYPE_STUB_DECL (gnu_type
), gnu_bound_rec
);
2433 TYPE_CONVENTION_FORTRAN_P (gnu_type
)
2434 = (Convention (gnat_entity
) == Convention_Fortran
);
2435 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2436 = (Is_Packed_Array_Type (gnat_entity
)
2437 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2439 /* If our size depends on a placeholder and the maximum size doesn't
2440 overflow, use it. */
2441 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2442 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2443 && TREE_OVERFLOW (gnu_max_size
))
2444 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2445 && TREE_OVERFLOW (gnu_max_size_unit
))
2448 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2449 TYPE_SIZE (gnu_type
));
2450 TYPE_SIZE_UNIT (gnu_type
)
2451 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2452 TYPE_SIZE_UNIT (gnu_type
));
2455 /* Set our alias set to that of our base type. This gives all
2456 array subtypes the same alias set. */
2457 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2460 /* If this is a packed type, make this type the same as the packed
2461 array type, but do some adjusting in the type first. */
2462 if (Present (Packed_Array_Type (gnat_entity
)))
2464 Entity_Id gnat_index
;
2465 tree gnu_inner_type
;
2467 /* First finish the type we had been making so that we output
2468 debugging information for it. */
2470 = build_qualified_type (gnu_type
,
2471 (TYPE_QUALS (gnu_type
)
2472 | (TYPE_QUAL_VOLATILE
2473 * Treat_As_Volatile (gnat_entity
))));
2475 /* Make it artificial only if the base type was artificial as well.
2476 That's sort of "morally" true and will make it possible for the
2477 debugger to look it up by name in DWARF more easily. */
2479 = create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2480 !Comes_From_Source (gnat_entity
)
2481 && !Comes_From_Source (Etype (gnat_entity
)),
2482 debug_info_p
, gnat_entity
);
2484 /* Save it as our equivalent in case the call below elaborates
2486 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2488 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2490 this_made_decl
= true;
2491 gnu_type
= TREE_TYPE (gnu_decl
);
2492 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2494 gnu_inner_type
= gnu_type
;
2495 while (TREE_CODE (gnu_inner_type
) == RECORD_TYPE
2496 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type
)
2497 || TYPE_IS_PADDING_P (gnu_inner_type
)))
2498 gnu_inner_type
= TREE_TYPE (TYPE_FIELDS (gnu_inner_type
));
2500 /* We need to point the type we just made to our index type so
2501 the actual bounds can be put into a template. */
2503 if ((TREE_CODE (gnu_inner_type
) == ARRAY_TYPE
2504 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type
))
2505 || (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
2506 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
)))
2508 if (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
)
2510 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2511 If it is, we need to make another type. */
2512 if (TYPE_MODULAR_P (gnu_inner_type
))
2516 gnu_subtype
= make_node (INTEGER_TYPE
);
2518 TREE_TYPE (gnu_subtype
) = gnu_inner_type
;
2519 TYPE_MIN_VALUE (gnu_subtype
)
2520 = TYPE_MIN_VALUE (gnu_inner_type
);
2521 TYPE_MAX_VALUE (gnu_subtype
)
2522 = TYPE_MAX_VALUE (gnu_inner_type
);
2523 TYPE_PRECISION (gnu_subtype
)
2524 = TYPE_PRECISION (gnu_inner_type
);
2525 TYPE_UNSIGNED (gnu_subtype
)
2526 = TYPE_UNSIGNED (gnu_inner_type
);
2527 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2528 layout_type (gnu_subtype
);
2530 gnu_inner_type
= gnu_subtype
;
2533 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
) = 1;
2536 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type
, NULL_TREE
);
2538 for (gnat_index
= First_Index (gnat_entity
);
2539 Present (gnat_index
); gnat_index
= Next_Index (gnat_index
))
2540 SET_TYPE_ACTUAL_BOUNDS
2542 tree_cons (NULL_TREE
,
2543 get_unpadded_type (Etype (gnat_index
)),
2544 TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2546 if (Convention (gnat_entity
) != Convention_Fortran
)
2547 SET_TYPE_ACTUAL_BOUNDS
2549 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2551 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2552 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2553 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner_type
;
2557 /* Abort if packed array with no packed array type field set. */
2559 gcc_assert (!Is_Packed (gnat_entity
));
2563 case E_String_Literal_Subtype
:
2564 /* Create the type for a string literal. */
2566 Entity_Id gnat_full_type
2567 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2568 && Present (Full_View (Etype (gnat_entity
)))
2569 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2570 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2571 tree gnu_string_array_type
2572 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2573 tree gnu_string_index_type
2574 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2575 (TYPE_DOMAIN (gnu_string_array_type
))));
2576 tree gnu_lower_bound
2577 = convert (gnu_string_index_type
,
2578 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2579 int length
= UI_To_Int (String_Literal_Length (gnat_entity
));
2580 tree gnu_length
= ssize_int (length
- 1);
2581 tree gnu_upper_bound
2582 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2584 convert (gnu_string_index_type
, gnu_length
));
2586 = build_range_type (gnu_string_index_type
,
2587 gnu_lower_bound
, gnu_upper_bound
);
2589 = create_index_type (convert (sizetype
,
2590 TYPE_MIN_VALUE (gnu_range_type
)),
2592 TYPE_MAX_VALUE (gnu_range_type
)),
2593 gnu_range_type
, gnat_entity
);
2596 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity
)),
2598 if (array_type_has_nonaliased_component (gnat_entity
, gnu_type
))
2599 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2600 relate_alias_sets (gnu_type
, gnu_string_type
, ALIAS_SET_COPY
);
2604 /* Record Types and Subtypes
2606 The following fields are defined on record types:
2608 Has_Discriminants True if the record has discriminants
2609 First_Discriminant Points to head of list of discriminants
2610 First_Entity Points to head of list of fields
2611 Is_Tagged_Type True if the record is tagged
2613 Implementation of Ada records and discriminated records:
2615 A record type definition is transformed into the equivalent of a C
2616 struct definition. The fields that are the discriminants which are
2617 found in the Full_Type_Declaration node and the elements of the
2618 Component_List found in the Record_Type_Definition node. The
2619 Component_List can be a recursive structure since each Variant of
2620 the Variant_Part of the Component_List has a Component_List.
2622 Processing of a record type definition comprises starting the list of
2623 field declarations here from the discriminants and the calling the
2624 function components_to_record to add the rest of the fields from the
2625 component list and return the gnu type node. The function
2626 components_to_record will call itself recursively as it traverses
2630 if (Has_Complex_Representation (gnat_entity
))
2633 = build_complex_type
2635 (Etype (Defining_Entity
2636 (First (Component_Items
2639 (Declaration_Node (gnat_entity
)))))))));
2645 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2646 Node_Id record_definition
= Type_Definition (full_definition
);
2647 Entity_Id gnat_field
;
2649 tree gnu_field_list
= NULL_TREE
;
2650 tree gnu_get_parent
;
2651 /* Set PACKED in keeping with gnat_to_gnu_field. */
2653 = Is_Packed (gnat_entity
)
2655 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2657 : (Known_Alignment (gnat_entity
)
2658 || (Strict_Alignment (gnat_entity
)
2659 && Known_Static_Esize (gnat_entity
)))
2662 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2663 bool all_rep
= has_rep
;
2665 = (Is_Tagged_Type (gnat_entity
)
2666 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2668 /* See if all fields have a rep clause. Stop when we find one
2670 for (gnat_field
= First_Entity (gnat_entity
);
2671 Present (gnat_field
) && all_rep
;
2672 gnat_field
= Next_Entity (gnat_field
))
2673 if ((Ekind (gnat_field
) == E_Component
2674 || Ekind (gnat_field
) == E_Discriminant
)
2675 && No (Component_Clause (gnat_field
)))
2678 /* If this is a record extension, go a level further to find the
2679 record definition. Also, verify we have a Parent_Subtype. */
2682 if (!type_annotate_only
2683 || Present (Record_Extension_Part (record_definition
)))
2684 record_definition
= Record_Extension_Part (record_definition
);
2686 gcc_assert (type_annotate_only
2687 || Present (Parent_Subtype (gnat_entity
)));
2690 /* Make a node for the record. If we are not defining the record,
2691 suppress expanding incomplete types. */
2692 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2693 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2694 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2697 defer_incomplete_level
++, this_deferred
= true;
2699 /* If both a size and rep clause was specified, put the size in
2700 the record type now so that it can get the proper mode. */
2701 if (has_rep
&& Known_Esize (gnat_entity
))
2702 TYPE_SIZE (gnu_type
) = UI_To_gnu (Esize (gnat_entity
), sizetype
);
2704 /* Always set the alignment here so that it can be used to
2705 set the mode, if it is making the alignment stricter. If
2706 it is invalid, it will be checked again below. If this is to
2707 be Atomic, choose a default alignment of a word unless we know
2708 the size and it's smaller. */
2709 if (Known_Alignment (gnat_entity
))
2710 TYPE_ALIGN (gnu_type
)
2711 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2712 else if (Is_Atomic (gnat_entity
))
2713 TYPE_ALIGN (gnu_type
)
2714 = esize
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_alignment (esize
);
2715 /* If a type needs strict alignment, the minimum size will be the
2716 type size instead of the RM size (see validate_size). Cap the
2717 alignment, lest it causes this type size to become too large. */
2718 else if (Strict_Alignment (gnat_entity
)
2719 && Known_Static_Esize (gnat_entity
))
2721 unsigned int raw_size
= UI_To_Int (Esize (gnat_entity
));
2722 unsigned int raw_align
= raw_size
& -raw_size
;
2723 if (raw_align
< BIGGEST_ALIGNMENT
)
2724 TYPE_ALIGN (gnu_type
) = raw_align
;
2727 TYPE_ALIGN (gnu_type
) = 0;
2729 /* If we have a Parent_Subtype, make a field for the parent. If
2730 this record has rep clauses, force the position to zero. */
2731 if (Present (Parent_Subtype (gnat_entity
)))
2733 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
2736 /* A major complexity here is that the parent subtype will
2737 reference our discriminants in its Discriminant_Constraint
2738 list. But those must reference the parent component of this
2739 record which is of the parent subtype we have not built yet!
2740 To break the circle we first build a dummy COMPONENT_REF which
2741 represents the "get to the parent" operation and initialize
2742 each of those discriminants to a COMPONENT_REF of the above
2743 dummy parent referencing the corresponding discriminant of the
2744 base type of the parent subtype. */
2745 gnu_get_parent
= build3 (COMPONENT_REF
, void_type_node
,
2746 build0 (PLACEHOLDER_EXPR
, gnu_type
),
2747 build_decl (FIELD_DECL
, NULL_TREE
,
2751 if (Has_Discriminants (gnat_entity
))
2752 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2753 Present (gnat_field
);
2754 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2755 if (Present (Corresponding_Discriminant (gnat_field
)))
2758 build3 (COMPONENT_REF
,
2759 get_unpadded_type (Etype (gnat_field
)),
2761 gnat_to_gnu_field_decl (Corresponding_Discriminant
2766 /* Then we build the parent subtype. */
2767 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
2769 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2770 initially built. The discriminants must reference the fields
2771 of the parent subtype and not those of its base type for the
2772 placeholder machinery to properly work. */
2773 if (Has_Discriminants (gnat_entity
))
2774 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2775 Present (gnat_field
);
2776 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2777 if (Present (Corresponding_Discriminant (gnat_field
)))
2779 Entity_Id field
= Empty
;
2780 for (field
= First_Stored_Discriminant (gnat_parent
);
2782 field
= Next_Stored_Discriminant (field
))
2783 if (same_discriminant_p (gnat_field
, field
))
2785 gcc_assert (Present (field
));
2786 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
2787 = gnat_to_gnu_field_decl (field
);
2790 /* The "get to the parent" COMPONENT_REF must be given its
2792 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
2794 /* ...and reference the _parent field of this record. */
2796 = create_field_decl (get_identifier
2797 (Get_Name_String (Name_uParent
)),
2798 gnu_parent
, gnu_type
, 0,
2799 has_rep
? TYPE_SIZE (gnu_parent
) : 0,
2800 has_rep
? bitsize_zero_node
: 0, 1);
2801 DECL_INTERNAL_P (gnu_field_list
) = 1;
2802 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field_list
;
2805 /* Make the fields for the discriminants and put them into the record
2806 unless it's an Unchecked_Union. */
2807 if (Has_Discriminants (gnat_entity
))
2808 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2809 Present (gnat_field
);
2810 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2812 /* If this is a record extension and this discriminant
2813 is the renaming of another discriminant, we've already
2814 handled the discriminant above. */
2815 if (Present (Parent_Subtype (gnat_entity
))
2816 && Present (Corresponding_Discriminant (gnat_field
)))
2820 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
);
2822 /* Make an expression using a PLACEHOLDER_EXPR from the
2823 FIELD_DECL node just created and link that with the
2824 corresponding GNAT defining identifier. Then add to the
2826 save_gnu_tree (gnat_field
,
2827 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2828 build0 (PLACEHOLDER_EXPR
,
2829 DECL_CONTEXT (gnu_field
)),
2830 gnu_field
, NULL_TREE
),
2833 if (!Is_Unchecked_Union (gnat_entity
))
2835 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2836 gnu_field_list
= gnu_field
;
2840 /* Put the discriminants into the record (backwards), so we can
2841 know the appropriate discriminant to use for the names of the
2843 TYPE_FIELDS (gnu_type
) = gnu_field_list
;
2845 /* Add the listed fields into the record and finish it up. */
2846 components_to_record (gnu_type
, Component_List (record_definition
),
2847 gnu_field_list
, packed
, definition
, NULL
,
2848 false, all_rep
, false,
2849 Is_Unchecked_Union (gnat_entity
));
2851 /* We used to remove the associations of the discriminants and
2852 _Parent for validity checking, but we may need them if there's
2853 Freeze_Node for a subtype used in this record. */
2854 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2855 TYPE_BY_REFERENCE_P (gnu_type
) = Is_By_Reference_Type (gnat_entity
);
2857 /* If it is a tagged record force the type to BLKmode to insure
2858 that these objects will always be placed in memory. Do the
2859 same thing for limited record types. */
2860 if (Is_Tagged_Type (gnat_entity
) || Is_Limited_Record (gnat_entity
))
2861 SET_TYPE_MODE (gnu_type
, BLKmode
);
2863 /* Fill in locations of fields. */
2864 annotate_rep (gnat_entity
, gnu_type
);
2866 /* If there are any entities in the chain corresponding to
2867 components that we did not elaborate, ensure we elaborate their
2868 types if they are Itypes. */
2869 for (gnat_temp
= First_Entity (gnat_entity
);
2870 Present (gnat_temp
); gnat_temp
= Next_Entity (gnat_temp
))
2871 if ((Ekind (gnat_temp
) == E_Component
2872 || Ekind (gnat_temp
) == E_Discriminant
)
2873 && Is_Itype (Etype (gnat_temp
))
2874 && !present_gnu_tree (gnat_temp
))
2875 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2879 case E_Class_Wide_Subtype
:
2880 /* If an equivalent type is present, that is what we should use.
2881 Otherwise, fall through to handle this like a record subtype
2882 since it may have constraints. */
2883 if (gnat_equiv_type
!= gnat_entity
)
2885 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
2886 maybe_present
= true;
2890 /* ... fall through ... */
2892 case E_Record_Subtype
:
2894 /* If Cloned_Subtype is Present it means this record subtype has
2895 identical layout to that type or subtype and we should use
2896 that GCC type for this one. The front end guarantees that
2897 the component list is shared. */
2898 if (Present (Cloned_Subtype (gnat_entity
)))
2900 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
2902 maybe_present
= true;
2905 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2906 changing the type, make a new type with each field having the
2907 type of the field in the new subtype but having the position
2908 computed by transforming every discriminant reference according
2909 to the constraints. We don't see any difference between
2910 private and nonprivate type here since derivations from types should
2911 have been deferred until the completion of the private type. */
2914 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
2919 defer_incomplete_level
++, this_deferred
= true;
2921 /* Get the base type initially for its alignment and sizes. But
2922 if it is a padded type, we do all the other work with the
2924 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
2926 if (TREE_CODE (gnu_base_type
) == RECORD_TYPE
2927 && TYPE_IS_PADDING_P (gnu_base_type
))
2928 gnu_type
= gnu_orig_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
2930 gnu_type
= gnu_orig_type
= gnu_base_type
;
2932 if (present_gnu_tree (gnat_entity
))
2934 maybe_present
= true;
2938 /* When the type has discriminants, and these discriminants
2939 affect the shape of what it built, factor them in.
2941 If we are making a subtype of an Unchecked_Union (must be an
2942 Itype), just return the type.
2944 We can't just use Is_Constrained because private subtypes without
2945 discriminants of full types with discriminants with default
2946 expressions are Is_Constrained but aren't constrained! */
2948 if (IN (Ekind (gnat_base_type
), Record_Kind
)
2949 && !Is_For_Access_Subtype (gnat_entity
)
2950 && !Is_Unchecked_Union (gnat_base_type
)
2951 && Is_Constrained (gnat_entity
)
2952 && Stored_Constraint (gnat_entity
) != No_Elist
2953 && Present (Discriminant_Constraint (gnat_entity
)))
2955 Entity_Id gnat_field
;
2956 tree gnu_field_list
= 0;
2958 = compute_field_positions (gnu_orig_type
, NULL_TREE
,
2959 size_zero_node
, bitsize_zero_node
,
2962 = substitution_list (gnat_entity
, gnat_base_type
, NULL_TREE
,
2966 gnu_type
= make_node (RECORD_TYPE
);
2967 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2968 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2970 /* Set the size, alignment and alias set of the new type to
2971 match that of the old one, doing required substitutions.
2972 We do it this early because we need the size of the new
2973 type below to discard old fields if necessary. */
2974 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_base_type
);
2975 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_base_type
);
2976 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_ADA_SIZE (gnu_base_type
));
2977 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2978 relate_alias_sets (gnu_type
, gnu_base_type
, ALIAS_SET_COPY
);
2980 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2981 for (gnu_temp
= gnu_subst_list
;
2982 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2983 TYPE_SIZE (gnu_type
)
2984 = substitute_in_expr (TYPE_SIZE (gnu_type
),
2985 TREE_PURPOSE (gnu_temp
),
2986 TREE_VALUE (gnu_temp
));
2988 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type
)))
2989 for (gnu_temp
= gnu_subst_list
;
2990 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2991 TYPE_SIZE_UNIT (gnu_type
)
2992 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type
),
2993 TREE_PURPOSE (gnu_temp
),
2994 TREE_VALUE (gnu_temp
));
2996 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type
)))
2997 for (gnu_temp
= gnu_subst_list
;
2998 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
3000 (gnu_type
, substitute_in_expr (TYPE_ADA_SIZE (gnu_type
),
3001 TREE_PURPOSE (gnu_temp
),
3002 TREE_VALUE (gnu_temp
)));
3004 for (gnat_field
= First_Entity (gnat_entity
);
3005 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
3006 if ((Ekind (gnat_field
) == E_Component
3007 || Ekind (gnat_field
) == E_Discriminant
)
3008 && (Underlying_Type (Scope (Original_Record_Component
3011 && (No (Corresponding_Discriminant (gnat_field
))
3012 || !Is_Tagged_Type (gnat_base_type
)))
3015 = gnat_to_gnu_field_decl (Original_Record_Component
3018 = TREE_VALUE (purpose_member (gnu_old_field
,
3020 tree gnu_pos
= TREE_PURPOSE (gnu_offset
);
3021 tree gnu_bitpos
= TREE_VALUE (TREE_VALUE (gnu_offset
));
3023 = gnat_to_gnu_type (Etype (gnat_field
));
3024 tree gnu_size
= TYPE_SIZE (gnu_field_type
);
3025 tree gnu_new_pos
= NULL_TREE
;
3026 unsigned int offset_align
3027 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset
)),
3031 /* If there was a component clause, the field types must be
3032 the same for the type and subtype, so copy the data from
3033 the old field to avoid recomputation here. Also if the
3034 field is justified modular and the optimization in
3035 gnat_to_gnu_field was applied. */
3036 if (Present (Component_Clause
3037 (Original_Record_Component (gnat_field
)))
3038 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3039 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
3040 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
3041 == TREE_TYPE (gnu_old_field
)))
3043 gnu_size
= DECL_SIZE (gnu_old_field
);
3044 gnu_field_type
= TREE_TYPE (gnu_old_field
);
3047 /* If the old field was packed and of constant size, we
3048 have to get the old size here, as it might differ from
3049 what the Etype conveys and the latter might overlap
3050 onto the following field. Try to arrange the type for
3051 possible better packing along the way. */
3052 else if (DECL_PACKED (gnu_old_field
)
3053 && TREE_CODE (DECL_SIZE (gnu_old_field
))
3056 gnu_size
= DECL_SIZE (gnu_old_field
);
3057 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
3058 && !TYPE_IS_FAT_POINTER_P (gnu_field_type
)
3059 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
3061 = make_packable_type (gnu_field_type
, true);
3064 if (CONTAINS_PLACEHOLDER_P (gnu_pos
))
3065 for (gnu_temp
= gnu_subst_list
;
3066 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
3067 gnu_pos
= substitute_in_expr (gnu_pos
,
3068 TREE_PURPOSE (gnu_temp
),
3069 TREE_VALUE (gnu_temp
));
3071 /* If the position is now a constant, we can set it as the
3072 position of the field when we make it. Otherwise, we need
3073 to deal with it specially below. */
3074 if (TREE_CONSTANT (gnu_pos
))
3076 gnu_new_pos
= bit_from_pos (gnu_pos
, gnu_bitpos
);
3078 /* Discard old fields that are outside the new type.
3079 This avoids confusing code scanning it to decide
3080 how to pass it to functions on some platforms. */
3081 if (TREE_CODE (gnu_new_pos
) == INTEGER_CST
3082 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
3083 && !integer_zerop (gnu_size
)
3084 && !tree_int_cst_lt (gnu_new_pos
,
3085 TYPE_SIZE (gnu_type
)))
3091 (DECL_NAME (gnu_old_field
), gnu_field_type
, gnu_type
,
3092 DECL_PACKED (gnu_old_field
), gnu_size
, gnu_new_pos
,
3093 !DECL_NONADDRESSABLE_P (gnu_old_field
));
3095 if (!TREE_CONSTANT (gnu_pos
))
3097 normalize_offset (&gnu_pos
, &gnu_bitpos
, offset_align
);
3098 DECL_FIELD_OFFSET (gnu_field
) = gnu_pos
;
3099 DECL_FIELD_BIT_OFFSET (gnu_field
) = gnu_bitpos
;
3100 SET_DECL_OFFSET_ALIGN (gnu_field
, offset_align
);
3101 DECL_SIZE (gnu_field
) = gnu_size
;
3102 DECL_SIZE_UNIT (gnu_field
)
3103 = convert (sizetype
,
3104 size_binop (CEIL_DIV_EXPR
, gnu_size
,
3105 bitsize_unit_node
));
3106 layout_decl (gnu_field
, DECL_OFFSET_ALIGN (gnu_field
));
3109 DECL_INTERNAL_P (gnu_field
)
3110 = DECL_INTERNAL_P (gnu_old_field
);
3111 SET_DECL_ORIGINAL_FIELD
3112 (gnu_field
, (DECL_ORIGINAL_FIELD (gnu_old_field
)
3113 ? DECL_ORIGINAL_FIELD (gnu_old_field
)
3115 DECL_DISCRIMINANT_NUMBER (gnu_field
)
3116 = DECL_DISCRIMINANT_NUMBER (gnu_old_field
);
3117 TREE_THIS_VOLATILE (gnu_field
)
3118 = TREE_THIS_VOLATILE (gnu_old_field
);
3120 /* To match the layout crafted in components_to_record, if
3121 this is the _Tag field, put it before any discriminants
3122 instead of after them as for all other fields. */
3123 if (Chars (gnat_field
) == Name_uTag
)
3124 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
3127 TREE_CHAIN (gnu_field
) = gnu_field_list
;
3128 gnu_field_list
= gnu_field
;
3131 save_gnu_tree (gnat_field
, gnu_field
, false);
3134 /* Now go through the entities again looking for Itypes that
3135 we have not elaborated but should (e.g., Etypes of fields
3136 that have Original_Components). */
3137 for (gnat_field
= First_Entity (gnat_entity
);
3138 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
3139 if ((Ekind (gnat_field
) == E_Discriminant
3140 || Ekind (gnat_field
) == E_Component
)
3141 && !present_gnu_tree (Etype (gnat_field
)))
3142 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
3144 /* Do not finalize it since we're going to modify it below. */
3145 gnu_field_list
= nreverse (gnu_field_list
);
3146 finish_record_type (gnu_type
, gnu_field_list
, 2, true);
3148 /* Finalize size and mode. */
3149 TYPE_SIZE (gnu_type
) = variable_size (TYPE_SIZE (gnu_type
));
3150 TYPE_SIZE_UNIT (gnu_type
)
3151 = variable_size (TYPE_SIZE_UNIT (gnu_type
));
3153 compute_record_mode (gnu_type
);
3155 /* Fill in locations of fields. */
3156 annotate_rep (gnat_entity
, gnu_type
);
3158 /* We've built a new type, make an XVS type to show what this
3159 is a subtype of. Some debuggers require the XVS type to be
3160 output first, so do it in that order. */
3163 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3164 tree gnu_orig_name
= TYPE_NAME (gnu_orig_type
);
3166 if (TREE_CODE (gnu_orig_name
) == TYPE_DECL
)
3167 gnu_orig_name
= DECL_NAME (gnu_orig_name
);
3169 TYPE_NAME (gnu_subtype_marker
)
3170 = create_concat_name (gnat_entity
, "XVS");
3171 finish_record_type (gnu_subtype_marker
,
3172 create_field_decl (gnu_orig_name
,
3179 add_parallel_type (TYPE_STUB_DECL (gnu_type
),
3180 gnu_subtype_marker
);
3183 /* Now we can finalize it. */
3184 rest_of_record_type_compilation (gnu_type
);
3187 /* Otherwise, go down all the components in the new type and
3188 make them equivalent to those in the base type. */
3190 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
3191 gnat_temp
= Next_Entity (gnat_temp
))
3192 if ((Ekind (gnat_temp
) == E_Discriminant
3193 && !Is_Unchecked_Union (gnat_base_type
))
3194 || Ekind (gnat_temp
) == E_Component
)
3195 save_gnu_tree (gnat_temp
,
3196 gnat_to_gnu_field_decl
3197 (Original_Record_Component (gnat_temp
)), false);
3201 case E_Access_Subprogram_Type
:
3202 /* Use the special descriptor type for dispatch tables if needed,
3203 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3204 Note that we are only required to do so for static tables in
3205 order to be compatible with the C++ ABI, but Ada 2005 allows
3206 to extend library level tagged types at the local level so
3207 we do it in the non-static case as well. */
3208 if (TARGET_VTABLE_USES_DESCRIPTORS
3209 && Is_Dispatch_Table_Entity (gnat_entity
))
3211 gnu_type
= fdesc_type_node
;
3212 gnu_size
= TYPE_SIZE (gnu_type
);
3216 /* ... fall through ... */
3218 case E_Anonymous_Access_Subprogram_Type
:
3219 /* If we are not defining this entity, and we have incomplete
3220 entities being processed above us, make a dummy type and
3221 fill it in later. */
3222 if (!definition
&& defer_incomplete_level
!= 0)
3224 struct incomplete
*p
3225 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3228 = build_pointer_type
3229 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3230 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3231 !Comes_From_Source (gnat_entity
),
3232 debug_info_p
, gnat_entity
);
3233 this_made_decl
= true;
3234 gnu_type
= TREE_TYPE (gnu_decl
);
3235 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3238 p
->old_type
= TREE_TYPE (gnu_type
);
3239 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3240 p
->next
= defer_incomplete_list
;
3241 defer_incomplete_list
= p
;
3245 /* ... fall through ... */
3247 case E_Allocator_Type
:
3249 case E_Access_Attribute_Type
:
3250 case E_Anonymous_Access_Type
:
3251 case E_General_Access_Type
:
3253 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3254 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3255 bool is_from_limited_with
3256 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
3257 && From_With_Type (gnat_desig_equiv
));
3259 /* Get the "full view" of this entity. If this is an incomplete
3260 entity from a limited with, treat its non-limited view as the full
3261 view. Otherwise, if this is an incomplete or private type, use the
3262 full view. In the former case, we might point to a private type,
3263 in which case, we need its full view. Also, we want to look at the
3264 actual type used for the representation, so this takes a total of
3266 Entity_Id gnat_desig_full_direct_first
3267 = (is_from_limited_with
? Non_Limited_View (gnat_desig_equiv
)
3268 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3269 ? Full_View (gnat_desig_equiv
) : Empty
));
3270 Entity_Id gnat_desig_full_direct
3271 = ((is_from_limited_with
3272 && Present (gnat_desig_full_direct_first
)
3273 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3274 ? Full_View (gnat_desig_full_direct_first
)
3275 : gnat_desig_full_direct_first
);
3276 Entity_Id gnat_desig_full
3277 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3279 /* This the type actually used to represent the designated type,
3280 either gnat_desig_full or gnat_desig_equiv. */
3281 Entity_Id gnat_desig_rep
;
3283 /* True if this is a pointer to an unconstrained array. */
3284 bool is_unconstrained_array
;
3286 /* We want to know if we'll be seeing the freeze node for any
3287 incomplete type we may be pointing to. */
3289 = (Present (gnat_desig_full
)
3290 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3291 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3293 /* True if we make a dummy type here. */
3294 bool got_fat_p
= false;
3295 /* True if the dummy is a fat pointer. */
3296 bool made_dummy
= false;
3297 tree gnu_desig_type
= NULL_TREE
;
3298 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3300 if (!targetm
.valid_pointer_mode (p_mode
))
3303 /* If either the designated type or its full view is an unconstrained
3304 array subtype, replace it with the type it's a subtype of. This
3305 avoids problems with multiple copies of unconstrained array types.
3306 Likewise, if the designated type is a subtype of an incomplete
3307 record type, use the parent type to avoid order of elaboration
3308 issues. This can lose some code efficiency, but there is no
3310 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3311 && ! Is_Constrained (gnat_desig_equiv
))
3312 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3313 if (Present (gnat_desig_full
)
3314 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3315 && ! Is_Constrained (gnat_desig_full
))
3316 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3317 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3318 gnat_desig_full
= Etype (gnat_desig_full
);
3320 /* Now set the type that actually marks the representation of
3321 the designated type and also flag whether we have a unconstrained
3323 gnat_desig_rep
= gnat_desig_full
? gnat_desig_full
: gnat_desig_equiv
;
3324 is_unconstrained_array
3325 = (Is_Array_Type (gnat_desig_rep
)
3326 && ! Is_Constrained (gnat_desig_rep
));
3328 /* If we are pointing to an incomplete type whose completion is an
3329 unconstrained array, make a fat pointer type. The two types in our
3330 fields will be pointers to dummy nodes and will be replaced in
3331 update_pointer_to. Similarly, if the type itself is a dummy type or
3332 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3333 in case we have any thin pointers to it. */
3334 if (is_unconstrained_array
3335 && (Present (gnat_desig_full
)
3336 || (present_gnu_tree (gnat_desig_equiv
)
3337 && TYPE_IS_DUMMY_P (TREE_TYPE
3338 (get_gnu_tree (gnat_desig_equiv
))))
3339 || (No (gnat_desig_full
) && ! in_main_unit
3340 && defer_incomplete_level
!= 0
3341 && ! present_gnu_tree (gnat_desig_equiv
))
3342 || (in_main_unit
&& is_from_limited_with
3343 && Present (Freeze_Node (gnat_desig_rep
)))))
3346 = (present_gnu_tree (gnat_desig_rep
)
3347 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep
))
3348 : make_dummy_type (gnat_desig_rep
));
3351 /* Show the dummy we get will be a fat pointer. */
3352 got_fat_p
= made_dummy
= true;
3354 /* If the call above got something that has a pointer, that
3355 pointer is our type. This could have happened either
3356 because the type was elaborated or because somebody
3357 else executed the code below. */
3358 gnu_type
= TYPE_POINTER_TO (gnu_old
);
3361 tree gnu_template_type
= make_node (ENUMERAL_TYPE
);
3362 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
3363 tree gnu_array_type
= make_node (ENUMERAL_TYPE
);
3364 tree gnu_ptr_array
= build_pointer_type (gnu_array_type
);
3366 TYPE_NAME (gnu_template_type
)
3367 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3369 TYPE_DUMMY_P (gnu_template_type
) = 1;
3371 TYPE_NAME (gnu_array_type
)
3372 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3374 TYPE_DUMMY_P (gnu_array_type
) = 1;
3376 gnu_type
= make_node (RECORD_TYPE
);
3377 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type
, gnu_old
);
3378 TYPE_POINTER_TO (gnu_old
) = gnu_type
;
3380 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3382 = chainon (chainon (NULL_TREE
,
3384 (get_identifier ("P_ARRAY"),
3386 gnu_type
, 0, 0, 0, 0)),
3387 create_field_decl (get_identifier ("P_BOUNDS"),
3389 gnu_type
, 0, 0, 0, 0));
3391 /* Make sure we can place this into a register. */
3392 TYPE_ALIGN (gnu_type
)
3393 = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
3394 TYPE_IS_FAT_POINTER_P (gnu_type
) = 1;
3396 /* Do not finalize this record type since the types of
3397 its fields are incomplete. */
3398 finish_record_type (gnu_type
, fields
, 0, true);
3400 TYPE_OBJECT_RECORD_TYPE (gnu_old
) = make_node (RECORD_TYPE
);
3401 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old
))
3402 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3404 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old
)) = 1;
3408 /* If we already know what the full type is, use it. */
3409 else if (Present (gnat_desig_full
)
3410 && present_gnu_tree (gnat_desig_full
))
3411 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3413 /* Get the type of the thing we are to point to and build a pointer
3414 to it. If it is a reference to an incomplete or private type with a
3415 full view that is a record, make a dummy type node and get the
3416 actual type later when we have verified it is safe. */
3417 else if ((! in_main_unit
3418 && ! present_gnu_tree (gnat_desig_equiv
)
3419 && Present (gnat_desig_full
)
3420 && ! present_gnu_tree (gnat_desig_full
)
3421 && Is_Record_Type (gnat_desig_full
))
3422 /* Likewise if we are pointing to a record or array and we
3423 are to defer elaborating incomplete types. We do this
3424 since this access type may be the full view of some
3425 private type. Note that the unconstrained array case is
3427 || ((! in_main_unit
|| imported_p
)
3428 && defer_incomplete_level
!= 0
3429 && ! present_gnu_tree (gnat_desig_equiv
)
3430 && ((Is_Record_Type (gnat_desig_rep
)
3431 || Is_Array_Type (gnat_desig_rep
))))
3432 /* If this is a reference from a limited_with type back to our
3433 main unit and there's a Freeze_Node for it, either we have
3434 already processed the declaration and made the dummy type,
3435 in which case we just reuse the latter, or we have not yet,
3436 in which case we make the dummy type and it will be reused
3437 when the declaration is processed. In both cases, the
3438 pointer eventually created below will be automatically
3439 adjusted when the Freeze_Node is processed. Note that the
3440 unconstrained array case is handled above. */
3441 || (in_main_unit
&& is_from_limited_with
3442 && Present (Freeze_Node (gnat_desig_rep
))))
3444 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3448 /* Otherwise handle the case of a pointer to itself. */
3449 else if (gnat_desig_equiv
== gnat_entity
)
3452 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3453 No_Strict_Aliasing (gnat_entity
));
3454 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3457 /* If expansion is disabled, the equivalent type of a concurrent
3458 type is absent, so build a dummy pointer type. */
3459 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3460 gnu_type
= ptr_void_type_node
;
3462 /* Finally, handle the straightforward case where we can just
3463 elaborate our designated type and point to it. */
3465 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3467 /* It is possible that a call to gnat_to_gnu_type above resolved our
3468 type. If so, just return it. */
3469 if (present_gnu_tree (gnat_entity
))
3471 maybe_present
= true;
3475 /* If we have a GCC type for the designated type, possibly modify it
3476 if we are pointing only to constant objects and then make a pointer
3477 to it. Don't do this for unconstrained arrays. */
3478 if (!gnu_type
&& gnu_desig_type
)
3480 if (Is_Access_Constant (gnat_entity
)
3481 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3484 = build_qualified_type
3486 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3488 /* Some extra processing is required if we are building a
3489 pointer to an incomplete type (in the GCC sense). We might
3490 have such a type if we just made a dummy, or directly out
3491 of the call to gnat_to_gnu_type above if we are processing
3492 an access type for a record component designating the
3493 record type itself. */
3494 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3496 /* We must ensure that the pointer to variant we make will
3497 be processed by update_pointer_to when the initial type
3498 is completed. Pretend we made a dummy and let further
3499 processing act as usual. */
3502 /* We must ensure that update_pointer_to will not retrieve
3503 the dummy variant when building a properly qualified
3504 version of the complete type. We take advantage of the
3505 fact that get_qualified_type is requiring TYPE_NAMEs to
3506 match to influence build_qualified_type and then also
3507 update_pointer_to here. */
3508 TYPE_NAME (gnu_desig_type
)
3509 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3514 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3515 No_Strict_Aliasing (gnat_entity
));
3518 /* If we are not defining this object and we made a dummy pointer,
3519 save our current definition, evaluate the actual type, and replace
3520 the tentative type we made with the actual one. If we are to defer
3521 actually looking up the actual type, make an entry in the
3522 deferred list. If this is from a limited with, we have to defer
3523 to the end of the current spec in two cases: first if the
3524 designated type is in the current unit and second if the access
3526 if ((! in_main_unit
|| is_from_limited_with
) && made_dummy
)
3529 = TYPE_FAT_POINTER_P (gnu_type
)
3530 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type
) : TREE_TYPE (gnu_type
);
3532 if (esize
== POINTER_SIZE
3533 && (got_fat_p
|| TYPE_FAT_POINTER_P (gnu_type
)))
3535 = build_pointer_type
3536 (TYPE_OBJECT_RECORD_TYPE
3537 (TYPE_UNCONSTRAINED_ARRAY (gnu_type
)));
3539 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3540 !Comes_From_Source (gnat_entity
),
3541 debug_info_p
, gnat_entity
);
3542 this_made_decl
= true;
3543 gnu_type
= TREE_TYPE (gnu_decl
);
3544 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3547 if (defer_incomplete_level
== 0
3548 && ! (is_from_limited_with
3550 || In_Extended_Main_Code_Unit (gnat_entity
))))
3551 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type
),
3552 gnat_to_gnu_type (gnat_desig_equiv
));
3554 /* Note that the call to gnat_to_gnu_type here might have
3555 updated gnu_old_type directly, in which case it is not a
3556 dummy type any more when we get into update_pointer_to.
3558 This may happen for instance when the designated type is a
3559 record type, because their elaboration starts with an
3560 initial node from make_dummy_type, which may yield the same
3561 node as the one we got.
3563 Besides, variants of this non-dummy type might have been
3564 created along the way. update_pointer_to is expected to
3565 properly take care of those situations. */
3568 struct incomplete
*p
3569 = (struct incomplete
*) xmalloc (sizeof
3570 (struct incomplete
));
3571 struct incomplete
**head
3572 = (is_from_limited_with
3574 || In_Extended_Main_Code_Unit (gnat_entity
))
3575 ? &defer_limited_with
: &defer_incomplete_list
);
3577 p
->old_type
= gnu_old_type
;
3578 p
->full_type
= gnat_desig_equiv
;
3586 case E_Access_Protected_Subprogram_Type
:
3587 case E_Anonymous_Access_Protected_Subprogram_Type
:
3588 if (type_annotate_only
&& No (gnat_equiv_type
))
3589 gnu_type
= ptr_void_type_node
;
3592 /* The runtime representation is the equivalent type. */
3593 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3594 maybe_present
= true;
3597 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3598 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3599 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3600 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3601 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3606 case E_Access_Subtype
:
3608 /* We treat this as identical to its base type; any constraint is
3609 meaningful only to the front end.
3611 The designated type must be elaborated as well, if it does
3612 not have its own freeze node. Designated (sub)types created
3613 for constrained components of records with discriminants are
3614 not frozen by the front end and thus not elaborated by gigi,
3615 because their use may appear before the base type is frozen,
3616 and because it is not clear that they are needed anywhere in
3617 Gigi. With the current model, there is no correct place where
3618 they could be elaborated. */
3620 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3621 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3622 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3623 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3624 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3626 /* If we are not defining this entity, and we have incomplete
3627 entities being processed above us, make a dummy type and
3628 elaborate it later. */
3629 if (!definition
&& defer_incomplete_level
!= 0)
3631 struct incomplete
*p
3632 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3634 = build_pointer_type
3635 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3637 p
->old_type
= TREE_TYPE (gnu_ptr_type
);
3638 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3639 p
->next
= defer_incomplete_list
;
3640 defer_incomplete_list
= p
;
3642 else if (!IN (Ekind (Base_Type
3643 (Directly_Designated_Type (gnat_entity
))),
3644 Incomplete_Or_Private_Kind
))
3645 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3649 maybe_present
= true;
3652 /* Subprogram Entities
3654 The following access functions are defined for subprograms (functions
3657 First_Formal The first formal parameter.
3658 Is_Imported Indicates that the subprogram has appeared in
3659 an INTERFACE or IMPORT pragma. For now we
3660 assume that the external language is C.
3661 Is_Exported Likewise but for an EXPORT pragma.
3662 Is_Inlined True if the subprogram is to be inlined.
3664 In addition for function subprograms we have:
3666 Etype Return type of the function.
3668 Each parameter is first checked by calling must_pass_by_ref on its
3669 type to determine if it is passed by reference. For parameters which
3670 are copied in, if they are Ada In Out or Out parameters, their return
3671 value becomes part of a record which becomes the return type of the
3672 function (C function - note that this applies only to Ada procedures
3673 so there is no Ada return type). Additional code to store back the
3674 parameters will be generated on the caller side. This transformation
3675 is done here, not in the front-end.
3677 The intended result of the transformation can be seen from the
3678 equivalent source rewritings that follow:
3680 struct temp {int a,b};
3681 procedure P (A,B: In Out ...) is temp P (int A,B)
3684 end P; return {A,B};
3691 For subprogram types we need to perform mainly the same conversions to
3692 GCC form that are needed for procedures and function declarations. The
3693 only difference is that at the end, we make a type declaration instead
3694 of a function declaration. */
3696 case E_Subprogram_Type
:
3700 /* The first GCC parameter declaration (a PARM_DECL node). The
3701 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3702 actually is the head of this parameter list. */
3703 tree gnu_param_list
= NULL_TREE
;
3704 /* Likewise for the stub associated with an exported procedure. */
3705 tree gnu_stub_param_list
= NULL_TREE
;
3706 /* The type returned by a function. If the subprogram is a procedure
3707 this type should be void_type_node. */
3708 tree gnu_return_type
= void_type_node
;
3709 /* List of fields in return type of procedure with copy-in copy-out
3711 tree gnu_field_list
= NULL_TREE
;
3712 /* Non-null for subprograms containing parameters passed by copy-in
3713 copy-out (Ada In Out or Out parameters not passed by reference),
3714 in which case it is the list of nodes used to specify the values of
3715 the in out/out parameters that are returned as a record upon
3716 procedure return. The TREE_PURPOSE of an element of this list is
3717 a field of the record and the TREE_VALUE is the PARM_DECL
3718 corresponding to that field. This list will be saved in the
3719 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3720 tree gnu_return_list
= NULL_TREE
;
3721 /* If an import pragma asks to map this subprogram to a GCC builtin,
3722 this is the builtin DECL node. */
3723 tree gnu_builtin_decl
= NULL_TREE
;
3724 /* For the stub associated with an exported procedure. */
3725 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
3726 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
3727 Entity_Id gnat_param
;
3728 bool inline_flag
= Is_Inlined (gnat_entity
);
3729 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
3731 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
3733 /* The semantics of "pure" in Ada essentially matches that of "const"
3734 in the back-end. In particular, both properties are orthogonal to
3735 the "nothrow" property if the EH circuitry is explicit in the
3736 internal representation of the back-end. If we are to completely
3737 hide the EH circuitry from it, we need to declare that calls to pure
3738 Ada subprograms that can throw have side effects since they can
3739 trigger an "abnormal" transfer of control flow; thus they can be
3740 neither "const" nor "pure" in the back-end sense. */
3742 = (Exception_Mechanism
== Back_End_Exceptions
3743 && Is_Pure (gnat_entity
));
3745 bool volatile_flag
= No_Return (gnat_entity
);
3746 bool returns_by_ref
= false;
3747 bool returns_unconstrained
= false;
3748 bool returns_by_target_ptr
= false;
3749 bool has_copy_in_out
= false;
3750 bool has_stub
= false;
3753 if (kind
== E_Subprogram_Type
&& !definition
)
3754 /* A parameter may refer to this type, so defer completion
3755 of any incomplete types. */
3756 defer_incomplete_level
++, this_deferred
= true;
3758 /* If the subprogram has an alias, it is probably inherited, so
3759 we can use the original one. If the original "subprogram"
3760 is actually an enumeration literal, it may be the first use
3761 of its type, so we must elaborate that type now. */
3762 if (Present (Alias (gnat_entity
)))
3764 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3765 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
3767 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
),
3770 /* Elaborate any Itypes in the parameters of this entity. */
3771 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
3772 Present (gnat_temp
);
3773 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
3774 if (Is_Itype (Etype (gnat_temp
)))
3775 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3780 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3781 corresponding DECL node.
3783 We still want the parameter associations to take place because the
3784 proper generation of calls depends on it (a GNAT parameter without
3785 a corresponding GCC tree has a very specific meaning), so we don't
3787 if (Convention (gnat_entity
) == Convention_Intrinsic
)
3788 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
3790 /* ??? What if we don't find the builtin node above ? warn ? err ?
3791 In the current state we neither warn nor err, and calls will just
3792 be handled as for regular subprograms. */
3794 if (kind
== E_Function
|| kind
== E_Subprogram_Type
)
3795 gnu_return_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3797 /* If this function returns by reference, make the actual
3798 return type of this function the pointer and mark the decl. */
3799 if (Returns_By_Ref (gnat_entity
))
3801 returns_by_ref
= true;
3802 gnu_return_type
= build_pointer_type (gnu_return_type
);
3805 /* If the Mechanism is By_Reference, ensure the return type uses
3806 the machine's by-reference mechanism, which may not the same
3807 as above (e.g., it might be by passing a fake parameter). */
3808 else if (kind
== E_Function
3809 && Mechanism (gnat_entity
) == By_Reference
)
3811 TREE_ADDRESSABLE (gnu_return_type
) = 1;
3813 /* We expect this bit to be reset by gigi shortly, so can avoid a
3814 type node copy here. This actually also prevents troubles with
3815 the generation of debug information for the function, because
3816 we might have issued such info for this type already, and would
3817 be attaching a distinct type node to the function if we made a
3821 /* If we are supposed to return an unconstrained array,
3822 actually return a fat pointer and make a note of that. Return
3823 a pointer to an unconstrained record of variable size. */
3824 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3826 gnu_return_type
= TREE_TYPE (gnu_return_type
);
3827 returns_unconstrained
= true;
3830 /* If the type requires a transient scope, the result is allocated
3831 on the secondary stack, so the result type of the function is
3833 else if (Requires_Transient_Scope (Etype (gnat_entity
)))
3835 gnu_return_type
= build_pointer_type (gnu_return_type
);
3836 returns_unconstrained
= true;
3839 /* If the type is a padded type and the underlying type would not
3840 be passed by reference or this function has a foreign convention,
3841 return the underlying type. */
3842 else if (TREE_CODE (gnu_return_type
) == RECORD_TYPE
3843 && TYPE_IS_PADDING_P (gnu_return_type
)
3844 && (!default_pass_by_ref (TREE_TYPE
3845 (TYPE_FIELDS (gnu_return_type
)))
3846 || Has_Foreign_Convention (gnat_entity
)))
3847 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
3849 /* If the return type has a non-constant size, we convert the function
3850 into a procedure and its caller will pass a pointer to an object as
3851 the first parameter when we call the function. This can happen for
3852 an unconstrained type with a maximum size or a constrained type with
3853 a size not known at compile time. */
3854 if (TYPE_SIZE_UNIT (gnu_return_type
)
3855 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
)))
3857 returns_by_target_ptr
= true;
3859 = create_param_decl (get_identifier ("TARGET"),
3860 build_reference_type (gnu_return_type
),
3862 gnu_return_type
= void_type_node
;
3865 /* If the return type has a size that overflows, we cannot have
3866 a function that returns that type. This usage doesn't make
3867 sense anyway, so give an error here. */
3868 if (TYPE_SIZE_UNIT (gnu_return_type
)
3869 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
3870 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
3872 post_error ("cannot return type whose size overflows",
3874 gnu_return_type
= copy_node (gnu_return_type
);
3875 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
3876 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
3877 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
3878 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
3881 /* Look at all our parameters and get the type of
3882 each. While doing this, build a copy-out structure if
3885 /* Loop over the parameters and get their associated GCC tree.
3886 While doing this, build a copy-out structure if we need one. */
3887 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
3888 Present (gnat_param
);
3889 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
3891 tree gnu_param_name
= get_entity_name (gnat_param
);
3892 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
3893 tree gnu_param
, gnu_field
;
3894 bool copy_in_copy_out
= false;
3895 Mechanism_Type mech
= Mechanism (gnat_param
);
3897 /* Builtins are expanded inline and there is no real call sequence
3898 involved. So the type expected by the underlying expander is
3899 always the type of each argument "as is". */
3900 if (gnu_builtin_decl
)
3902 /* Handle the first parameter of a valued procedure specially. */
3903 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
3904 mech
= By_Copy_Return
;
3905 /* Otherwise, see if a Mechanism was supplied that forced this
3906 parameter to be passed one way or another. */
3907 else if (mech
== Default
3908 || mech
== By_Copy
|| mech
== By_Reference
)
3910 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
3911 mech
= By_Descriptor
;
3913 else if (By_Short_Descriptor_Last
<= mech
&&
3914 mech
<= By_Short_Descriptor
)
3915 mech
= By_Short_Descriptor
;
3919 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
3920 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
3921 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
3923 mech
= By_Reference
;
3929 post_error ("unsupported mechanism for&", gnat_param
);
3934 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
3935 Has_Foreign_Convention (gnat_entity
),
3938 /* We are returned either a PARM_DECL or a type if no parameter
3939 needs to be passed; in either case, adjust the type. */
3940 if (DECL_P (gnu_param
))
3941 gnu_param_type
= TREE_TYPE (gnu_param
);
3944 gnu_param_type
= gnu_param
;
3945 gnu_param
= NULL_TREE
;
3950 /* If it's an exported subprogram, we build a parameter list
3951 in parallel, in case we need to emit a stub for it. */
3952 if (Is_Exported (gnat_entity
))
3955 = chainon (gnu_param
, gnu_stub_param_list
);
3956 /* Change By_Descriptor parameter to By_Reference for
3957 the internal version of an exported subprogram. */
3958 if (mech
== By_Descriptor
|| mech
== By_Short_Descriptor
)
3961 = gnat_to_gnu_param (gnat_param
, By_Reference
,
3967 gnu_param
= copy_node (gnu_param
);
3970 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
3971 Sloc_to_locus (Sloc (gnat_param
),
3972 &DECL_SOURCE_LOCATION (gnu_param
));
3973 save_gnu_tree (gnat_param
, gnu_param
, false);
3975 /* If a parameter is a pointer, this function may modify
3976 memory through it and thus shouldn't be considered
3977 a const function. Also, the memory may be modified
3978 between two calls, so they can't be CSE'ed. The latter
3979 case also handles by-ref parameters. */
3980 if (POINTER_TYPE_P (gnu_param_type
)
3981 || TYPE_FAT_POINTER_P (gnu_param_type
))
3985 if (copy_in_copy_out
)
3987 if (!has_copy_in_out
)
3989 gcc_assert (TREE_CODE (gnu_return_type
) == VOID_TYPE
);
3990 gnu_return_type
= make_node (RECORD_TYPE
);
3991 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
3992 has_copy_in_out
= true;
3995 gnu_field
= create_field_decl (gnu_param_name
, gnu_param_type
,
3996 gnu_return_type
, 0, 0, 0, 0);
3997 Sloc_to_locus (Sloc (gnat_param
),
3998 &DECL_SOURCE_LOCATION (gnu_field
));
3999 TREE_CHAIN (gnu_field
) = gnu_field_list
;
4000 gnu_field_list
= gnu_field
;
4001 gnu_return_list
= tree_cons (gnu_field
, gnu_param
,
4006 /* Do not compute record for out parameters if subprogram is
4007 stubbed since structures are incomplete for the back-end. */
4008 if (gnu_field_list
&& Convention (gnat_entity
) != Convention_Stubbed
)
4009 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
4012 /* If we have a CICO list but it has only one entry, we convert
4013 this function into a function that simply returns that one
4015 if (list_length (gnu_return_list
) == 1)
4016 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_return_list
));
4018 if (Has_Stdcall_Convention (gnat_entity
))
4019 prepend_one_attribute_to
4020 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4021 get_identifier ("stdcall"), NULL_TREE
,
4024 /* If we are on a target where stack realignment is needed for 'main'
4025 to honor GCC's implicit expectations (stack alignment greater than
4026 what the base ABI guarantees), ensure we do the same for foreign
4027 convention subprograms as they might be used as callbacks from code
4028 breaking such expectations. Note that this applies to task entry
4029 points in particular. */
4030 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4031 && Has_Foreign_Convention (gnat_entity
))
4032 prepend_one_attribute_to
4033 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
4034 get_identifier ("force_align_arg_pointer"), NULL_TREE
,
4037 /* The lists have been built in reverse. */
4038 gnu_param_list
= nreverse (gnu_param_list
);
4040 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
4041 gnu_return_list
= nreverse (gnu_return_list
);
4043 if (Ekind (gnat_entity
) == E_Function
)
4044 Set_Mechanism (gnat_entity
,
4045 (returns_by_ref
|| returns_unconstrained
4046 ? By_Reference
: By_Copy
));
4048 = create_subprog_type (gnu_return_type
, gnu_param_list
,
4049 gnu_return_list
, returns_unconstrained
,
4050 returns_by_ref
, returns_by_target_ptr
);
4054 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
4055 gnu_return_list
, returns_unconstrained
,
4056 returns_by_ref
, returns_by_target_ptr
);
4058 /* A subprogram (something that doesn't return anything) shouldn't
4059 be considered const since there would be no reason for such a
4060 subprogram. Note that procedures with Out (or In Out) parameters
4061 have already been converted into a function with a return type. */
4062 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
4066 = build_qualified_type (gnu_type
,
4067 TYPE_QUALS (gnu_type
)
4068 | (TYPE_QUAL_CONST
* const_flag
)
4069 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4071 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
4075 = build_qualified_type (gnu_stub_type
,
4076 TYPE_QUALS (gnu_stub_type
)
4077 | (TYPE_QUAL_CONST
* const_flag
)
4078 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
4080 /* If we have a builtin decl for that function, check the signatures
4081 compatibilities. If the signatures are compatible, use the builtin
4082 decl. If they are not, we expect the checker predicate to have
4083 posted the appropriate errors, and just continue with what we have
4085 if (gnu_builtin_decl
)
4087 tree gnu_builtin_type
= TREE_TYPE (gnu_builtin_decl
);
4089 if (compatible_signatures_p (gnu_type
, gnu_builtin_type
))
4091 gnu_decl
= gnu_builtin_decl
;
4092 gnu_type
= gnu_builtin_type
;
4097 /* If there was no specified Interface_Name and the external and
4098 internal names of the subprogram are the same, only use the
4099 internal name to allow disambiguation of nested subprograms. */
4100 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_id
)
4101 gnu_ext_name
= NULL_TREE
;
4103 /* If we are defining the subprogram and it has an Address clause
4104 we must get the address expression from the saved GCC tree for the
4105 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4106 the address expression here since the front-end has guaranteed
4107 in that case that the elaboration has no effects. If there is
4108 an Address clause and we are not defining the object, just
4109 make it a constant. */
4110 if (Present (Address_Clause (gnat_entity
)))
4112 tree gnu_address
= NULL_TREE
;
4116 = (present_gnu_tree (gnat_entity
)
4117 ? get_gnu_tree (gnat_entity
)
4118 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
4120 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
4122 /* Convert the type of the object to a reference type that can
4123 alias everything as per 13.3(19). */
4125 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
4127 gnu_address
= convert (gnu_type
, gnu_address
);
4130 = create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
4131 gnu_address
, false, Is_Public (gnat_entity
),
4132 extern_flag
, false, NULL
, gnat_entity
);
4133 DECL_BY_REF_P (gnu_decl
) = 1;
4136 else if (kind
== E_Subprogram_Type
)
4137 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4138 !Comes_From_Source (gnat_entity
),
4139 debug_info_p
, gnat_entity
);
4144 gnu_stub_name
= gnu_ext_name
;
4145 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
4146 public_flag
= false;
4149 gnu_decl
= create_subprog_decl (gnu_entity_id
, gnu_ext_name
,
4150 gnu_type
, gnu_param_list
,
4151 inline_flag
, public_flag
,
4152 extern_flag
, attr_list
,
4157 = create_subprog_decl (gnu_entity_id
, gnu_stub_name
,
4158 gnu_stub_type
, gnu_stub_param_list
,
4160 extern_flag
, attr_list
,
4162 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
4165 /* This is unrelated to the stub built right above. */
4166 DECL_STUBBED_P (gnu_decl
)
4167 = Convention (gnat_entity
) == Convention_Stubbed
;
4172 case E_Incomplete_Type
:
4173 case E_Incomplete_Subtype
:
4174 case E_Private_Type
:
4175 case E_Private_Subtype
:
4176 case E_Limited_Private_Type
:
4177 case E_Limited_Private_Subtype
:
4178 case E_Record_Type_With_Private
:
4179 case E_Record_Subtype_With_Private
:
4181 /* Get the "full view" of this entity. If this is an incomplete
4182 entity from a limited with, treat its non-limited view as the
4183 full view. Otherwise, use either the full view or the underlying
4184 full view, whichever is present. This is used in all the tests
4187 = (IN (Ekind (gnat_entity
), Incomplete_Kind
)
4188 && From_With_Type (gnat_entity
))
4189 ? Non_Limited_View (gnat_entity
)
4190 : Present (Full_View (gnat_entity
))
4191 ? Full_View (gnat_entity
)
4192 : Underlying_Full_View (gnat_entity
);
4194 /* If this is an incomplete type with no full view, it must be a Taft
4195 Amendment type, in which case we return a dummy type. Otherwise,
4196 just get the type from its Etype. */
4199 if (kind
== E_Incomplete_Type
)
4201 gnu_type
= make_dummy_type (gnat_entity
);
4202 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4206 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
4208 maybe_present
= true;
4213 /* If we already made a type for the full view, reuse it. */
4214 else if (present_gnu_tree (full_view
))
4216 gnu_decl
= get_gnu_tree (full_view
);
4220 /* Otherwise, if we are not defining the type now, get the type
4221 from the full view. But always get the type from the full view
4222 for define on use types, since otherwise we won't see them! */
4223 else if (!definition
4224 || (Is_Itype (full_view
)
4225 && No (Freeze_Node (gnat_entity
)))
4226 || (Is_Itype (gnat_entity
)
4227 && No (Freeze_Node (full_view
))))
4229 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
4230 maybe_present
= true;
4234 /* For incomplete types, make a dummy type entry which will be
4235 replaced later. Save it as the full declaration's type so
4236 we can do any needed updates when we see it. */
4237 gnu_type
= make_dummy_type (gnat_entity
);
4238 gnu_decl
= TYPE_STUB_DECL (gnu_type
);
4239 save_gnu_tree (full_view
, gnu_decl
, 0);
4243 /* Simple class_wide types are always viewed as their root_type
4244 by Gigi unless an Equivalent_Type is specified. */
4245 case E_Class_Wide_Type
:
4246 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4247 maybe_present
= true;
4251 case E_Task_Subtype
:
4252 case E_Protected_Type
:
4253 case E_Protected_Subtype
:
4254 if (type_annotate_only
&& No (gnat_equiv_type
))
4255 gnu_type
= void_type_node
;
4257 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
4259 maybe_present
= true;
4263 gnu_decl
= create_label_decl (gnu_entity_id
);
4268 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4269 we've already saved it, so we don't try to. */
4270 gnu_decl
= error_mark_node
;
4278 /* If we had a case where we evaluated another type and it might have
4279 defined this one, handle it here. */
4280 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4282 gnu_decl
= get_gnu_tree (gnat_entity
);
4286 /* If we are processing a type and there is either no decl for it or
4287 we just made one, do some common processing for the type, such as
4288 handling alignment and possible padding. */
4290 if ((!gnu_decl
|| this_made_decl
) && IN (kind
, Type_Kind
))
4292 if (Is_Tagged_Type (gnat_entity
)
4293 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4294 TYPE_ALIGN_OK (gnu_type
) = 1;
4296 if (AGGREGATE_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4297 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4299 /* ??? Don't set the size for a String_Literal since it is either
4300 confirming or we don't handle it properly (if the low bound is
4302 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4303 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
, gnat_entity
,
4305 Has_Size_Clause (gnat_entity
));
4307 /* If a size was specified, see if we can make a new type of that size
4308 by rearranging the type, for example from a fat to a thin pointer. */
4312 = make_type_from_size (gnu_type
, gnu_size
,
4313 Has_Biased_Representation (gnat_entity
));
4315 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4316 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4320 /* If the alignment hasn't already been processed and this is
4321 not an unconstrained array, see if an alignment is specified.
4322 If not, we pick a default alignment for atomic objects. */
4323 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4325 else if (Known_Alignment (gnat_entity
))
4327 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4328 TYPE_ALIGN (gnu_type
));
4330 /* Warn on suspiciously large alignments. This should catch
4331 errors about the (alignment,byte)/(size,bit) discrepancy. */
4332 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4336 /* If a size was specified, take it into account. Otherwise
4337 use the RM size for records as the type size has already
4338 been adjusted to the alignment. */
4341 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
4342 || TREE_CODE (gnu_type
) == UNION_TYPE
4343 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
4344 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
4345 size
= rm_size (gnu_type
);
4347 size
= TYPE_SIZE (gnu_type
);
4349 /* Consider an alignment as suspicious if the alignment/size
4350 ratio is greater or equal to the byte/bit ratio. */
4351 if (host_integerp (size
, 1)
4352 && align
>= TREE_INT_CST_LOW (size
) * BITS_PER_UNIT
)
4353 post_error_ne ("?suspiciously large alignment specified for&",
4354 Expression (Alignment_Clause (gnat_entity
)),
4358 else if (Is_Atomic (gnat_entity
) && !gnu_size
4359 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4360 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4361 align
= MIN (BIGGEST_ALIGNMENT
,
4362 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4363 else if (Is_Atomic (gnat_entity
) && gnu_size
4364 && host_integerp (gnu_size
, 1)
4365 && integer_pow2p (gnu_size
))
4366 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4368 /* See if we need to pad the type. If we did, and made a record,
4369 the name of the new type may be changed. So get it back for
4370 us when we make the new TYPE_DECL below. */
4371 if (gnu_size
|| align
> 0)
4372 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
4373 "PAD", true, definition
, false);
4375 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4376 && TYPE_IS_PADDING_P (gnu_type
))
4378 gnu_entity_id
= TYPE_NAME (gnu_type
);
4379 if (TREE_CODE (gnu_entity_id
) == TYPE_DECL
)
4380 gnu_entity_id
= DECL_NAME (gnu_entity_id
);
4383 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4385 /* If we are at global level, GCC will have applied variable_size to
4386 the type, but that won't have done anything. So, if it's not
4387 a constant or self-referential, call elaborate_expression_1 to
4388 make a variable for the size rather than calculating it each time.
4389 Handle both the RM size and the actual size. */
4390 if (global_bindings_p ()
4391 && TYPE_SIZE (gnu_type
)
4392 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4393 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4395 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4396 && operand_equal_p (TYPE_ADA_SIZE (gnu_type
),
4397 TYPE_SIZE (gnu_type
), 0))
4399 TYPE_SIZE (gnu_type
)
4400 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4401 TYPE_SIZE (gnu_type
),
4402 get_identifier ("SIZE"),
4404 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_SIZE (gnu_type
));
4408 TYPE_SIZE (gnu_type
)
4409 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4410 TYPE_SIZE (gnu_type
),
4411 get_identifier ("SIZE"),
4414 /* ??? For now, store the size as a multiple of the alignment
4415 in bytes so that we can see the alignment from the tree. */
4416 TYPE_SIZE_UNIT (gnu_type
)
4418 (MULT_EXPR
, sizetype
,
4419 elaborate_expression_1
4420 (gnat_entity
, gnat_entity
,
4421 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4422 TYPE_SIZE_UNIT (gnu_type
),
4423 size_int (TYPE_ALIGN (gnu_type
)
4425 get_identifier ("SIZE_A_UNIT"),
4427 size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4429 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4432 elaborate_expression_1 (gnat_entity
,
4434 TYPE_ADA_SIZE (gnu_type
),
4435 get_identifier ("RM_SIZE"),
4440 /* If this is a record type or subtype, call elaborate_expression_1 on
4441 any field position. Do this for both global and local types.
4442 Skip any fields that we haven't made trees for to avoid problems with
4443 class wide types. */
4444 if (IN (kind
, Record_Kind
))
4445 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4446 gnat_temp
= Next_Entity (gnat_temp
))
4447 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4449 tree gnu_field
= get_gnu_tree (gnat_temp
);
4451 /* ??? Unfortunately, GCC needs to be able to prove the
4452 alignment of this offset and if it's a variable, it can't.
4453 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4454 right now, we have to put in an explicit multiply and
4455 divide by that value. */
4456 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4458 DECL_FIELD_OFFSET (gnu_field
)
4460 (MULT_EXPR
, sizetype
,
4461 elaborate_expression_1
4462 (gnat_temp
, gnat_temp
,
4463 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4464 DECL_FIELD_OFFSET (gnu_field
),
4465 size_int (DECL_OFFSET_ALIGN (gnu_field
)
4467 get_identifier ("OFFSET"),
4469 size_int (DECL_OFFSET_ALIGN (gnu_field
) / BITS_PER_UNIT
));
4471 /* ??? The context of gnu_field is not necessarily gnu_type so
4472 the MULT_EXPR node built above may not be marked by the call
4473 to create_type_decl below. */
4474 if (global_bindings_p ())
4475 mark_visited (&DECL_FIELD_OFFSET (gnu_field
));
4479 gnu_type
= build_qualified_type (gnu_type
,
4480 (TYPE_QUALS (gnu_type
)
4481 | (TYPE_QUAL_VOLATILE
4482 * Treat_As_Volatile (gnat_entity
))));
4484 if (Is_Atomic (gnat_entity
))
4485 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
4487 if (Present (Alignment_Clause (gnat_entity
)))
4488 TYPE_USER_ALIGN (gnu_type
) = 1;
4490 if (Universal_Aliasing (gnat_entity
))
4491 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
4494 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4495 !Comes_From_Source (gnat_entity
),
4496 debug_info_p
, gnat_entity
);
4498 TREE_TYPE (gnu_decl
) = gnu_type
;
4501 if (IN (kind
, Type_Kind
) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4503 gnu_type
= TREE_TYPE (gnu_decl
);
4505 /* If this is a derived type, relate its alias set to that of its parent
4506 to avoid troubles when a call to an inherited primitive is inlined in
4507 a context where a derived object is accessed. The inlined code works
4508 on the parent view so the resulting code may access the same object
4509 using both the parent and the derived alias sets, which thus have to
4510 conflict. As the same issue arises with component references, the
4511 parent alias set also has to conflict with composite types enclosing
4512 derived components. For instance, if we have:
4519 we want T to conflict with both D and R, in addition to R being a
4520 superset of D by record/component construction.
4522 One way to achieve this is to perform an alias set copy from the
4523 parent to the derived type. This is not quite appropriate, though,
4524 as we don't want separate derived types to conflict with each other:
4526 type I1 is new Integer;
4527 type I2 is new Integer;
4529 We want I1 and I2 to both conflict with Integer but we do not want
4530 I1 to conflict with I2, and an alias set copy on derivation would
4533 The option chosen is to make the alias set of the derived type a
4534 superset of that of its parent type. It trivially fulfills the
4535 simple requirement for the Integer derivation example above, and
4536 the component case as well by superset transitivity:
4539 R ----------> D ----------> T
4541 The language rules ensure the parent type is already frozen here. */
4542 if (Is_Derived_Type (gnat_entity
))
4544 tree gnu_parent_type
= gnat_to_gnu_type (Etype (gnat_entity
));
4545 relate_alias_sets (gnu_type
, gnu_parent_type
, ALIAS_SET_SUPERSET
);
4548 /* Back-annotate the Alignment of the type if not already in the
4549 tree. Likewise for sizes. */
4550 if (Unknown_Alignment (gnat_entity
))
4551 Set_Alignment (gnat_entity
,
4552 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4554 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4556 /* If the size is self-referential, we annotate the maximum
4557 value of that size. */
4558 tree gnu_size
= TYPE_SIZE (gnu_type
);
4560 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4561 gnu_size
= max_size (gnu_size
, true);
4563 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4565 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4567 /* In this mode the tag and the parent components are not
4568 generated by the front-end, so the sizes must be adjusted
4570 int size_offset
, new_size
;
4572 if (Is_Derived_Type (gnat_entity
))
4575 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity
))));
4576 Set_Alignment (gnat_entity
,
4577 Alignment (Etype (Base_Type (gnat_entity
))));
4580 size_offset
= POINTER_SIZE
;
4582 new_size
= UI_To_Int (Esize (gnat_entity
)) + size_offset
;
4583 Set_Esize (gnat_entity
,
4584 UI_From_Int (((new_size
+ (POINTER_SIZE
- 1))
4585 / POINTER_SIZE
) * POINTER_SIZE
));
4586 Set_RM_Size (gnat_entity
, Esize (gnat_entity
));
4590 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
4591 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4594 if (!Comes_From_Source (gnat_entity
) && DECL_P (gnu_decl
))
4595 DECL_ARTIFICIAL (gnu_decl
) = 1;
4597 if (!debug_info_p
&& DECL_P (gnu_decl
)
4598 && TREE_CODE (gnu_decl
) != FUNCTION_DECL
4599 && No (Renamed_Object (gnat_entity
)))
4600 DECL_IGNORED_P (gnu_decl
) = 1;
4602 /* If we haven't already, associate the ..._DECL node that we just made with
4603 the input GNAT entity node. */
4605 save_gnu_tree (gnat_entity
, gnu_decl
, false);
4607 /* If this is an enumeral or floating-point type, we were not able to set
4608 the bounds since they refer to the type. These bounds are always static.
4610 For enumeration types, also write debugging information and declare the
4611 enumeration literal table, if needed. */
4613 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
4614 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
4616 tree gnu_scalar_type
= gnu_type
;
4618 /* If this is a padded type, we need to use the underlying type. */
4619 if (TREE_CODE (gnu_scalar_type
) == RECORD_TYPE
4620 && TYPE_IS_PADDING_P (gnu_scalar_type
))
4621 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
4623 /* If this is a floating point type and we haven't set a floating
4624 point type yet, use this in the evaluation of the bounds. */
4625 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
4626 longest_float_type_node
= gnu_type
;
4628 TYPE_MIN_VALUE (gnu_scalar_type
)
4629 = gnat_to_gnu (Type_Low_Bound (gnat_entity
));
4630 TYPE_MAX_VALUE (gnu_scalar_type
)
4631 = gnat_to_gnu (Type_High_Bound (gnat_entity
));
4633 if (TREE_CODE (gnu_scalar_type
) == ENUMERAL_TYPE
)
4635 /* Since this has both a typedef and a tag, avoid outputting
4637 DECL_ARTIFICIAL (gnu_decl
) = 1;
4638 rest_of_type_decl_compilation (gnu_decl
);
4642 /* If we deferred processing of incomplete types, re-enable it. If there
4643 were no other disables and we have some to process, do so. */
4644 if (this_deferred
&& --defer_incomplete_level
== 0)
4646 if (defer_incomplete_list
)
4648 struct incomplete
*incp
, *next
;
4650 /* We are back to level 0 for the deferring of incomplete types.
4651 But processing these incomplete types below may itself require
4652 deferring, so preserve what we have and restart from scratch. */
4653 incp
= defer_incomplete_list
;
4654 defer_incomplete_list
= NULL
;
4656 /* For finalization, however, all types must be complete so we
4657 cannot do the same because deferred incomplete types may end up
4658 referencing each other. Process them all recursively first. */
4659 defer_finalize_level
++;
4661 for (; incp
; incp
= next
)
4666 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4667 gnat_to_gnu_type (incp
->full_type
));
4671 defer_finalize_level
--;
4674 /* All the deferred incomplete types have been processed so we can
4675 now proceed with the finalization of the deferred types. */
4676 if (defer_finalize_level
== 0 && defer_finalize_list
)
4681 for (i
= 0; VEC_iterate (tree
, defer_finalize_list
, i
, t
); i
++)
4682 rest_of_type_decl_compilation_no_defer (t
);
4684 VEC_free (tree
, heap
, defer_finalize_list
);
4688 /* If we are not defining this type, see if it's in the incomplete list.
4689 If so, handle that list entry now. */
4690 else if (!definition
)
4692 struct incomplete
*incp
;
4694 for (incp
= defer_incomplete_list
; incp
; incp
= incp
->next
)
4695 if (incp
->old_type
&& incp
->full_type
== gnat_entity
)
4697 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4698 TREE_TYPE (gnu_decl
));
4699 incp
->old_type
= NULL_TREE
;
4706 if (Is_Packed_Array_Type (gnat_entity
)
4707 && Is_Itype (Associated_Node_For_Itype (gnat_entity
))
4708 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity
)))
4709 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity
)))
4710 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity
), NULL_TREE
, 0);
4715 /* Similar, but if the returned value is a COMPONENT_REF, return the
4719 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
4721 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4723 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
4724 gnu_field
= TREE_OPERAND (gnu_field
, 1);
4729 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4730 the GCC type corresponding to that entity. */
4733 gnat_to_gnu_type (Entity_Id gnat_entity
)
4737 /* The back end never attempts to annotate generic types. */
4738 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
4739 return void_type_node
;
4741 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4742 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
4744 return TREE_TYPE (gnu_decl
);
4747 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4748 the unpadded version of the GCC type corresponding to that entity. */
4751 get_unpadded_type (Entity_Id gnat_entity
)
4753 tree type
= gnat_to_gnu_type (gnat_entity
);
4755 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
4756 type
= TREE_TYPE (TYPE_FIELDS (type
));
4761 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4762 Every TYPE_DECL generated for a type definition must be passed
4763 to this function once everything else has been done for it. */
4766 rest_of_type_decl_compilation (tree decl
)
4768 /* We need to defer finalizing the type if incomplete types
4769 are being deferred or if they are being processed. */
4770 if (defer_incomplete_level
|| defer_finalize_level
)
4771 VEC_safe_push (tree
, heap
, defer_finalize_list
, decl
);
4773 rest_of_type_decl_compilation_no_defer (decl
);
4776 /* Same as above but without deferring the compilation. This
4777 function should not be invoked directly on a TYPE_DECL. */
4780 rest_of_type_decl_compilation_no_defer (tree decl
)
4782 const int toplev
= global_bindings_p ();
4783 tree t
= TREE_TYPE (decl
);
4785 rest_of_decl_compilation (decl
, toplev
, 0);
4787 /* Now process all the variants. This is needed for STABS. */
4788 for (t
= TYPE_MAIN_VARIANT (t
); t
; t
= TYPE_NEXT_VARIANT (t
))
4790 if (t
== TREE_TYPE (decl
))
4793 if (!TYPE_STUB_DECL (t
))
4794 TYPE_STUB_DECL (t
) = create_type_stub_decl (DECL_NAME (decl
), t
);
4796 rest_of_type_compilation (t
, toplev
);
4800 /* Finalize any From_With_Type incomplete types. We do this after processing
4801 our compilation unit and after processing its spec, if this is a body. */
4804 finalize_from_with_types (void)
4806 struct incomplete
*incp
= defer_limited_with
;
4807 struct incomplete
*next
;
4809 defer_limited_with
= 0;
4810 for (; incp
; incp
= next
)
4814 if (incp
->old_type
!= 0)
4815 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4816 gnat_to_gnu_type (incp
->full_type
));
4821 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4822 kind of type (such E_Task_Type) that has a different type which Gigi
4823 uses for its representation. If the type does not have a special type
4824 for its representation, return GNAT_ENTITY. If a type is supposed to
4825 exist, but does not, abort unless annotating types, in which case
4826 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4829 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
4831 Entity_Id gnat_equiv
= gnat_entity
;
4833 if (No (gnat_entity
))
4836 switch (Ekind (gnat_entity
))
4838 case E_Class_Wide_Subtype
:
4839 if (Present (Equivalent_Type (gnat_entity
)))
4840 gnat_equiv
= Equivalent_Type (gnat_entity
);
4843 case E_Access_Protected_Subprogram_Type
:
4844 case E_Anonymous_Access_Protected_Subprogram_Type
:
4845 gnat_equiv
= Equivalent_Type (gnat_entity
);
4848 case E_Class_Wide_Type
:
4849 gnat_equiv
= ((Present (Equivalent_Type (gnat_entity
)))
4850 ? Equivalent_Type (gnat_entity
)
4851 : Root_Type (gnat_entity
));
4855 case E_Task_Subtype
:
4856 case E_Protected_Type
:
4857 case E_Protected_Subtype
:
4858 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
4865 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
4869 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4870 using MECH as its passing mechanism, to be placed in the parameter
4871 list built for GNAT_SUBPROG. Assume a foreign convention for the
4872 latter if FOREIGN is true. Also set CICO to true if the parameter
4873 must use the copy-in copy-out implementation mechanism.
4875 The returned tree is a PARM_DECL, except for those cases where no
4876 parameter needs to be actually passed to the subprogram; the type
4877 of this "shadow" parameter is then returned instead. */
4880 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
4881 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
4883 tree gnu_param_name
= get_entity_name (gnat_param
);
4884 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
4885 tree gnu_param_type_alt
= NULL_TREE
;
4886 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
4887 /* The parameter can be indirectly modified if its address is taken. */
4888 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
4889 bool by_return
= false, by_component_ptr
= false, by_ref
= false;
4892 /* Copy-return is used only for the first parameter of a valued procedure.
4893 It's a copy mechanism for which a parameter is never allocated. */
4894 if (mech
== By_Copy_Return
)
4896 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
4901 /* If this is either a foreign function or if the underlying type won't
4902 be passed by reference, strip off possible padding type. */
4903 if (TREE_CODE (gnu_param_type
) == RECORD_TYPE
4904 && TYPE_IS_PADDING_P (gnu_param_type
))
4906 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
4908 if (mech
== By_Reference
4910 || (!must_pass_by_ref (unpadded_type
)
4911 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
4912 gnu_param_type
= unpadded_type
;
4915 /* If this is a read-only parameter, make a variant of the type that is
4916 read-only. ??? However, if this is an unconstrained array, that type
4917 can be very complex, so skip it for now. Likewise for any other
4918 self-referential type. */
4920 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
4921 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
4922 gnu_param_type
= build_qualified_type (gnu_param_type
,
4923 (TYPE_QUALS (gnu_param_type
)
4924 | TYPE_QUAL_CONST
));
4926 /* For foreign conventions, pass arrays as pointers to the element type.
4927 First check for unconstrained array and get the underlying array. */
4928 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4930 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
4932 /* VMS descriptors are themselves passed by reference. */
4933 if (mech
== By_Short_Descriptor
||
4934 (mech
== By_Descriptor
&& TARGET_ABI_OPEN_VMS
&& !TARGET_MALLOC64
))
4936 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
4937 Mechanism (gnat_param
),
4939 else if (mech
== By_Descriptor
)
4941 /* Build both a 32-bit and 64-bit descriptor, one of which will be
4942 chosen in fill_vms_descriptor. */
4944 = build_pointer_type (build_vms_descriptor32 (gnu_param_type
,
4945 Mechanism (gnat_param
),
4948 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
4949 Mechanism (gnat_param
),
4953 /* Arrays are passed as pointers to element type for foreign conventions. */
4956 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
4958 /* Strip off any multi-dimensional entries, then strip
4959 off the last array to get the component type. */
4960 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
4961 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
4962 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4964 by_component_ptr
= true;
4965 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4968 gnu_param_type
= build_qualified_type (gnu_param_type
,
4969 (TYPE_QUALS (gnu_param_type
)
4970 | TYPE_QUAL_CONST
));
4972 gnu_param_type
= build_pointer_type (gnu_param_type
);
4975 /* Fat pointers are passed as thin pointers for foreign conventions. */
4976 else if (foreign
&& TYPE_FAT_POINTER_P (gnu_param_type
))
4978 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
4980 /* If we must pass or were requested to pass by reference, do so.
4981 If we were requested to pass by copy, do so.
4982 Otherwise, for foreign conventions, pass In Out or Out parameters
4983 or aggregates by reference. For COBOL and Fortran, pass all
4984 integer and FP types that way too. For Convention Ada, use
4985 the standard Ada default. */
4986 else if (must_pass_by_ref (gnu_param_type
)
4987 || mech
== By_Reference
4990 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
4992 && (Convention (gnat_subprog
) == Convention_Fortran
4993 || Convention (gnat_subprog
) == Convention_COBOL
)
4994 && (INTEGRAL_TYPE_P (gnu_param_type
)
4995 || FLOAT_TYPE_P (gnu_param_type
)))
4997 && default_pass_by_ref (gnu_param_type
)))))
4999 gnu_param_type
= build_reference_type (gnu_param_type
);
5003 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5007 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
5008 post_error ("?cannot pass & by copy", gnat_param
);
5010 /* If this is an Out parameter that isn't passed by reference and isn't
5011 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5012 it will be a VAR_DECL created when we process the procedure, so just
5013 return its type. For the special parameter of a valued procedure,
5016 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5017 Out parameters with discriminants or implicit initial values to be
5018 handled like In Out parameters. These type are normally built as
5019 aggregates, hence passed by reference, except for some packed arrays
5020 which end up encoded in special integer types.
5022 The exception we need to make is then for packed arrays of records
5023 with discriminants or implicit initial values. We have no light/easy
5024 way to check for the latter case, so we merely check for packed arrays
5025 of records. This may lead to useless copy-in operations, but in very
5026 rare cases only, as these would be exceptions in a set of already
5027 exceptional situations. */
5028 if (Ekind (gnat_param
) == E_Out_Parameter
5031 || (mech
!= By_Descriptor
5032 && mech
!= By_Short_Descriptor
5033 && !POINTER_TYPE_P (gnu_param_type
)
5034 && !AGGREGATE_TYPE_P (gnu_param_type
)))
5035 && !(Is_Array_Type (Etype (gnat_param
))
5036 && Is_Packed (Etype (gnat_param
))
5037 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
5038 return gnu_param_type
;
5040 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
5041 ro_param
|| by_ref
|| by_component_ptr
);
5042 DECL_BY_REF_P (gnu_param
) = by_ref
;
5043 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
5044 DECL_BY_DESCRIPTOR_P (gnu_param
) = (mech
== By_Descriptor
||
5045 mech
== By_Short_Descriptor
);
5046 DECL_POINTS_TO_READONLY_P (gnu_param
)
5047 = (ro_param
&& (by_ref
|| by_component_ptr
));
5049 /* Save the alternate descriptor type, if any. */
5050 if (gnu_param_type_alt
)
5051 SET_DECL_PARM_ALT_TYPE (gnu_param
, gnu_param_type_alt
);
5053 /* If no Mechanism was specified, indicate what we're using, then
5054 back-annotate it. */
5055 if (mech
== Default
)
5056 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
5058 Set_Mechanism (gnat_param
, mech
);
5062 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5065 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
5067 while (Present (Corresponding_Discriminant (discr1
)))
5068 discr1
= Corresponding_Discriminant (discr1
);
5070 while (Present (Corresponding_Discriminant (discr2
)))
5071 discr2
= Corresponding_Discriminant (discr2
);
5074 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
5077 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
5078 a non-aliased component in the back-end sense. */
5081 array_type_has_nonaliased_component (Entity_Id gnat_type
, tree gnu_type
)
5083 /* If the type below this is a multi-array type, then
5084 this does not have aliased components. */
5085 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
5086 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
5089 if (Has_Aliased_Components (gnat_type
))
5092 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
5095 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5098 compile_time_known_address_p (Node_Id gnat_address
)
5100 /* Catch System'To_Address. */
5101 if (Nkind (gnat_address
) == N_Unchecked_Type_Conversion
)
5102 gnat_address
= Expression (gnat_address
);
5104 return Compile_Time_Known_Value (gnat_address
);
5107 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5108 be elaborated at the point of its definition, but do nothing else. */
5111 elaborate_entity (Entity_Id gnat_entity
)
5113 switch (Ekind (gnat_entity
))
5115 case E_Signed_Integer_Subtype
:
5116 case E_Modular_Integer_Subtype
:
5117 case E_Enumeration_Subtype
:
5118 case E_Ordinary_Fixed_Point_Subtype
:
5119 case E_Decimal_Fixed_Point_Subtype
:
5120 case E_Floating_Point_Subtype
:
5122 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
5123 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
5125 /* ??? Tests for avoiding static constraint error expression
5126 is needed until the front stops generating bogus conversions
5127 on bounds of real types. */
5129 if (!Raises_Constraint_Error (gnat_lb
))
5130 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
5131 1, 0, Needs_Debug_Info (gnat_entity
));
5132 if (!Raises_Constraint_Error (gnat_hb
))
5133 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
5134 1, 0, Needs_Debug_Info (gnat_entity
));
5140 Node_Id full_definition
= Declaration_Node (gnat_entity
);
5141 Node_Id record_definition
= Type_Definition (full_definition
);
5143 /* If this is a record extension, go a level further to find the
5144 record definition. */
5145 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
5146 record_definition
= Record_Extension_Part (record_definition
);
5150 case E_Record_Subtype
:
5151 case E_Private_Subtype
:
5152 case E_Limited_Private_Subtype
:
5153 case E_Record_Subtype_With_Private
:
5154 if (Is_Constrained (gnat_entity
)
5155 && Has_Discriminants (Base_Type (gnat_entity
))
5156 && Present (Discriminant_Constraint (gnat_entity
)))
5158 Node_Id gnat_discriminant_expr
;
5159 Entity_Id gnat_field
;
5161 for (gnat_field
= First_Discriminant (Base_Type (gnat_entity
)),
5162 gnat_discriminant_expr
5163 = First_Elmt (Discriminant_Constraint (gnat_entity
));
5164 Present (gnat_field
);
5165 gnat_field
= Next_Discriminant (gnat_field
),
5166 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
5167 /* ??? For now, ignore access discriminants. */
5168 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
5169 elaborate_expression (Node (gnat_discriminant_expr
),
5171 get_entity_name (gnat_field
), 1, 0, 0);
5178 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5179 any entities on its entity chain similarly. */
5182 mark_out_of_scope (Entity_Id gnat_entity
)
5184 Entity_Id gnat_sub_entity
;
5185 unsigned int kind
= Ekind (gnat_entity
);
5187 /* If this has an entity list, process all in the list. */
5188 if (IN (kind
, Class_Wide_Kind
) || IN (kind
, Concurrent_Kind
)
5189 || IN (kind
, Private_Kind
)
5190 || kind
== E_Block
|| kind
== E_Entry
|| kind
== E_Entry_Family
5191 || kind
== E_Function
|| kind
== E_Generic_Function
5192 || kind
== E_Generic_Package
|| kind
== E_Generic_Procedure
5193 || kind
== E_Loop
|| kind
== E_Operator
|| kind
== E_Package
5194 || kind
== E_Package_Body
|| kind
== E_Procedure
5195 || kind
== E_Record_Type
|| kind
== E_Record_Subtype
5196 || kind
== E_Subprogram_Body
|| kind
== E_Subprogram_Type
)
5197 for (gnat_sub_entity
= First_Entity (gnat_entity
);
5198 Present (gnat_sub_entity
);
5199 gnat_sub_entity
= Next_Entity (gnat_sub_entity
))
5200 if (Scope (gnat_sub_entity
) == gnat_entity
5201 && gnat_sub_entity
!= gnat_entity
)
5202 mark_out_of_scope (gnat_sub_entity
);
5204 /* Now clear this if it has been defined, but only do so if it isn't
5205 a subprogram or parameter. We could refine this, but it isn't
5206 worth it. If this is statically allocated, it is supposed to
5207 hang around out of cope. */
5208 if (present_gnu_tree (gnat_entity
) && !Is_Statically_Allocated (gnat_entity
)
5209 && kind
!= E_Procedure
&& kind
!= E_Function
&& !IN (kind
, Formal_Kind
))
5211 save_gnu_tree (gnat_entity
, NULL_TREE
, true);
5212 save_gnu_tree (gnat_entity
, error_mark_node
, true);
5216 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5217 If this is a multi-dimensional array type, do this recursively.
5220 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5221 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5222 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5225 relate_alias_sets (tree gnu_new_type
, tree gnu_old_type
, enum alias_set_op op
)
5227 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5228 of a one-dimensional array, since the padding has the same alias set
5229 as the field type, but if it's a multi-dimensional array, we need to
5230 see the inner types. */
5231 while (TREE_CODE (gnu_old_type
) == RECORD_TYPE
5232 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type
)
5233 || TYPE_IS_PADDING_P (gnu_old_type
)))
5234 gnu_old_type
= TREE_TYPE (TYPE_FIELDS (gnu_old_type
));
5236 /* Unconstrained array types are deemed incomplete and would thus be given
5237 alias set 0. Retrieve the underlying array type. */
5238 if (TREE_CODE (gnu_old_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5240 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type
))));
5241 if (TREE_CODE (gnu_new_type
) == UNCONSTRAINED_ARRAY_TYPE
)
5243 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type
))));
5245 if (TREE_CODE (gnu_new_type
) == ARRAY_TYPE
5246 && TREE_CODE (TREE_TYPE (gnu_new_type
)) == ARRAY_TYPE
5247 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type
)))
5248 relate_alias_sets (TREE_TYPE (gnu_new_type
), TREE_TYPE (gnu_old_type
), op
);
5252 case ALIAS_SET_COPY
:
5253 /* The alias set shouldn't be copied between array types with different
5254 aliasing settings because this can break the aliasing relationship
5255 between the array type and its element type. */
5256 #ifndef ENABLE_CHECKING
5257 if (flag_strict_aliasing
)
5259 gcc_assert (!(TREE_CODE (gnu_new_type
) == ARRAY_TYPE
5260 && TREE_CODE (gnu_old_type
) == ARRAY_TYPE
5261 && TYPE_NONALIASED_COMPONENT (gnu_new_type
)
5262 != TYPE_NONALIASED_COMPONENT (gnu_old_type
)));
5264 TYPE_ALIAS_SET (gnu_new_type
) = get_alias_set (gnu_old_type
);
5267 case ALIAS_SET_SUBSET
:
5268 case ALIAS_SET_SUPERSET
:
5270 alias_set_type old_set
= get_alias_set (gnu_old_type
);
5271 alias_set_type new_set
= get_alias_set (gnu_new_type
);
5273 /* Do nothing if the alias sets conflict. This ensures that we
5274 never call record_alias_subset several times for the same pair
5275 or at all for alias set 0. */
5276 if (!alias_sets_conflict_p (old_set
, new_set
))
5278 if (op
== ALIAS_SET_SUBSET
)
5279 record_alias_subset (old_set
, new_set
);
5281 record_alias_subset (new_set
, old_set
);
5290 record_component_aliases (gnu_new_type
);
5293 /* Return a TREE_LIST describing the substitutions needed to reflect
5294 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5295 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
5296 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
5297 gives the tree for the discriminant and TREE_VALUES is the replacement
5298 value. They are in the form of operands to substitute_in_expr.
5299 DEFINITION is as in gnat_to_gnu_entity. */
5302 substitution_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
,
5303 tree gnu_list
, bool definition
)
5305 Entity_Id gnat_discrim
;
5309 gnat_type
= Implementation_Base_Type (gnat_subtype
);
5311 if (Has_Discriminants (gnat_type
))
5312 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
5313 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
5314 Present (gnat_discrim
);
5315 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
5316 gnat_value
= Next_Elmt (gnat_value
))
5317 /* Ignore access discriminants. */
5318 if (!Is_Access_Type (Etype (Node (gnat_value
))))
5319 gnu_list
= tree_cons (gnat_to_gnu_field_decl (gnat_discrim
),
5320 elaborate_expression
5321 (Node (gnat_value
), gnat_subtype
,
5322 get_entity_name (gnat_discrim
), definition
,
5329 /* Return true if the size represented by GNU_SIZE can be handled by an
5330 allocation. If STATIC_P is true, consider only what can be done with a
5331 static allocation. */
5334 allocatable_size_p (tree gnu_size
, bool static_p
)
5336 HOST_WIDE_INT our_size
;
5338 /* If this is not a static allocation, the only case we want to forbid
5339 is an overflowing size. That will be converted into a raise a
5342 return !(TREE_CODE (gnu_size
) == INTEGER_CST
5343 && TREE_OVERFLOW (gnu_size
));
5345 /* Otherwise, we need to deal with both variable sizes and constant
5346 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5347 since assemblers may not like very large sizes. */
5348 if (!host_integerp (gnu_size
, 1))
5351 our_size
= tree_low_cst (gnu_size
, 1);
5352 return (int) our_size
== our_size
;
5355 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5356 NAME, ARGS and ERROR_POINT. */
5359 prepend_one_attribute_to (struct attrib
** attr_list
,
5360 enum attr_type attr_type
,
5363 Node_Id attr_error_point
)
5365 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
5367 attr
->type
= attr_type
;
5368 attr
->name
= attr_name
;
5369 attr
->args
= attr_args
;
5370 attr
->error_point
= attr_error_point
;
5372 attr
->next
= *attr_list
;
5376 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5379 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
5383 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
5384 gnat_temp
= Next_Rep_Item (gnat_temp
))
5385 if (Nkind (gnat_temp
) == N_Pragma
)
5387 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
5388 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
5389 enum attr_type etype
;
5391 if (Present (gnat_assoc
) && Present (First (gnat_assoc
))
5392 && Present (Next (First (gnat_assoc
)))
5393 && (Nkind (Expression (Next (First (gnat_assoc
))))
5394 == N_String_Literal
))
5396 gnu_arg0
= get_identifier (TREE_STRING_POINTER
5399 (First (gnat_assoc
))))));
5400 if (Present (Next (Next (First (gnat_assoc
))))
5401 && (Nkind (Expression (Next (Next (First (gnat_assoc
)))))
5402 == N_String_Literal
))
5403 gnu_arg1
= get_identifier (TREE_STRING_POINTER
5407 (First (gnat_assoc
)))))));
5410 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp
))))
5412 case Pragma_Machine_Attribute
:
5413 etype
= ATTR_MACHINE_ATTRIBUTE
;
5416 case Pragma_Linker_Alias
:
5417 etype
= ATTR_LINK_ALIAS
;
5420 case Pragma_Linker_Section
:
5421 etype
= ATTR_LINK_SECTION
;
5424 case Pragma_Linker_Constructor
:
5425 etype
= ATTR_LINK_CONSTRUCTOR
;
5428 case Pragma_Linker_Destructor
:
5429 etype
= ATTR_LINK_DESTRUCTOR
;
5432 case Pragma_Weak_External
:
5433 etype
= ATTR_WEAK_EXTERNAL
;
5441 /* Prepend to the list now. Make a list of the argument we might
5442 have, as GCC expects it. */
5443 prepend_one_attribute_to
5446 (gnu_arg1
!= NULL_TREE
)
5447 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
5448 Present (Next (First (gnat_assoc
)))
5449 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
5453 /* Called when we need to protect a variable object using a save_expr. */
5456 maybe_variable (tree gnu_operand
)
5458 if (TREE_CONSTANT (gnu_operand
) || TREE_READONLY (gnu_operand
)
5459 || TREE_CODE (gnu_operand
) == SAVE_EXPR
5460 || TREE_CODE (gnu_operand
) == NULL_EXPR
)
5463 if (TREE_CODE (gnu_operand
) == UNCONSTRAINED_ARRAY_REF
)
5465 tree gnu_result
= build1 (UNCONSTRAINED_ARRAY_REF
,
5466 TREE_TYPE (gnu_operand
),
5467 variable_size (TREE_OPERAND (gnu_operand
, 0)));
5469 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
)
5470 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand
)));
5474 return variable_size (gnu_operand
);
5477 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5478 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5479 return the GCC tree to use for that expression. GNU_NAME is the
5480 qualification to use if an external name is appropriate and DEFINITION is
5481 true if this is a definition of GNAT_ENTITY. If NEED_VALUE is true, we
5482 need a result. Otherwise, we are just elaborating this for side-effects.
5483 If NEED_DEBUG is true we need the symbol for debugging purposes even if it
5484 isn't needed for code generation. */
5487 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5488 tree gnu_name
, bool definition
, bool need_value
,
5493 /* If we already elaborated this expression (e.g., it was involved
5494 in the definition of a private type), use the old value. */
5495 if (present_gnu_tree (gnat_expr
))
5496 return get_gnu_tree (gnat_expr
);
5498 /* If we don't need a value and this is static or a discriminant, we
5499 don't need to do anything. */
5500 else if (!need_value
5501 && (Is_OK_Static_Expression (gnat_expr
)
5502 || (Nkind (gnat_expr
) == N_Identifier
5503 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
5506 /* Otherwise, convert this tree to its GCC equivalent. */
5508 = elaborate_expression_1 (gnat_expr
, gnat_entity
, gnat_to_gnu (gnat_expr
),
5509 gnu_name
, definition
, need_debug
);
5511 /* Save the expression in case we try to elaborate this entity again. Since
5512 it's not a DECL, don't check it. Don't save if it's a discriminant. */
5513 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
5514 save_gnu_tree (gnat_expr
, gnu_expr
, true);
5516 return need_value
? gnu_expr
: error_mark_node
;
5519 /* Similar, but take a GNU expression. */
5522 elaborate_expression_1 (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5523 tree gnu_expr
, tree gnu_name
, bool definition
,
5526 tree gnu_decl
= NULL_TREE
;
5527 /* Skip any conversions and simple arithmetics to see if the expression
5528 is a read-only variable.
5529 ??? This really should remain read-only, but we have to think about
5530 the typing of the tree here. */
5532 = skip_simple_arithmetic (remove_conversions (gnu_expr
, true));
5533 bool expr_global
= Is_Public (gnat_entity
) || global_bindings_p ();
5536 /* In most cases, we won't see a naked FIELD_DECL here because a
5537 discriminant reference will have been replaced with a COMPONENT_REF
5538 when the type is being elaborated. However, there are some cases
5539 involving child types where we will. So convert it to a COMPONENT_REF
5540 here. We have to hope it will be at the highest level of the
5541 expression in these cases. */
5542 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
5543 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
5544 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
5545 gnu_expr
, NULL_TREE
);
5547 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5548 that is read-only, make a variable that is initialized to contain the
5549 bound when the package containing the definition is elaborated. If
5550 this entity is defined at top level and a bound or discriminant value
5551 isn't a constant or a reference to a discriminant, replace the bound
5552 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5553 rely here on the fact that an expression cannot contain both the
5554 discriminant and some other variable. */
5556 expr_variable
= (!CONSTANT_CLASS_P (gnu_expr
)
5557 && !(TREE_CODE (gnu_inner_expr
) == VAR_DECL
5558 && (TREE_READONLY (gnu_inner_expr
)
5559 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr
)))
5560 && !CONTAINS_PLACEHOLDER_P (gnu_expr
));
5562 /* If this is a static expression or contains a discriminant, we don't
5563 need the variable for debugging (and can't elaborate anyway if a
5566 && (Is_OK_Static_Expression (gnat_expr
)
5567 || CONTAINS_PLACEHOLDER_P (gnu_expr
)))
5570 /* Now create the variable if we need it. */
5571 if (need_debug
|| (expr_variable
&& expr_global
))
5573 = create_var_decl (create_concat_name (gnat_entity
,
5574 IDENTIFIER_POINTER (gnu_name
)),
5575 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
5576 !need_debug
, Is_Public (gnat_entity
),
5577 !definition
, false, NULL
, gnat_entity
);
5579 /* We only need to use this variable if we are in global context since GCC
5580 can do the right thing in the local case. */
5581 if (expr_global
&& expr_variable
)
5583 else if (!expr_variable
)
5586 return maybe_variable (gnu_expr
);
5589 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5590 starting bit position so that it is aligned to ALIGN bits, and leaving at
5591 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5592 record is guaranteed to get. */
5595 make_aligning_type (tree type
, unsigned int align
, tree size
,
5596 unsigned int base_align
, int room
)
5598 /* We will be crafting a record type with one field at a position set to be
5599 the next multiple of ALIGN past record'address + room bytes. We use a
5600 record placeholder to express record'address. */
5602 tree record_type
= make_node (RECORD_TYPE
);
5603 tree record
= build0 (PLACEHOLDER_EXPR
, record_type
);
5606 = convert (sizetype
, build_unary_op (ADDR_EXPR
, NULL_TREE
, record
));
5608 /* The diagram below summarizes the shape of what we manipulate:
5610 <--------- pos ---------->
5611 { +------------+-------------+-----------------+
5612 record =>{ |############| ... | field (type) |
5613 { +------------+-------------+-----------------+
5614 |<-- room -->|<- voffset ->|<---- size ----->|
5617 record_addr vblock_addr
5619 Every length is in sizetype bytes there, except "pos" which has to be
5620 set as a bit position in the GCC tree for the record. */
5622 tree room_st
= size_int (room
);
5623 tree vblock_addr_st
= size_binop (PLUS_EXPR
, record_addr_st
, room_st
);
5624 tree voffset_st
, pos
, field
;
5626 tree name
= TYPE_NAME (type
);
5628 if (TREE_CODE (name
) == TYPE_DECL
)
5629 name
= DECL_NAME (name
);
5631 TYPE_NAME (record_type
) = concat_id_with_name (name
, "_ALIGN");
5633 /* Compute VOFFSET and then POS. The next byte position multiple of some
5634 alignment after some address is obtained by "and"ing the alignment minus
5635 1 with the two's complement of the address. */
5637 voffset_st
= size_binop (BIT_AND_EXPR
,
5638 size_diffop (size_zero_node
, vblock_addr_st
),
5639 ssize_int ((align
/ BITS_PER_UNIT
) - 1));
5641 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5643 pos
= size_binop (MULT_EXPR
,
5644 convert (bitsizetype
,
5645 size_binop (PLUS_EXPR
, room_st
, voffset_st
)),
5648 /* Craft the GCC record representation. We exceptionally do everything
5649 manually here because 1) our generic circuitry is not quite ready to
5650 handle the complex position/size expressions we are setting up, 2) we
5651 have a strong simplifying factor at hand: we know the maximum possible
5652 value of voffset, and 3) we have to set/reset at least the sizes in
5653 accordance with this maximum value anyway, as we need them to convey
5654 what should be "alloc"ated for this type.
5656 Use -1 as the 'addressable' indication for the field to prevent the
5657 creation of a bitfield. We don't need one, it would have damaging
5658 consequences on the alignment computation, and create_field_decl would
5659 make one without this special argument, for instance because of the
5660 complex position expression. */
5662 field
= create_field_decl (get_identifier ("F"), type
, record_type
,
5664 TYPE_FIELDS (record_type
) = field
;
5666 TYPE_ALIGN (record_type
) = base_align
;
5667 TYPE_USER_ALIGN (record_type
) = 1;
5669 TYPE_SIZE (record_type
)
5670 = size_binop (PLUS_EXPR
,
5671 size_binop (MULT_EXPR
, convert (bitsizetype
, size
),
5673 bitsize_int (align
+ room
* BITS_PER_UNIT
));
5674 TYPE_SIZE_UNIT (record_type
)
5675 = size_binop (PLUS_EXPR
, size
,
5676 size_int (room
+ align
/ BITS_PER_UNIT
));
5678 SET_TYPE_MODE (record_type
, BLKmode
);
5680 relate_alias_sets (record_type
, type
, ALIAS_SET_COPY
);
5684 /* Return the result of rounding T up to ALIGN. */
5686 static inline unsigned HOST_WIDE_INT
5687 round_up_to_align (unsigned HOST_WIDE_INT t
, unsigned int align
)
5695 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5696 as the field type of a packed record if IN_RECORD is true, or as the
5697 component type of a packed array if IN_RECORD is false. See if we can
5698 rewrite it either as a type that has a non-BLKmode, which we can pack
5699 tighter in the packed record case, or as a smaller type. If so, return
5700 the new type. If not, return the original type. */
5703 make_packable_type (tree type
, bool in_record
)
5705 unsigned HOST_WIDE_INT size
= tree_low_cst (TYPE_SIZE (type
), 1);
5706 unsigned HOST_WIDE_INT new_size
;
5707 tree new_type
, old_field
, field_list
= NULL_TREE
;
5709 /* No point in doing anything if the size is zero. */
5713 new_type
= make_node (TREE_CODE (type
));
5715 /* Copy the name and flags from the old type to that of the new.
5716 Note that we rely on the pointer equality created here for
5717 TYPE_NAME to look through conversions in various places. */
5718 TYPE_NAME (new_type
) = TYPE_NAME (type
);
5719 TYPE_JUSTIFIED_MODULAR_P (new_type
) = TYPE_JUSTIFIED_MODULAR_P (type
);
5720 TYPE_CONTAINS_TEMPLATE_P (new_type
) = TYPE_CONTAINS_TEMPLATE_P (type
);
5721 if (TREE_CODE (type
) == RECORD_TYPE
)
5722 TYPE_IS_PADDING_P (new_type
) = TYPE_IS_PADDING_P (type
);
5724 /* If we are in a record and have a small size, set the alignment to
5725 try for an integral mode. Otherwise set it to try for a smaller
5726 type with BLKmode. */
5727 if (in_record
&& size
<= MAX_FIXED_MODE_SIZE
)
5729 TYPE_ALIGN (new_type
) = ceil_alignment (size
);
5730 new_size
= round_up_to_align (size
, TYPE_ALIGN (new_type
));
5734 unsigned HOST_WIDE_INT align
;
5736 /* Do not try to shrink the size if the RM size is not constant. */
5737 if (TYPE_CONTAINS_TEMPLATE_P (type
)
5738 || !host_integerp (TYPE_ADA_SIZE (type
), 1))
5741 /* Round the RM size up to a unit boundary to get the minimal size
5742 for a BLKmode record. Give up if it's already the size. */
5743 new_size
= TREE_INT_CST_LOW (TYPE_ADA_SIZE (type
));
5744 new_size
= round_up_to_align (new_size
, BITS_PER_UNIT
);
5745 if (new_size
== size
)
5748 align
= new_size
& -new_size
;
5749 TYPE_ALIGN (new_type
) = MIN (TYPE_ALIGN (type
), align
);
5752 TYPE_USER_ALIGN (new_type
) = 1;
5754 /* Now copy the fields, keeping the position and size as we don't want
5755 to change the layout by propagating the packedness downwards. */
5756 for (old_field
= TYPE_FIELDS (type
); old_field
;
5757 old_field
= TREE_CHAIN (old_field
))
5759 tree new_field_type
= TREE_TYPE (old_field
);
5760 tree new_field
, new_size
;
5762 if ((TREE_CODE (new_field_type
) == RECORD_TYPE
5763 || TREE_CODE (new_field_type
) == UNION_TYPE
5764 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
5765 && !TYPE_IS_FAT_POINTER_P (new_field_type
)
5766 && host_integerp (TYPE_SIZE (new_field_type
), 1))
5767 new_field_type
= make_packable_type (new_field_type
, true);
5769 /* However, for the last field in a not already packed record type
5770 that is of an aggregate type, we need to use the RM_Size in the
5771 packable version of the record type, see finish_record_type. */
5772 if (!TREE_CHAIN (old_field
)
5773 && !TYPE_PACKED (type
)
5774 && (TREE_CODE (new_field_type
) == RECORD_TYPE
5775 || TREE_CODE (new_field_type
) == UNION_TYPE
5776 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
5777 && !TYPE_IS_FAT_POINTER_P (new_field_type
)
5778 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type
)
5779 && TYPE_ADA_SIZE (new_field_type
))
5780 new_size
= TYPE_ADA_SIZE (new_field_type
);
5782 new_size
= DECL_SIZE (old_field
);
5784 new_field
= create_field_decl (DECL_NAME (old_field
), new_field_type
,
5785 new_type
, TYPE_PACKED (type
), new_size
,
5786 bit_position (old_field
),
5787 !DECL_NONADDRESSABLE_P (old_field
));
5789 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
5790 SET_DECL_ORIGINAL_FIELD
5791 (new_field
, (DECL_ORIGINAL_FIELD (old_field
)
5792 ? DECL_ORIGINAL_FIELD (old_field
) : old_field
));
5794 if (TREE_CODE (new_type
) == QUAL_UNION_TYPE
)
5795 DECL_QUALIFIER (new_field
) = DECL_QUALIFIER (old_field
);
5797 TREE_CHAIN (new_field
) = field_list
;
5798 field_list
= new_field
;
5801 finish_record_type (new_type
, nreverse (field_list
), 2, true);
5802 relate_alias_sets (new_type
, type
, ALIAS_SET_COPY
);
5804 /* If this is a padding record, we never want to make the size smaller
5805 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5806 if ((TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5807 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
5809 TYPE_SIZE (new_type
) = TYPE_SIZE (type
);
5810 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (type
);
5814 TYPE_SIZE (new_type
) = bitsize_int (new_size
);
5815 TYPE_SIZE_UNIT (new_type
)
5816 = size_int ((new_size
+ BITS_PER_UNIT
- 1) / BITS_PER_UNIT
);
5819 if (!TYPE_CONTAINS_TEMPLATE_P (type
))
5820 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (type
));
5822 compute_record_mode (new_type
);
5824 /* Try harder to get a packable type if necessary, for example
5825 in case the record itself contains a BLKmode field. */
5826 if (in_record
&& TYPE_MODE (new_type
) == BLKmode
)
5827 SET_TYPE_MODE (new_type
,
5828 mode_for_size_tree (TYPE_SIZE (new_type
), MODE_INT
, 1));
5830 /* If neither the mode nor the size has shrunk, return the old type. */
5831 if (TYPE_MODE (new_type
) == BLKmode
&& new_size
>= size
)
5837 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5838 if needed. We have already verified that SIZE and TYPE are large enough.
5840 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5843 IS_USER_TYPE is true if we must complete the original type.
5845 DEFINITION is true if this type is being defined.
5847 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
5848 to SIZE too; otherwise, it's set to the RM_Size of the original type. */
5851 maybe_pad_type (tree type
, tree size
, unsigned int align
,
5852 Entity_Id gnat_entity
, const char *name_trailer
,
5853 bool is_user_type
, bool definition
, bool same_rm_size
)
5855 tree orig_rm_size
= same_rm_size
? NULL_TREE
: rm_size (type
);
5856 tree orig_size
= TYPE_SIZE (type
);
5857 unsigned int orig_align
= align
;
5860 /* If TYPE is a padded type, see if it agrees with any size and alignment
5861 we were given. If so, return the original type. Otherwise, strip
5862 off the padding, since we will either be returning the inner type
5863 or repadding it. If no size or alignment is specified, use that of
5864 the original padded type. */
5865 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5868 || operand_equal_p (round_up (size
,
5869 MAX (align
, TYPE_ALIGN (type
))),
5870 round_up (TYPE_SIZE (type
),
5871 MAX (align
, TYPE_ALIGN (type
))),
5873 && (align
== 0 || align
== TYPE_ALIGN (type
)))
5877 size
= TYPE_SIZE (type
);
5879 align
= TYPE_ALIGN (type
);
5881 type
= TREE_TYPE (TYPE_FIELDS (type
));
5882 orig_size
= TYPE_SIZE (type
);
5885 /* If the size is either not being changed or is being made smaller (which
5886 is not done here (and is only valid for bitfields anyway), show the size
5887 isn't changing. Likewise, clear the alignment if it isn't being
5888 changed. Then return if we aren't doing anything. */
5890 && (operand_equal_p (size
, orig_size
, 0)
5891 || (TREE_CODE (orig_size
) == INTEGER_CST
5892 && tree_int_cst_lt (size
, orig_size
))))
5895 if (align
== TYPE_ALIGN (type
))
5898 if (align
== 0 && !size
)
5901 /* If requested, complete the original type and give it a name. */
5903 create_type_decl (get_entity_name (gnat_entity
), type
,
5904 NULL
, !Comes_From_Source (gnat_entity
),
5906 && TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
5907 && DECL_IGNORED_P (TYPE_NAME (type
))),
5910 /* We used to modify the record in place in some cases, but that could
5911 generate incorrect debugging information. So make a new record
5913 record
= make_node (RECORD_TYPE
);
5914 TYPE_IS_PADDING_P (record
) = 1;
5916 if (Present (gnat_entity
))
5917 TYPE_NAME (record
) = create_concat_name (gnat_entity
, name_trailer
);
5919 TYPE_VOLATILE (record
)
5920 = Present (gnat_entity
) && Treat_As_Volatile (gnat_entity
);
5922 TYPE_ALIGN (record
) = align
;
5924 TYPE_USER_ALIGN (record
) = align
;
5926 TYPE_SIZE (record
) = size
? size
: orig_size
;
5927 TYPE_SIZE_UNIT (record
)
5928 = convert (sizetype
,
5929 size_binop (CEIL_DIV_EXPR
, TYPE_SIZE (record
),
5930 bitsize_unit_node
));
5932 /* If we are changing the alignment and the input type is a record with
5933 BLKmode and a small constant size, try to make a form that has an
5934 integral mode. This might allow the padding record to also have an
5935 integral mode, which will be much more efficient. There is no point
5936 in doing so if a size is specified unless it is also a small constant
5937 size and it is incorrect to do so if we cannot guarantee that the mode
5938 will be naturally aligned since the field must always be addressable.
5940 ??? This might not always be a win when done for a stand-alone object:
5941 since the nominal and the effective type of the object will now have
5942 different modes, a VIEW_CONVERT_EXPR will be required for converting
5943 between them and it might be hard to overcome afterwards, including
5944 at the RTL level when the stand-alone object is accessed as a whole. */
5946 && TREE_CODE (type
) == RECORD_TYPE
5947 && TYPE_MODE (type
) == BLKmode
5948 && TREE_CODE (orig_size
) == INTEGER_CST
5949 && !TREE_OVERFLOW (orig_size
)
5950 && compare_tree_int (orig_size
, MAX_FIXED_MODE_SIZE
) <= 0
5952 || (TREE_CODE (size
) == INTEGER_CST
5953 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) <= 0)))
5955 tree packable_type
= make_packable_type (type
, true);
5956 if (TYPE_MODE (packable_type
) != BLKmode
5957 && align
>= TYPE_ALIGN (packable_type
))
5958 type
= packable_type
;
5961 /* Now create the field with the original size. */
5962 field
= create_field_decl (get_identifier ("F"), type
, record
, 0,
5963 orig_size
, bitsize_zero_node
, 1);
5964 DECL_INTERNAL_P (field
) = 1;
5966 /* Do not finalize it until after the auxiliary record is built. */
5967 finish_record_type (record
, field
, 1, true);
5969 /* Set the same size for its RM_size if requested; otherwise reuse
5970 the RM_size of the original type. */
5971 SET_TYPE_ADA_SIZE (record
, same_rm_size
? size
: orig_rm_size
);
5973 /* Unless debugging information isn't being written for the input type,
5974 write a record that shows what we are a subtype of and also make a
5975 variable that indicates our size, if still variable. */
5976 if (TYPE_NAME (record
)
5977 && AGGREGATE_TYPE_P (type
)
5978 && TREE_CODE (orig_size
) != INTEGER_CST
5979 && !(TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
5980 && DECL_IGNORED_P (TYPE_NAME (type
))))
5982 tree marker
= make_node (RECORD_TYPE
);
5983 tree name
= TYPE_NAME (record
);
5984 tree orig_name
= TYPE_NAME (type
);
5986 if (TREE_CODE (name
) == TYPE_DECL
)
5987 name
= DECL_NAME (name
);
5989 if (TREE_CODE (orig_name
) == TYPE_DECL
)
5990 orig_name
= DECL_NAME (orig_name
);
5992 TYPE_NAME (marker
) = concat_id_with_name (name
, "XVS");
5993 finish_record_type (marker
,
5994 create_field_decl (orig_name
, integer_type_node
,
5995 marker
, 0, NULL_TREE
, NULL_TREE
,
5999 add_parallel_type (TYPE_STUB_DECL (record
), marker
);
6001 if (size
&& TREE_CODE (size
) != INTEGER_CST
&& definition
)
6002 create_var_decl (concat_id_with_name (name
, "XVZ"), NULL_TREE
,
6003 sizetype
, TYPE_SIZE_UNIT (record
), false, false,
6004 false, false, NULL
, gnat_entity
);
6007 rest_of_record_type_compilation (record
);
6009 /* If the size was widened explicitly, maybe give a warning. Take the
6010 original size as the maximum size of the input if there was an
6011 unconstrained record involved and round it up to the specified alignment,
6012 if one was specified. */
6013 if (CONTAINS_PLACEHOLDER_P (orig_size
))
6014 orig_size
= max_size (orig_size
, true);
6017 orig_size
= round_up (orig_size
, align
);
6019 if (size
&& Present (gnat_entity
)
6020 && !operand_equal_p (size
, orig_size
, 0)
6021 && !(TREE_CODE (size
) == INTEGER_CST
6022 && TREE_CODE (orig_size
) == INTEGER_CST
6023 && tree_int_cst_lt (size
, orig_size
)))
6025 Node_Id gnat_error_node
= Empty
;
6027 if (Is_Packed_Array_Type (gnat_entity
))
6028 gnat_entity
= Original_Array_Type (gnat_entity
);
6030 if ((Ekind (gnat_entity
) == E_Component
6031 || Ekind (gnat_entity
) == E_Discriminant
)
6032 && Present (Component_Clause (gnat_entity
)))
6033 gnat_error_node
= Last_Bit (Component_Clause (gnat_entity
));
6034 else if (Present (Size_Clause (gnat_entity
)))
6035 gnat_error_node
= Expression (Size_Clause (gnat_entity
));
6037 /* Generate message only for entities that come from source, since
6038 if we have an entity created by expansion, the message will be
6039 generated for some other corresponding source entity. */
6040 if (Comes_From_Source (gnat_entity
) && Present (gnat_error_node
))
6041 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node
,
6043 size_diffop (size
, orig_size
));
6045 else if (*name_trailer
== 'C' && !Is_Internal (gnat_entity
))
6046 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6047 gnat_entity
, gnat_entity
,
6048 size_diffop (size
, orig_size
));
6054 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6055 the value passed against the list of choices. */
6058 choices_to_gnu (tree operand
, Node_Id choices
)
6062 tree result
= integer_zero_node
;
6063 tree this_test
, low
= 0, high
= 0, single
= 0;
6065 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
6067 switch (Nkind (choice
))
6070 low
= gnat_to_gnu (Low_Bound (choice
));
6071 high
= gnat_to_gnu (High_Bound (choice
));
6073 /* There's no good type to use here, so we might as well use
6074 integer_type_node. */
6076 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
6077 build_binary_op (GE_EXPR
, integer_type_node
,
6079 build_binary_op (LE_EXPR
, integer_type_node
,
6084 case N_Subtype_Indication
:
6085 gnat_temp
= Range_Expression (Constraint (choice
));
6086 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
6087 high
= gnat_to_gnu (High_Bound (gnat_temp
));
6090 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
6091 build_binary_op (GE_EXPR
, integer_type_node
,
6093 build_binary_op (LE_EXPR
, integer_type_node
,
6098 case N_Expanded_Name
:
6099 /* This represents either a subtype range, an enumeration
6100 literal, or a constant Ekind says which. If an enumeration
6101 literal or constant, fall through to the next case. */
6102 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
6103 && Ekind (Entity (choice
)) != E_Constant
)
6105 tree type
= gnat_to_gnu_type (Entity (choice
));
6107 low
= TYPE_MIN_VALUE (type
);
6108 high
= TYPE_MAX_VALUE (type
);
6111 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
6112 build_binary_op (GE_EXPR
, integer_type_node
,
6114 build_binary_op (LE_EXPR
, integer_type_node
,
6119 /* ... fall through ... */
6121 case N_Character_Literal
:
6122 case N_Integer_Literal
:
6123 single
= gnat_to_gnu (choice
);
6124 this_test
= build_binary_op (EQ_EXPR
, integer_type_node
, operand
,
6128 case N_Others_Choice
:
6129 this_test
= integer_one_node
;
6136 result
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
6143 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6144 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6147 adjust_packed (tree field_type
, tree record_type
, int packed
)
6149 /* If the field contains an item of variable size, we cannot pack it
6150 because we cannot create temporaries of non-fixed size in case
6151 we need to take the address of the field. See addressable_p and
6152 the notes on the addressability issues for further details. */
6153 if (is_variable_size (field_type
))
6156 /* If the alignment of the record is specified and the field type
6157 is over-aligned, request Storage_Unit alignment for the field. */
6160 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
6169 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6170 placed in GNU_RECORD_TYPE.
6172 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6173 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6174 record has a specified alignment.
6176 DEFINITION is true if this field is for a record being defined. */
6179 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
6182 tree gnu_field_id
= get_entity_name (gnat_field
);
6183 tree gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
6184 tree gnu_field
, gnu_size
, gnu_pos
;
6185 bool needs_strict_alignment
6186 = (Is_Aliased (gnat_field
) || Strict_Alignment (Etype (gnat_field
))
6187 || Treat_As_Volatile (gnat_field
));
6189 /* If this field requires strict alignment, we cannot pack it because
6190 it would very likely be under-aligned in the record. */
6191 if (needs_strict_alignment
)
6194 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
6196 /* If a size is specified, use it. Otherwise, if the record type is packed,
6197 use the official RM size. See "Handling of Type'Size Values" in Einfo
6198 for further details. */
6199 if (Known_Static_Esize (gnat_field
))
6200 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6201 gnat_field
, FIELD_DECL
, false, true);
6202 else if (packed
== 1)
6203 gnu_size
= validate_size (RM_Size (Etype (gnat_field
)), gnu_field_type
,
6204 gnat_field
, FIELD_DECL
, false, true);
6206 gnu_size
= NULL_TREE
;
6208 /* If we have a specified size that's smaller than that of the field type,
6209 or a position is specified, and the field type is a record, see if we can
6210 get either an integral mode form of the type or a smaller form. If we
6211 can, show a size was specified for the field if there wasn't one already,
6212 so we know to make this a bitfield and avoid making things wider.
6214 Doing this is first useful if the record is packed because we may then
6215 place the field at a non-byte-aligned position and so achieve tighter
6218 This is in addition *required* if the field shares a byte with another
6219 field and the front-end lets the back-end handle the references, because
6220 GCC does not handle BLKmode bitfields properly.
6222 We avoid the transformation if it is not required or potentially useful,
6223 as it might entail an increase of the field's alignment and have ripple
6224 effects on the outer record type. A typical case is a field known to be
6225 byte aligned and not to share a byte with another field.
6227 Besides, we don't even look the possibility of a transformation in cases
6228 known to be in error already, for instance when an invalid size results
6229 from a component clause. */
6231 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6232 && !TYPE_IS_FAT_POINTER_P (gnu_field_type
)
6233 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
6236 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
6237 || Present (Component_Clause (gnat_field
))))))
6239 /* See what the alternate type and size would be. */
6240 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
6242 bool has_byte_aligned_clause
6243 = Present (Component_Clause (gnat_field
))
6244 && (UI_To_Int (Component_Bit_Offset (gnat_field
))
6245 % BITS_PER_UNIT
== 0);
6247 /* Compute whether we should avoid the substitution. */
6249 /* There is no point substituting if there is no change... */
6250 = (gnu_packable_type
== gnu_field_type
)
6251 /* ... nor when the field is known to be byte aligned and not to
6252 share a byte with another field. */
6253 || (has_byte_aligned_clause
6254 && value_factor_p (gnu_size
, BITS_PER_UNIT
))
6255 /* The size of an aliased field must be an exact multiple of the
6256 type's alignment, which the substitution might increase. Reject
6257 substitutions that would so invalidate a component clause when the
6258 specified position is byte aligned, as the change would have no
6259 real benefit from the packing standpoint anyway. */
6260 || (Is_Aliased (gnat_field
)
6261 && has_byte_aligned_clause
6262 && !value_factor_p (gnu_size
, TYPE_ALIGN (gnu_packable_type
)));
6264 /* Substitute unless told otherwise. */
6267 gnu_field_type
= gnu_packable_type
;
6270 gnu_size
= rm_size (gnu_field_type
);
6274 /* If we are packing the record and the field is BLKmode, round the
6275 size up to a byte boundary. */
6276 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
6277 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
6279 if (Present (Component_Clause (gnat_field
)))
6281 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
6282 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
6283 gnat_field
, FIELD_DECL
, false, true);
6285 /* Ensure the position does not overlap with the parent subtype,
6287 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field
)))))
6290 = gnat_to_gnu_type (Parent_Subtype
6291 (Underlying_Type (Scope (gnat_field
))));
6293 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
6294 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
6297 ("offset of& must be beyond parent{, minimum allowed is ^}",
6298 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6299 TYPE_SIZE_UNIT (gnu_parent
));
6303 /* If this field needs strict alignment, ensure the record is
6304 sufficiently aligned and that that position and size are
6305 consistent with the alignment. */
6306 if (needs_strict_alignment
)
6308 TYPE_ALIGN (gnu_record_type
)
6309 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
6312 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
6314 if (Is_Atomic (gnat_field
) || Is_Atomic (Etype (gnat_field
)))
6316 ("atomic field& must be natural size of type{ (^)}",
6317 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6318 TYPE_SIZE (gnu_field_type
));
6320 else if (Is_Aliased (gnat_field
))
6322 ("size of aliased field& must be ^ bits",
6323 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6324 TYPE_SIZE (gnu_field_type
));
6326 else if (Strict_Alignment (Etype (gnat_field
)))
6328 ("size of & with aliased or tagged components not ^ bits",
6329 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6330 TYPE_SIZE (gnu_field_type
));
6332 gnu_size
= NULL_TREE
;
6335 if (!integer_zerop (size_binop
6336 (TRUNC_MOD_EXPR
, gnu_pos
,
6337 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
6339 if (Is_Aliased (gnat_field
))
6341 ("position of aliased field& must be multiple of ^ bits",
6342 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6343 TYPE_ALIGN (gnu_field_type
));
6345 else if (Treat_As_Volatile (gnat_field
))
6347 ("position of volatile field& must be multiple of ^ bits",
6348 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6349 TYPE_ALIGN (gnu_field_type
));
6351 else if (Strict_Alignment (Etype (gnat_field
)))
6353 ("position of & with aliased or tagged components not multiple of ^ bits",
6354 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6355 TYPE_ALIGN (gnu_field_type
));
6360 gnu_pos
= NULL_TREE
;
6364 if (Is_Atomic (gnat_field
))
6365 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
6368 /* If the record has rep clauses and this is the tag field, make a rep
6369 clause for it as well. */
6370 else if (Has_Specified_Layout (Scope (gnat_field
))
6371 && Chars (gnat_field
) == Name_uTag
)
6373 gnu_pos
= bitsize_zero_node
;
6374 gnu_size
= TYPE_SIZE (gnu_field_type
);
6378 gnu_pos
= NULL_TREE
;
6380 /* We need to make the size the maximum for the type if it is
6381 self-referential and an unconstrained type. In that case, we can't
6382 pack the field since we can't make a copy to align it. */
6383 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6385 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
6386 && !Is_Constrained (Underlying_Type (Etype (gnat_field
))))
6388 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
6392 /* If a size is specified, adjust the field's type to it. */
6395 /* If the field's type is justified modular, we would need to remove
6396 the wrapper to (better) meet the layout requirements. However we
6397 can do so only if the field is not aliased to preserve the unique
6398 layout and if the prescribed size is not greater than that of the
6399 packed array to preserve the justification. */
6400 if (!needs_strict_alignment
6401 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6402 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
6403 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
6405 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6408 = make_type_from_size (gnu_field_type
, gnu_size
,
6409 Has_Biased_Representation (gnat_field
));
6410 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
6411 "PAD", false, definition
, true);
6414 /* Otherwise (or if there was an error), don't specify a position. */
6416 gnu_pos
= NULL_TREE
;
6418 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
6419 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
6421 /* Now create the decl for the field. */
6422 gnu_field
= create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
6423 packed
, gnu_size
, gnu_pos
,
6424 Is_Aliased (gnat_field
));
6425 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
6426 TREE_THIS_VOLATILE (gnu_field
) = Treat_As_Volatile (gnat_field
);
6428 if (Ekind (gnat_field
) == E_Discriminant
)
6429 DECL_DISCRIMINANT_NUMBER (gnu_field
)
6430 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
6435 /* Return true if TYPE is a type with variable size, a padding type with a
6436 field of variable size or is a record that has a field such a field. */
6439 is_variable_size (tree type
)
6443 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
6446 if (TREE_CODE (type
) == RECORD_TYPE
6447 && TYPE_IS_PADDING_P (type
)
6448 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
6451 if (TREE_CODE (type
) != RECORD_TYPE
6452 && TREE_CODE (type
) != UNION_TYPE
6453 && TREE_CODE (type
) != QUAL_UNION_TYPE
)
6456 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
6457 if (is_variable_size (TREE_TYPE (field
)))
6463 /* qsort comparer for the bit positions of two record components. */
6466 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
6468 const_tree
const field1
= * (const_tree
const *) rt1
;
6469 const_tree
const field2
= * (const_tree
const *) rt2
;
6471 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
6473 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
6476 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6477 of GCC trees for fields that are in the record and have already been
6478 processed. When called from gnat_to_gnu_entity during the processing of a
6479 record type definition, the GCC nodes for the discriminants will be on
6480 the chain. The other calls to this function are recursive calls from
6481 itself for the Component_List of a variant and the chain is empty.
6483 PACKED is 1 if this is for a packed record, -1 if this is for a record
6484 with Component_Alignment of Storage_Unit, -2 if this is for a record
6485 with a specified alignment.
6487 DEFINITION is true if we are defining this record.
6489 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6490 with a rep clause is to be added. If it is nonzero, that is all that
6491 should be done with such fields.
6493 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6494 laying out the record. This means the alignment only serves to force fields
6495 to be bitfields, but not require the record to be that aligned. This is
6498 ALL_REP, if true, means a rep clause was found for all the fields. This
6499 simplifies the logic since we know we're not in the mixed case.
6501 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6502 modified afterwards so it will not be sent to the back-end for finalization.
6504 UNCHECKED_UNION, if true, means that we are building a type for a record
6505 with a Pragma Unchecked_Union.
6507 The processing of the component list fills in the chain with all of the
6508 fields of the record and then the record type is finished. */
6511 components_to_record (tree gnu_record_type
, Node_Id component_list
,
6512 tree gnu_field_list
, int packed
, bool definition
,
6513 tree
*p_gnu_rep_list
, bool cancel_alignment
,
6514 bool all_rep
, bool do_not_finalize
, bool unchecked_union
)
6516 Node_Id component_decl
;
6517 Entity_Id gnat_field
;
6518 Node_Id variant_part
;
6519 tree gnu_our_rep_list
= NULL_TREE
;
6520 tree gnu_field
, gnu_last
;
6521 bool layout_with_rep
= false;
6522 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
6524 /* For each variable within each component declaration create a GCC field
6525 and add it to the list, skipping any pragmas in the list. */
6526 if (Present (Component_Items (component_list
)))
6527 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
6528 Present (component_decl
);
6529 component_decl
= Next_Non_Pragma (component_decl
))
6531 gnat_field
= Defining_Entity (component_decl
);
6533 if (Chars (gnat_field
) == Name_uParent
)
6534 gnu_field
= tree_last (TYPE_FIELDS (gnu_record_type
));
6537 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
,
6538 packed
, definition
);
6540 /* If this is the _Tag field, put it before any discriminants,
6541 instead of after them as is the case for all other fields. */
6542 if (Chars (gnat_field
) == Name_uTag
)
6543 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6546 TREE_CHAIN (gnu_field
) = gnu_field_list
;
6547 gnu_field_list
= gnu_field
;
6551 save_gnu_tree (gnat_field
, gnu_field
, false);
6554 /* At the end of the component list there may be a variant part. */
6555 variant_part
= Variant_Part (component_list
);
6557 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6558 mutually exclusive and should go in the same memory. To do this we need
6559 to treat each variant as a record whose elements are created from the
6560 component list for the variant. So here we create the records from the
6561 lists for the variants and put them all into the QUAL_UNION_TYPE.
6562 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6563 use GNU_RECORD_TYPE if there are no fields so far. */
6564 if (Present (variant_part
))
6566 tree gnu_discriminant
= gnat_to_gnu (Name (variant_part
));
6568 tree gnu_name
= TYPE_NAME (gnu_record_type
);
6570 = concat_id_with_name (get_identifier (Get_Name_String
6571 (Chars (Name (variant_part
)))),
6573 tree gnu_union_type
;
6574 tree gnu_union_name
;
6575 tree gnu_union_field
;
6576 tree gnu_variant_list
= NULL_TREE
;
6578 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
6579 gnu_name
= DECL_NAME (gnu_name
);
6581 gnu_union_name
= concat_id_with_name (gnu_name
,
6582 IDENTIFIER_POINTER (gnu_var_name
));
6584 /* Reuse an enclosing union if all fields are in the variant part
6585 and there is no representation clause on the record, to match
6586 the layout of C unions. There is an associated check below. */
6588 && TREE_CODE (gnu_record_type
) == UNION_TYPE
6589 && !TYPE_PACKED (gnu_record_type
))
6590 gnu_union_type
= gnu_record_type
;
6594 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
6596 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
6597 TYPE_ALIGN (gnu_union_type
) = 0;
6598 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
6601 for (variant
= First_Non_Pragma (Variants (variant_part
));
6603 variant
= Next_Non_Pragma (variant
))
6605 tree gnu_variant_type
= make_node (RECORD_TYPE
);
6606 tree gnu_inner_name
;
6609 Get_Variant_Encoding (variant
);
6610 gnu_inner_name
= get_identifier (Name_Buffer
);
6611 TYPE_NAME (gnu_variant_type
)
6612 = concat_id_with_name (gnu_union_name
,
6613 IDENTIFIER_POINTER (gnu_inner_name
));
6615 /* Set the alignment of the inner type in case we need to make
6616 inner objects into bitfields, but then clear it out
6617 so the record actually gets only the alignment required. */
6618 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
6619 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
6621 /* Similarly, if the outer record has a size specified and all fields
6622 have record rep clauses, we can propagate the size into the
6624 if (all_rep_and_size
)
6626 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
6627 TYPE_SIZE_UNIT (gnu_variant_type
)
6628 = TYPE_SIZE_UNIT (gnu_record_type
);
6631 /* Create the record type for the variant. Note that we defer
6632 finalizing it until after we are sure to actually use it. */
6633 components_to_record (gnu_variant_type
, Component_List (variant
),
6634 NULL_TREE
, packed
, definition
,
6635 &gnu_our_rep_list
, !all_rep_and_size
, all_rep
,
6636 true, unchecked_union
);
6638 gnu_qual
= choices_to_gnu (gnu_discriminant
,
6639 Discrete_Choices (variant
));
6641 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
6643 /* If this is an Unchecked_Union and we have exactly one field,
6644 use this field directly to match the layout of C unions. */
6646 && TYPE_FIELDS (gnu_variant_type
)
6647 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type
)))
6648 gnu_field
= TYPE_FIELDS (gnu_variant_type
);
6651 /* Deal with packedness like in gnat_to_gnu_field. */
6653 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
6655 /* Finalize the record type now. We used to throw away
6656 empty records but we no longer do that because we need
6657 them to generate complete debug info for the variant;
6658 otherwise, the union type definition will be lacking
6659 the fields associated with these empty variants. */
6660 rest_of_record_type_compilation (gnu_variant_type
);
6662 gnu_field
= create_field_decl (gnu_inner_name
, gnu_variant_type
,
6663 gnu_union_type
, field_packed
,
6665 ? TYPE_SIZE (gnu_variant_type
)
6668 ? bitsize_zero_node
: 0),
6671 DECL_INTERNAL_P (gnu_field
) = 1;
6673 if (!unchecked_union
)
6674 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
6677 TREE_CHAIN (gnu_field
) = gnu_variant_list
;
6678 gnu_variant_list
= gnu_field
;
6681 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6682 if (gnu_variant_list
)
6684 int union_field_packed
;
6686 if (all_rep_and_size
)
6688 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
6689 TYPE_SIZE_UNIT (gnu_union_type
)
6690 = TYPE_SIZE_UNIT (gnu_record_type
);
6693 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
6694 all_rep_and_size
? 1 : 0, false);
6696 /* If GNU_UNION_TYPE is our record type, it means we must have an
6697 Unchecked_Union with no fields. Verify that and, if so, just
6699 if (gnu_union_type
== gnu_record_type
)
6701 gcc_assert (unchecked_union
6703 && !gnu_our_rep_list
);
6707 /* Deal with packedness like in gnat_to_gnu_field. */
6709 = adjust_packed (gnu_union_type
, gnu_record_type
, packed
);
6712 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
6714 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
6715 all_rep
? bitsize_zero_node
: 0, 0);
6717 DECL_INTERNAL_P (gnu_union_field
) = 1;
6718 TREE_CHAIN (gnu_union_field
) = gnu_field_list
;
6719 gnu_field_list
= gnu_union_field
;
6723 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6724 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6725 in a separate pass since we want to handle the discriminants but can't
6726 play with them until we've used them in debugging data above.
6728 ??? Note: if we then reorder them, debugging information will be wrong,
6729 but there's nothing that can be done about this at the moment. */
6730 for (gnu_field
= gnu_field_list
, gnu_last
= NULL_TREE
; gnu_field
; )
6732 if (DECL_FIELD_OFFSET (gnu_field
))
6734 tree gnu_next
= TREE_CHAIN (gnu_field
);
6737 gnu_field_list
= gnu_next
;
6739 TREE_CHAIN (gnu_last
) = gnu_next
;
6741 TREE_CHAIN (gnu_field
) = gnu_our_rep_list
;
6742 gnu_our_rep_list
= gnu_field
;
6743 gnu_field
= gnu_next
;
6747 gnu_last
= gnu_field
;
6748 gnu_field
= TREE_CHAIN (gnu_field
);
6752 /* If we have any items in our rep'ed field list, it is not the case that all
6753 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6754 set it and ignore the items. */
6755 if (gnu_our_rep_list
&& p_gnu_rep_list
&& !all_rep
)
6756 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_our_rep_list
);
6757 else if (gnu_our_rep_list
)
6759 /* Otherwise, sort the fields by bit position and put them into their
6760 own record if we have any fields without rep clauses. */
6762 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
6763 int len
= list_length (gnu_our_rep_list
);
6764 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * len
);
6767 for (i
= 0, gnu_field
= gnu_our_rep_list
; gnu_field
;
6768 gnu_field
= TREE_CHAIN (gnu_field
), i
++)
6769 gnu_arr
[i
] = gnu_field
;
6771 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
6773 /* Put the fields in the list in order of increasing position, which
6774 means we start from the end. */
6775 gnu_our_rep_list
= NULL_TREE
;
6776 for (i
= len
- 1; i
>= 0; i
--)
6778 TREE_CHAIN (gnu_arr
[i
]) = gnu_our_rep_list
;
6779 gnu_our_rep_list
= gnu_arr
[i
];
6780 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
6785 finish_record_type (gnu_rep_type
, gnu_our_rep_list
, 1, false);
6786 gnu_field
= create_field_decl (get_identifier ("REP"), gnu_rep_type
,
6787 gnu_record_type
, 0, 0, 0, 1);
6788 DECL_INTERNAL_P (gnu_field
) = 1;
6789 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6793 layout_with_rep
= true;
6794 gnu_field_list
= nreverse (gnu_our_rep_list
);
6798 if (cancel_alignment
)
6799 TYPE_ALIGN (gnu_record_type
) = 0;
6801 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
6802 layout_with_rep
? 1 : 0, do_not_finalize
);
6805 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6806 placed into an Esize, Component_Bit_Offset, or Component_Size value
6807 in the GNAT tree. */
6810 annotate_value (tree gnu_size
)
6812 int len
= TREE_CODE_LENGTH (TREE_CODE (gnu_size
));
6814 Node_Ref_Or_Val ops
[3], ret
;
6817 struct tree_int_map
**h
= NULL
;
6819 /* See if we've already saved the value for this node. */
6820 if (EXPR_P (gnu_size
))
6822 struct tree_int_map in
;
6823 if (!annotate_value_cache
)
6824 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
6825 tree_int_map_eq
, 0);
6826 in
.base
.from
= gnu_size
;
6827 h
= (struct tree_int_map
**)
6828 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
6831 return (Node_Ref_Or_Val
) (*h
)->to
;
6834 /* If we do not return inside this switch, TCODE will be set to the
6835 code to use for a Create_Node operand and LEN (set above) will be
6836 the number of recursive calls for us to make. */
6838 switch (TREE_CODE (gnu_size
))
6841 if (TREE_OVERFLOW (gnu_size
))
6844 /* This may have come from a conversion from some smaller type,
6845 so ensure this is in bitsizetype. */
6846 gnu_size
= convert (bitsizetype
, gnu_size
);
6848 /* For negative values, use NEGATE_EXPR of the supplied value. */
6849 if (tree_int_cst_sgn (gnu_size
) < 0)
6851 /* The ridiculous code below is to handle the case of the largest
6852 negative integer. */
6853 tree negative_size
= size_diffop (bitsize_zero_node
, gnu_size
);
6854 bool adjust
= false;
6857 if (TREE_OVERFLOW (negative_size
))
6860 = size_binop (MINUS_EXPR
, bitsize_zero_node
,
6861 size_binop (PLUS_EXPR
, gnu_size
,
6866 temp
= build1 (NEGATE_EXPR
, bitsizetype
, negative_size
);
6868 temp
= build2 (MINUS_EXPR
, bitsizetype
, temp
, bitsize_one_node
);
6870 return annotate_value (temp
);
6873 if (!host_integerp (gnu_size
, 1))
6876 size
= tree_low_cst (gnu_size
, 1);
6878 /* This peculiar test is to make sure that the size fits in an int
6879 on machines where HOST_WIDE_INT is not "int". */
6880 if (tree_low_cst (gnu_size
, 1) == size
)
6881 return UI_From_Int (size
);
6886 /* The only case we handle here is a simple discriminant reference. */
6887 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
6888 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
6889 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
6890 return Create_Node (Discrim_Val
,
6891 annotate_value (DECL_DISCRIMINANT_NUMBER
6892 (TREE_OPERAND (gnu_size
, 1))),
6897 CASE_CONVERT
: case NON_LVALUE_EXPR
:
6898 return annotate_value (TREE_OPERAND (gnu_size
, 0));
6900 /* Now just list the operations we handle. */
6901 case COND_EXPR
: tcode
= Cond_Expr
; break;
6902 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
6903 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
6904 case MULT_EXPR
: tcode
= Mult_Expr
; break;
6905 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
6906 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
6907 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
6908 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
6909 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
6910 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
6911 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
6912 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
6913 case MIN_EXPR
: tcode
= Min_Expr
; break;
6914 case MAX_EXPR
: tcode
= Max_Expr
; break;
6915 case ABS_EXPR
: tcode
= Abs_Expr
; break;
6916 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
6917 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
6918 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
6919 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
6920 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
6921 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
6922 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
6923 case LT_EXPR
: tcode
= Lt_Expr
; break;
6924 case LE_EXPR
: tcode
= Le_Expr
; break;
6925 case GT_EXPR
: tcode
= Gt_Expr
; break;
6926 case GE_EXPR
: tcode
= Ge_Expr
; break;
6927 case EQ_EXPR
: tcode
= Eq_Expr
; break;
6928 case NE_EXPR
: tcode
= Ne_Expr
; break;
6934 /* Now get each of the operands that's relevant for this code. If any
6935 cannot be expressed as a repinfo node, say we can't. */
6936 for (i
= 0; i
< 3; i
++)
6939 for (i
= 0; i
< len
; i
++)
6941 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
6942 if (ops
[i
] == No_Uint
)
6946 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
6948 /* Save the result in the cache. */
6951 *h
= GGC_NEW (struct tree_int_map
);
6952 (*h
)->base
.from
= gnu_size
;
6959 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6960 GCC type, set Component_Bit_Offset and Esize to the position and size
6964 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
6968 Entity_Id gnat_field
;
6970 /* We operate by first making a list of all fields and their positions
6971 (we can get the sizes easily at any time) by a recursive call
6972 and then update all the sizes into the tree. */
6973 gnu_list
= compute_field_positions (gnu_type
, NULL_TREE
,
6974 size_zero_node
, bitsize_zero_node
,
6977 for (gnat_field
= First_Entity (gnat_entity
); Present (gnat_field
);
6978 gnat_field
= Next_Entity (gnat_field
))
6979 if ((Ekind (gnat_field
) == E_Component
6980 || (Ekind (gnat_field
) == E_Discriminant
6981 && !Is_Unchecked_Union (Scope (gnat_field
)))))
6983 tree parent_offset
= bitsize_zero_node
;
6985 gnu_entry
= purpose_member (gnat_to_gnu_field_decl (gnat_field
),
6990 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
6992 /* In this mode the tag and parent components have not been
6993 generated, so we add the appropriate offset to each
6994 component. For a component appearing in the current
6995 extension, the offset is the size of the parent. */
6996 if (Is_Derived_Type (gnat_entity
)
6997 && Original_Record_Component (gnat_field
) == gnat_field
)
6999 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
7002 parent_offset
= bitsize_int (POINTER_SIZE
);
7005 Set_Component_Bit_Offset
7008 (size_binop (PLUS_EXPR
,
7009 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry
)),
7010 TREE_VALUE (TREE_VALUE
7011 (TREE_VALUE (gnu_entry
)))),
7014 Set_Esize (gnat_field
,
7015 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry
))));
7017 else if (Is_Tagged_Type (gnat_entity
)
7018 && Is_Derived_Type (gnat_entity
))
7020 /* If there is no gnu_entry, this is an inherited component whose
7021 position is the same as in the parent type. */
7022 Set_Component_Bit_Offset
7024 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
7025 Set_Esize (gnat_field
,
7026 Esize (Original_Record_Component (gnat_field
)));
7031 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
7032 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
7033 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
7034 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
7035 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
7036 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
7040 compute_field_positions (tree gnu_type
, tree gnu_list
, tree gnu_pos
,
7041 tree gnu_bitpos
, unsigned int offset_align
)
7044 tree gnu_result
= gnu_list
;
7046 for (gnu_field
= TYPE_FIELDS (gnu_type
); gnu_field
;
7047 gnu_field
= TREE_CHAIN (gnu_field
))
7049 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
7050 DECL_FIELD_BIT_OFFSET (gnu_field
));
7051 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
7052 DECL_FIELD_OFFSET (gnu_field
));
7053 unsigned int our_offset_align
7054 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
7057 = tree_cons (gnu_field
,
7058 tree_cons (gnu_our_offset
,
7059 tree_cons (size_int (our_offset_align
),
7060 gnu_our_bitpos
, NULL_TREE
),
7064 if (DECL_INTERNAL_P (gnu_field
))
7066 = compute_field_positions (TREE_TYPE (gnu_field
), gnu_result
,
7067 gnu_our_offset
, gnu_our_bitpos
,
7074 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7075 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
7076 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
7077 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7078 for the size of a field. COMPONENT_P is true if we are being called
7079 to process the Component_Size of GNAT_OBJECT. This is used for error
7080 message handling and to indicate to use the object size of GNU_TYPE.
7081 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7082 it means that a size of zero should be treated as an unspecified size. */
7085 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
7086 enum tree_code kind
, bool component_p
, bool zero_ok
)
7088 Node_Id gnat_error_node
;
7089 tree type_size
, size
;
7091 if (kind
== VAR_DECL
7092 /* If a type needs strict alignment, a component of this type in
7093 a packed record cannot be packed and thus uses the type size. */
7094 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
7095 type_size
= TYPE_SIZE (gnu_type
);
7097 type_size
= rm_size (gnu_type
);
7099 /* Find the node to use for errors. */
7100 if ((Ekind (gnat_object
) == E_Component
7101 || Ekind (gnat_object
) == E_Discriminant
)
7102 && Present (Component_Clause (gnat_object
)))
7103 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
7104 else if (Present (Size_Clause (gnat_object
)))
7105 gnat_error_node
= Expression (Size_Clause (gnat_object
));
7107 gnat_error_node
= gnat_object
;
7109 /* Return 0 if no size was specified, either because Esize was not Present or
7110 the specified size was zero. */
7111 if (No (uint_size
) || uint_size
== No_Uint
)
7114 /* Get the size as a tree. Give an error if a size was specified, but cannot
7115 be represented as in sizetype. */
7116 size
= UI_To_gnu (uint_size
, bitsizetype
);
7117 if (TREE_OVERFLOW (size
))
7119 post_error_ne (component_p
? "component size of & is too large"
7120 : "size of & is too large",
7121 gnat_error_node
, gnat_object
);
7125 /* Ignore a negative size since that corresponds to our back-annotation.
7126 Also ignore a zero size unless a size clause exists. */
7127 else if (tree_int_cst_sgn (size
) < 0 || (integer_zerop (size
) && !zero_ok
))
7130 /* The size of objects is always a multiple of a byte. */
7131 if (kind
== VAR_DECL
7132 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
7135 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7136 gnat_error_node
, gnat_object
);
7138 post_error_ne ("size for& is not a multiple of Storage_Unit",
7139 gnat_error_node
, gnat_object
);
7143 /* If this is an integral type or a packed array type, the front-end has
7144 verified the size, so we need not do it here (which would entail
7145 checking against the bounds). However, if this is an aliased object, it
7146 may not be smaller than the type of the object. */
7147 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
7148 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
7151 /* If the object is a record that contains a template, add the size of
7152 the template to the specified size. */
7153 if (TREE_CODE (gnu_type
) == RECORD_TYPE
7154 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7155 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
7157 /* Modify the size of the type to be that of the maximum size if it has a
7159 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
7160 type_size
= max_size (type_size
, true);
7162 /* If this is an access type or a fat pointer, the minimum size is that given
7163 by the smallest integral mode that's valid for pointers. */
7164 if ((TREE_CODE (gnu_type
) == POINTER_TYPE
) || TYPE_FAT_POINTER_P (gnu_type
))
7166 enum machine_mode p_mode
;
7168 for (p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
7169 !targetm
.valid_pointer_mode (p_mode
);
7170 p_mode
= GET_MODE_WIDER_MODE (p_mode
))
7173 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
7176 /* If the size of the object is a constant, the new size must not be
7178 if (TREE_CODE (type_size
) != INTEGER_CST
7179 || TREE_OVERFLOW (type_size
)
7180 || tree_int_cst_lt (size
, type_size
))
7184 ("component size for& too small{, minimum allowed is ^}",
7185 gnat_error_node
, gnat_object
, type_size
);
7187 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7188 gnat_error_node
, gnat_object
, type_size
);
7190 if (kind
== VAR_DECL
&& !component_p
7191 && TREE_CODE (rm_size (gnu_type
)) == INTEGER_CST
7192 && !tree_int_cst_lt (size
, rm_size (gnu_type
)))
7193 post_error_ne_tree_2
7194 ("\\size of ^ is not a multiple of alignment (^ bits)",
7195 gnat_error_node
, gnat_object
, rm_size (gnu_type
),
7196 TYPE_ALIGN (gnu_type
));
7198 else if (INTEGRAL_TYPE_P (gnu_type
))
7199 post_error_ne ("\\size would be legal if & were not aliased!",
7200 gnat_error_node
, gnat_object
);
7208 /* Similarly, but both validate and process a value of RM_Size. This
7209 routine is only called for types. */
7212 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
7214 /* Only give an error if a Value_Size clause was explicitly given.
7215 Otherwise, we'd be duplicating an error on the Size clause. */
7216 Node_Id gnat_attr_node
7217 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
7218 tree old_size
= rm_size (gnu_type
);
7221 /* Get the size as a tree. Do nothing if none was specified, either
7222 because RM_Size was not Present or if the specified size was zero.
7223 Give an error if a size was specified, but cannot be represented as
7225 if (No (uint_size
) || uint_size
== No_Uint
)
7228 size
= UI_To_gnu (uint_size
, bitsizetype
);
7229 if (TREE_OVERFLOW (size
))
7231 if (Present (gnat_attr_node
))
7232 post_error_ne ("Value_Size of & is too large", gnat_attr_node
,
7238 /* Ignore a negative size since that corresponds to our back-annotation.
7239 Also ignore a zero size unless a size clause exists, a Value_Size
7240 clause exists, or this is an integer type, in which case the
7241 front end will have always set it. */
7242 else if (tree_int_cst_sgn (size
) < 0
7243 || (integer_zerop (size
) && No (gnat_attr_node
)
7244 && !Has_Size_Clause (gnat_entity
)
7245 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
)))
7248 /* If the old size is self-referential, get the maximum size. */
7249 if (CONTAINS_PLACEHOLDER_P (old_size
))
7250 old_size
= max_size (old_size
, true);
7252 /* If the size of the object is a constant, the new size must not be
7253 smaller (the front end checks this for scalar types). */
7254 if (TREE_CODE (old_size
) != INTEGER_CST
7255 || TREE_OVERFLOW (old_size
)
7256 || (AGGREGATE_TYPE_P (gnu_type
)
7257 && tree_int_cst_lt (size
, old_size
)))
7259 if (Present (gnat_attr_node
))
7261 ("Value_Size for& too small{, minimum allowed is ^}",
7262 gnat_attr_node
, gnat_entity
, old_size
);
7267 /* Otherwise, set the RM_Size. */
7268 if (TREE_CODE (gnu_type
) == INTEGER_TYPE
7269 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
7270 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
7271 else if (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
7272 || TREE_CODE (gnu_type
) == BOOLEAN_TYPE
)
7273 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
7274 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
7275 || TREE_CODE (gnu_type
) == UNION_TYPE
7276 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
7277 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
7278 SET_TYPE_ADA_SIZE (gnu_type
, size
);
7281 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7282 If TYPE is the best type, return it. Otherwise, make a new type. We
7283 only support new integral and pointer types. FOR_BIASED is true if
7284 we are making a biased type. */
7287 make_type_from_size (tree type
, tree size_tree
, bool for_biased
)
7289 unsigned HOST_WIDE_INT size
;
7293 /* If size indicates an error, just return TYPE to avoid propagating
7294 the error. Likewise if it's too large to represent. */
7295 if (!size_tree
|| !host_integerp (size_tree
, 1))
7298 size
= tree_low_cst (size_tree
, 1);
7300 switch (TREE_CODE (type
))
7305 biased_p
= (TREE_CODE (type
) == INTEGER_TYPE
7306 && TYPE_BIASED_REPRESENTATION_P (type
));
7308 /* Only do something if the type is not a packed array type and
7309 doesn't already have the proper size. */
7310 if (TYPE_PACKED_ARRAY_TYPE_P (type
)
7311 || (TYPE_PRECISION (type
) == size
&& biased_p
== for_biased
))
7314 biased_p
|= for_biased
;
7315 size
= MIN (size
, LONG_LONG_TYPE_SIZE
);
7317 if (TYPE_UNSIGNED (type
) || biased_p
)
7318 new_type
= make_unsigned_type (size
);
7320 new_type
= make_signed_type (size
);
7321 TREE_TYPE (new_type
) = TREE_TYPE (type
) ? TREE_TYPE (type
) : type
;
7322 TYPE_MIN_VALUE (new_type
)
7323 = convert (TREE_TYPE (new_type
), TYPE_MIN_VALUE (type
));
7324 TYPE_MAX_VALUE (new_type
)
7325 = convert (TREE_TYPE (new_type
), TYPE_MAX_VALUE (type
));
7326 /* Propagate the name to avoid creating a fake subrange type. */
7327 if (TYPE_NAME (type
))
7329 if (TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
)
7330 TYPE_NAME (new_type
) = DECL_NAME (TYPE_NAME (type
));
7332 TYPE_NAME (new_type
) = TYPE_NAME (type
);
7334 TYPE_BIASED_REPRESENTATION_P (new_type
) = biased_p
;
7335 TYPE_RM_SIZE_NUM (new_type
) = bitsize_int (size
);
7339 /* Do something if this is a fat pointer, in which case we
7340 may need to return the thin pointer. */
7341 if (TYPE_IS_FAT_POINTER_P (type
) && size
< POINTER_SIZE
* 2)
7343 enum machine_mode p_mode
= mode_for_size (size
, MODE_INT
, 0);
7344 if (!targetm
.valid_pointer_mode (p_mode
))
7347 build_pointer_type_for_mode
7348 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type
)),
7354 /* Only do something if this is a thin pointer, in which case we
7355 may need to return the fat pointer. */
7356 if (TYPE_THIN_POINTER_P (type
) && size
>= POINTER_SIZE
* 2)
7358 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)));
7368 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7369 a type or object whose present alignment is ALIGN. If this alignment is
7370 valid, return it. Otherwise, give an error and return ALIGN. */
7373 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
7375 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
7376 unsigned int new_align
;
7377 Node_Id gnat_error_node
;
7379 /* Don't worry about checking alignment if alignment was not specified
7380 by the source program and we already posted an error for this entity. */
7381 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
7384 /* Post the error on the alignment clause if any. */
7385 if (Present (Alignment_Clause (gnat_entity
)))
7386 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
7388 gnat_error_node
= gnat_entity
;
7390 /* Within GCC, an alignment is an integer, so we must make sure a value is
7391 specified that fits in that range. Also, there is an upper bound to
7392 alignments we can support/allow. */
7393 if (!UI_Is_In_Int_Range (alignment
)
7394 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
7395 post_error_ne_num ("largest supported alignment for& is ^",
7396 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
7397 else if (!(Present (Alignment_Clause (gnat_entity
))
7398 && From_At_Mod (Alignment_Clause (gnat_entity
)))
7399 && new_align
* BITS_PER_UNIT
< align
)
7400 post_error_ne_num ("alignment for& must be at least ^",
7401 gnat_error_node
, gnat_entity
,
7402 align
/ BITS_PER_UNIT
);
7405 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
7406 if (new_align
> align
)
7413 /* Return the smallest alignment not less than SIZE. */
7416 ceil_alignment (unsigned HOST_WIDE_INT size
)
7418 return (unsigned int) 1 << (floor_log2 (size
- 1) + 1);
7421 /* Verify that OBJECT, a type or decl, is something we can implement
7422 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7423 if we require atomic components. */
7426 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
7428 Node_Id gnat_error_point
= gnat_entity
;
7430 enum machine_mode mode
;
7434 /* There are three case of what OBJECT can be. It can be a type, in which
7435 case we take the size, alignment and mode from the type. It can be a
7436 declaration that was indirect, in which case the relevant values are
7437 that of the type being pointed to, or it can be a normal declaration,
7438 in which case the values are of the decl. The code below assumes that
7439 OBJECT is either a type or a decl. */
7440 if (TYPE_P (object
))
7442 mode
= TYPE_MODE (object
);
7443 align
= TYPE_ALIGN (object
);
7444 size
= TYPE_SIZE (object
);
7446 else if (DECL_BY_REF_P (object
))
7448 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
7449 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
7450 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
7454 mode
= DECL_MODE (object
);
7455 align
= DECL_ALIGN (object
);
7456 size
= DECL_SIZE (object
);
7459 /* Consider all floating-point types atomic and any types that that are
7460 represented by integers no wider than a machine word. */
7461 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
7462 || ((GET_MODE_CLASS (mode
) == MODE_INT
7463 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
7464 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
7467 /* For the moment, also allow anything that has an alignment equal
7468 to its size and which is smaller than a word. */
7469 if (size
&& TREE_CODE (size
) == INTEGER_CST
7470 && compare_tree_int (size
, align
) == 0
7471 && align
<= BITS_PER_WORD
)
7474 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
7475 gnat_node
= Next_Rep_Item (gnat_node
))
7477 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
7478 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7480 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7481 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
7482 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7483 == Pragma_Atomic_Components
))
7484 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7488 post_error_ne ("atomic access to component of & cannot be guaranteed",
7489 gnat_error_point
, gnat_entity
);
7491 post_error_ne ("atomic access to & cannot be guaranteed",
7492 gnat_error_point
, gnat_entity
);
7495 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7496 have compatible signatures so that a call using one type may be safely
7497 issued if the actual target function type is the other. Return 1 if it is
7498 the case, 0 otherwise, and post errors on the incompatibilities.
7500 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7501 that calls to the subprogram will have arguments suitable for the later
7502 underlying builtin expansion. */
7505 compatible_signatures_p (tree ftype1
, tree ftype2
)
7507 /* As of now, we only perform very trivial tests and consider it's the
7508 programmer's responsibility to ensure the type correctness in the Ada
7509 declaration, as in the regular Import cases.
7511 Mismatches typically result in either error messages from the builtin
7512 expander, internal compiler errors, or in a real call sequence. This
7513 should be refined to issue diagnostics helping error detection and
7516 /* Almost fake test, ensuring a use of each argument. */
7517 if (ftype1
== ftype2
)
7523 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7524 type with all size expressions that contain F updated by replacing F
7525 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
7526 nothing has changed. */
7529 substitute_in_type (tree t
, tree f
, tree r
)
7534 switch (TREE_CODE (t
))
7539 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
7540 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
7542 tree low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
7543 tree high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
7545 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
7548 new = build_range_type (TREE_TYPE (t
), low
, high
);
7549 if (TYPE_INDEX_TYPE (t
))
7551 (new, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
7558 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
7559 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
7561 tree low
= NULL_TREE
, high
= NULL_TREE
;
7563 if (TYPE_MIN_VALUE (t
))
7564 low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
7565 if (TYPE_MAX_VALUE (t
))
7566 high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
7568 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
7572 TYPE_MIN_VALUE (t
) = low
;
7573 TYPE_MAX_VALUE (t
) = high
;
7578 tem
= substitute_in_type (TREE_TYPE (t
), f
, r
);
7579 if (tem
== TREE_TYPE (t
))
7582 return build_complex_type (tem
);
7588 /* Don't know how to do these yet. */
7593 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
7594 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
7596 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
7599 new = build_array_type (component
, domain
);
7600 TYPE_SIZE (new) = 0;
7601 TYPE_NONALIASED_COMPONENT (new) = TYPE_NONALIASED_COMPONENT (t
);
7602 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t
);
7603 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t
);
7605 TYPE_ALIGN (new) = TYPE_ALIGN (t
);
7606 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t
);
7608 /* If we had bounded the sizes of T by a constant, bound the sizes of
7609 NEW by the same constant. */
7610 if (TREE_CODE (TYPE_SIZE (t
)) == MIN_EXPR
)
7612 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE (t
), 1),
7614 if (TREE_CODE (TYPE_SIZE_UNIT (t
)) == MIN_EXPR
)
7615 TYPE_SIZE_UNIT (new)
7616 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE_UNIT (t
), 1),
7617 TYPE_SIZE_UNIT (new));
7623 case QUAL_UNION_TYPE
:
7627 = (f
== NULL_TREE
&& !TREE_CONSTANT (TYPE_SIZE (t
)));
7628 bool field_has_rep
= false;
7629 tree last_field
= NULL_TREE
;
7631 tree
new = copy_type (t
);
7633 /* Start out with no fields, make new fields, and chain them
7634 in. If we haven't actually changed the type of any field,
7635 discard everything we've done and return the old type. */
7637 TYPE_FIELDS (new) = NULL_TREE
;
7638 TYPE_SIZE (new) = NULL_TREE
;
7640 for (field
= TYPE_FIELDS (t
); field
; field
= TREE_CHAIN (field
))
7642 tree new_field
= copy_node (field
);
7644 TREE_TYPE (new_field
)
7645 = substitute_in_type (TREE_TYPE (new_field
), f
, r
);
7647 if (DECL_HAS_REP_P (field
) && !DECL_INTERNAL_P (field
))
7648 field_has_rep
= true;
7649 else if (TREE_TYPE (new_field
) != TREE_TYPE (field
))
7650 changed_field
= true;
7652 /* If this is an internal field and the type of this field is
7653 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7654 the type just has one element, treat that as the field.
7655 But don't do this if we are processing a QUAL_UNION_TYPE. */
7656 if (TREE_CODE (t
) != QUAL_UNION_TYPE
7657 && DECL_INTERNAL_P (new_field
)
7658 && (TREE_CODE (TREE_TYPE (new_field
)) == UNION_TYPE
7659 || TREE_CODE (TREE_TYPE (new_field
)) == RECORD_TYPE
))
7661 if (!TYPE_FIELDS (TREE_TYPE (new_field
)))
7664 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field
))))
7667 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field
)));
7669 /* Make sure omitting the union doesn't change
7671 DECL_ALIGN (next_new_field
) = DECL_ALIGN (new_field
);
7672 new_field
= next_new_field
;
7676 DECL_CONTEXT (new_field
) = new;
7677 SET_DECL_ORIGINAL_FIELD (new_field
,
7678 (DECL_ORIGINAL_FIELD (field
)
7679 ? DECL_ORIGINAL_FIELD (field
) : field
));
7681 /* If the size of the old field was set at a constant,
7682 propagate the size in case the type's size was variable.
7683 (This occurs in the case of a variant or discriminated
7684 record with a default size used as a field of another
7686 DECL_SIZE (new_field
)
7687 = TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
7688 ? DECL_SIZE (field
) : NULL_TREE
;
7689 DECL_SIZE_UNIT (new_field
)
7690 = TREE_CODE (DECL_SIZE_UNIT (field
)) == INTEGER_CST
7691 ? DECL_SIZE_UNIT (field
) : NULL_TREE
;
7693 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
7695 tree new_q
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
7697 if (new_q
!= DECL_QUALIFIER (new_field
))
7698 changed_field
= true;
7700 /* Do the substitution inside the qualifier and if we find
7701 that this field will not be present, omit it. */
7702 DECL_QUALIFIER (new_field
) = new_q
;
7704 if (integer_zerop (DECL_QUALIFIER (new_field
)))
7709 TYPE_FIELDS (new) = new_field
;
7711 TREE_CHAIN (last_field
) = new_field
;
7713 last_field
= new_field
;
7715 /* If this is a qualified type and this field will always be
7716 present, we are done. */
7717 if (TREE_CODE (t
) == QUAL_UNION_TYPE
7718 && integer_onep (DECL_QUALIFIER (new_field
)))
7722 /* If this used to be a qualified union type, but we now know what
7723 field will be present, make this a normal union. */
7724 if (changed_field
&& TREE_CODE (new) == QUAL_UNION_TYPE
7725 && (!TYPE_FIELDS (new)
7726 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7727 TREE_SET_CODE (new, UNION_TYPE
);
7728 else if (!changed_field
)
7731 gcc_assert (!field_has_rep
);
7734 /* If the size was originally a constant use it. */
7735 if (TYPE_SIZE (t
) && TREE_CODE (TYPE_SIZE (t
)) == INTEGER_CST
7736 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST
)
7738 TYPE_SIZE (new) = TYPE_SIZE (t
);
7739 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t
);
7740 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t
));
7751 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7752 needed to represent the object. */
7755 rm_size (tree gnu_type
)
7757 /* For integer types, this is the precision. For record types, we store
7758 the size explicitly. For other types, this is just the size. */
7760 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
7761 return TYPE_RM_SIZE (gnu_type
);
7762 else if (TREE_CODE (gnu_type
) == RECORD_TYPE
7763 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7764 /* Return the rm_size of the actual data plus the size of the template. */
7766 size_binop (PLUS_EXPR
,
7767 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)))),
7768 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
7769 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
7770 || TREE_CODE (gnu_type
) == UNION_TYPE
7771 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
7772 && !TYPE_IS_FAT_POINTER_P (gnu_type
)
7773 && TYPE_ADA_SIZE (gnu_type
))
7774 return TYPE_ADA_SIZE (gnu_type
);
7776 return TYPE_SIZE (gnu_type
);
7779 /* Return an identifier representing the external name to be used for
7780 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7781 and the specified suffix. */
7784 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
7786 Entity_Kind kind
= Ekind (gnat_entity
);
7788 const char *str
= (!suffix
? "" : suffix
);
7789 String_Template temp
= {1, strlen (str
)};
7790 Fat_Pointer fp
= {str
, &temp
};
7792 Get_External_Name_With_Suffix (gnat_entity
, fp
);
7794 /* A variable using the Stdcall convention (meaning we are running
7795 on a Windows box) live in a DLL. Here we adjust its name to use
7796 the jump-table, the _imp__NAME contains the address for the NAME
7798 if ((kind
== E_Variable
|| kind
== E_Constant
)
7799 && Has_Stdcall_Convention (gnat_entity
))
7801 const char *prefix
= "_imp__";
7802 int k
, plen
= strlen (prefix
);
7804 for (k
= 0; k
<= Name_Len
; k
++)
7805 Name_Buffer
[Name_Len
- k
+ plen
] = Name_Buffer
[Name_Len
- k
];
7806 strncpy (Name_Buffer
, prefix
, plen
);
7809 return get_identifier (Name_Buffer
);
7812 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7813 fully-qualified name, possibly with type information encoding.
7814 Otherwise, return the name. */
7817 get_entity_name (Entity_Id gnat_entity
)
7819 Get_Encoded_Name (gnat_entity
);
7820 return get_identifier (Name_Buffer
);
7823 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7824 string, return a new IDENTIFIER_NODE that is the concatenation of
7825 the name in GNU_ID and SUFFIX. */
7828 concat_id_with_name (tree gnu_id
, const char *suffix
)
7830 int len
= IDENTIFIER_LENGTH (gnu_id
);
7832 strncpy (Name_Buffer
, IDENTIFIER_POINTER (gnu_id
), len
);
7833 strncpy (Name_Buffer
+ len
, "___", 3);
7835 strcpy (Name_Buffer
+ len
, suffix
);
7836 return get_identifier (Name_Buffer
);
7839 #include "gt-ada-decl.h"