1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
56 #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)
72 struct incomplete
*next
;
77 /* These variables are used to defer recursively expanding incomplete types
78 while we are processing an array, a record or a subprogram type. */
79 static int defer_incomplete_level
= 0;
80 static struct incomplete
*defer_incomplete_list
;
82 /* This variable is used to delay expanding From_With_Type types until the
84 static struct incomplete
*defer_limited_with
;
86 /* These variables are used to defer finalizing types. The element of the
87 list is the TYPE_DECL associated with the type. */
88 static int defer_finalize_level
= 0;
89 static VEC (tree
,heap
) *defer_finalize_list
;
91 /* A hash table used to cache the result of annotate_value. */
92 static GTY ((if_marked ("tree_int_map_marked_p"),
93 param_is (struct tree_int_map
))) htab_t annotate_value_cache
;
95 static void copy_alias_set (tree
, tree
);
96 static tree
substitution_list (Entity_Id
, Entity_Id
, tree
, bool);
97 static bool allocatable_size_p (tree
, bool);
98 static void prepend_one_attribute_to (struct attrib
**,
99 enum attr_type
, tree
, tree
, Node_Id
);
100 static void prepend_attributes (Entity_Id
, struct attrib
**);
101 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
102 static bool is_variable_size (tree
);
103 static tree
elaborate_expression_1 (Node_Id
, Entity_Id
, tree
, tree
,
105 static tree
make_packable_type (tree
, bool);
106 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool);
107 static tree
gnat_to_gnu_param (Entity_Id
, Mechanism_Type
, Entity_Id
, bool,
109 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
110 static bool array_type_has_nonaliased_component (Entity_Id
, tree
);
111 static void components_to_record (tree
, Node_Id
, tree
, int, bool, tree
*,
112 bool, bool, bool, bool);
113 static Uint
annotate_value (tree
);
114 static void annotate_rep (Entity_Id
, tree
);
115 static tree
compute_field_positions (tree
, tree
, tree
, tree
, unsigned int);
116 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
117 static void set_rm_size (Uint
, tree
, Entity_Id
);
118 static tree
make_type_from_size (tree
, tree
, bool);
119 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
120 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT
);
121 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
122 static int compatible_signatures_p (tree ftype1
, tree ftype2
);
123 static void rest_of_type_decl_compilation_no_defer (tree
);
125 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
126 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
127 refer to an Ada type. */
130 gnat_to_gnu_type (Entity_Id gnat_entity
)
134 /* The back end never attempts to annotate generic types */
135 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
136 return void_type_node
;
138 /* Convert the ada entity type into a GCC TYPE_DECL node. */
139 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
140 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
141 return TREE_TYPE (gnu_decl
);
144 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
145 entity, this routine returns the equivalent GCC tree for that entity
146 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
149 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
150 initial value (in GCC tree form). This is optional for variables.
151 For renamed entities, GNU_EXPR gives the object being renamed.
153 DEFINITION is nonzero if this call is intended for a definition. This is
154 used for separate compilation where it necessary to know whether an
155 external declaration or a definition should be created if the GCC equivalent
156 was not created previously. The value of 1 is normally used for a nonzero
157 DEFINITION, but a value of 2 is used in special circumstances, defined in
161 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
163 Entity_Id gnat_equiv_type
= Gigi_Equivalent_Type (gnat_entity
);
165 tree gnu_type
= NULL_TREE
;
166 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
167 GNAT tree. This node will be associated with the GNAT node by calling
168 the save_gnu_tree routine at the end of the `switch' statement. */
169 tree gnu_decl
= NULL_TREE
;
170 /* true if we have already saved gnu_decl as a gnat association. */
172 /* Nonzero if we incremented defer_incomplete_level. */
173 bool this_deferred
= false;
174 /* Nonzero if we incremented force_global. */
175 bool this_global
= false;
176 /* Nonzero if we should check to see if elaborated during processing. */
177 bool maybe_present
= false;
178 /* Nonzero if we made GNU_DECL and its type here. */
179 bool this_made_decl
= false;
180 struct attrib
*attr_list
= NULL
;
181 bool debug_info_p
= (Needs_Debug_Info (gnat_entity
)
182 || debug_info_level
== DINFO_LEVEL_VERBOSE
);
183 Entity_Kind kind
= Ekind (gnat_entity
);
186 = ((Known_Esize (gnat_entity
)
187 && UI_Is_In_Int_Range (Esize (gnat_entity
)))
188 ? MIN (UI_To_Int (Esize (gnat_entity
)),
189 IN (kind
, Float_Kind
)
190 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
)
191 : IN (kind
, Access_Kind
) ? POINTER_SIZE
* 2
192 : LONG_LONG_TYPE_SIZE
)
193 : LONG_LONG_TYPE_SIZE
);
196 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
197 unsigned int align
= 0;
199 /* Since a use of an Itype is a definition, process it as such if it
200 is not in a with'ed unit. */
202 if (!definition
&& Is_Itype (gnat_entity
)
203 && !present_gnu_tree (gnat_entity
)
204 && In_Extended_Main_Code_Unit (gnat_entity
))
206 /* Ensure that we are in a subprogram mentioned in the Scope
207 chain of this entity, our current scope is global,
208 or that we encountered a task or entry (where we can't currently
209 accurately check scoping). */
210 if (!current_function_decl
211 || DECL_ELABORATION_PROC_P (current_function_decl
))
213 process_type (gnat_entity
);
214 return get_gnu_tree (gnat_entity
);
217 for (gnat_temp
= Scope (gnat_entity
);
218 Present (gnat_temp
); gnat_temp
= Scope (gnat_temp
))
220 if (Is_Type (gnat_temp
))
221 gnat_temp
= Underlying_Type (gnat_temp
);
223 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
225 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
227 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
228 && Present (Protected_Body_Subprogram (gnat_temp
)))
229 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
231 if (Ekind (gnat_temp
) == E_Entry
232 || Ekind (gnat_temp
) == E_Entry_Family
233 || Ekind (gnat_temp
) == E_Task_Type
234 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
235 && present_gnu_tree (gnat_temp
)
236 && (current_function_decl
237 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
239 process_type (gnat_entity
);
240 return get_gnu_tree (gnat_entity
);
244 /* This abort means the entity "gnat_entity" has an incorrect scope,
245 i.e. that its scope does not correspond to the subprogram in which
250 /* If this is entity 0, something went badly wrong. */
251 gcc_assert (Present (gnat_entity
));
253 /* If we've already processed this entity, return what we got last time.
254 If we are defining the node, we should not have already processed it.
255 In that case, we will abort below when we try to save a new GCC tree for
256 this object. We also need to handle the case of getting a dummy type
257 when a Full_View exists. */
259 if (present_gnu_tree (gnat_entity
)
260 && (!definition
|| (Is_Type (gnat_entity
) && imported_p
)))
262 gnu_decl
= get_gnu_tree (gnat_entity
);
264 if (TREE_CODE (gnu_decl
) == TYPE_DECL
265 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
266 && IN (kind
, Incomplete_Or_Private_Kind
)
267 && Present (Full_View (gnat_entity
)))
269 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
272 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
273 save_gnu_tree (gnat_entity
, gnu_decl
, false);
279 /* If this is a numeric or enumeral type, or an access type, a nonzero
280 Esize must be specified unless it was specified by the programmer. */
281 gcc_assert (!Unknown_Esize (gnat_entity
)
282 || Has_Size_Clause (gnat_entity
)
283 || (!IN (kind
, Numeric_Kind
) && !IN (kind
, Enumeration_Kind
)
284 && (!IN (kind
, Access_Kind
)
285 || kind
== E_Access_Protected_Subprogram_Type
286 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
287 || kind
== E_Access_Subtype
)));
289 /* Likewise, RM_Size must be specified for all discrete and fixed-point
291 gcc_assert (!IN (kind
, Discrete_Or_Fixed_Point_Kind
)
292 || !Unknown_RM_Size (gnat_entity
));
294 /* Get the name of the entity and set up the line number and filename of
295 the original definition for use in any decl we make. */
296 gnu_entity_id
= get_entity_name (gnat_entity
);
297 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
299 /* If we get here, it means we have not yet done anything with this
300 entity. If we are not defining it here, it must be external,
301 otherwise we should have defined it already. */
302 gcc_assert (definition
|| Is_Public (gnat_entity
) || type_annotate_only
303 || kind
== E_Discriminant
|| kind
== E_Component
305 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
306 || IN (kind
, Type_Kind
));
308 /* For cases when we are not defining (i.e., we are referencing from
309 another compilation unit) Public entities, show we are at global level
310 for the purpose of computing scopes. Don't do this for components or
311 discriminants since the relevant test is whether or not the record is
312 being defined. But do this for Imported functions or procedures in
314 if ((!definition
&& Is_Public (gnat_entity
)
315 && !Is_Statically_Allocated (gnat_entity
)
316 && kind
!= E_Discriminant
&& kind
!= E_Component
)
317 || (Is_Imported (gnat_entity
)
318 && (kind
== E_Function
|| kind
== E_Procedure
)))
319 force_global
++, this_global
= true;
321 /* Handle any attributes directly attached to the entity. */
322 if (Has_Gigi_Rep_Item (gnat_entity
))
323 prepend_attributes (gnat_entity
, &attr_list
);
325 /* Machine_Attributes on types are expected to be propagated to subtypes.
326 The corresponding Gigi_Rep_Items are only attached to the first subtype
327 though, so we handle the propagation here. */
328 if (Is_Type (gnat_entity
) && Base_Type (gnat_entity
) != gnat_entity
329 && !Is_First_Subtype (gnat_entity
)
330 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
331 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)), &attr_list
);
336 /* If this is a use of a deferred constant, get its full
338 if (!definition
&& Present (Full_View (gnat_entity
)))
340 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
346 /* If we have an external constant that we are not defining, get the
347 expression that is was defined to represent. We may throw that
348 expression away later if it is not a constant. Do not retrieve the
349 expression if it is an aggregate or allocator, because in complex
350 instantiation contexts it may not be expanded */
352 && Present (Expression (Declaration_Node (gnat_entity
)))
353 && !No_Initialization (Declaration_Node (gnat_entity
))
354 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
356 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
358 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
360 /* Ignore deferred constant definitions; they are processed fully in the
361 front-end. For deferred constant references get the full definition.
362 On the other hand, constants that are renamings are handled like
363 variable renamings. If No_Initialization is set, this is not a
364 deferred constant but a constant whose value is built manually. */
365 if (definition
&& !gnu_expr
366 && !No_Initialization (Declaration_Node (gnat_entity
))
367 && No (Renamed_Object (gnat_entity
)))
369 gnu_decl
= error_mark_node
;
373 else if (!definition
&& IN (kind
, Incomplete_Or_Private_Kind
)
374 && Present (Full_View (gnat_entity
)))
376 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
385 /* We used to special case VMS exceptions here to directly map them to
386 their associated condition code. Since this code had to be masked
387 dynamically to strip off the severity bits, this caused trouble in
388 the GCC/ZCX case because the "type" pointers we store in the tables
389 have to be static. We now don't special case here anymore, and let
390 the regular processing take place, which leaves us with a regular
391 exception data object for VMS exceptions too. The condition code
392 mapping is taken care of by the front end and the bitmasking by the
399 /* The GNAT record where the component was defined. */
400 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
402 /* If the variable is an inherited record component (in the case of
403 extended record types), just return the inherited entity, which
404 must be a FIELD_DECL. Likewise for discriminants.
405 For discriminants of untagged records which have explicit
406 stored discriminants, return the entity for the corresponding
407 stored discriminant. Also use Original_Record_Component
408 if the record has a private extension. */
410 if (Present (Original_Record_Component (gnat_entity
))
411 && Original_Record_Component (gnat_entity
) != gnat_entity
)
414 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
415 gnu_expr
, definition
);
420 /* If the enclosing record has explicit stored discriminants,
421 then it is an untagged record. If the Corresponding_Discriminant
422 is not empty then this must be a renamed discriminant and its
423 Original_Record_Component must point to the corresponding explicit
424 stored discriminant (i.e., we should have taken the previous
427 else if (Present (Corresponding_Discriminant (gnat_entity
))
428 && Is_Tagged_Type (gnat_record
))
430 /* A tagged record has no explicit stored discriminants. */
432 gcc_assert (First_Discriminant (gnat_record
)
433 == First_Stored_Discriminant (gnat_record
));
435 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
436 gnu_expr
, definition
);
441 else if (Present (CR_Discriminant (gnat_entity
))
442 && type_annotate_only
)
444 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
445 gnu_expr
, definition
);
450 /* If the enclosing record has explicit stored discriminants,
451 then it is an untagged record. If the Corresponding_Discriminant
452 is not empty then this must be a renamed discriminant and its
453 Original_Record_Component must point to the corresponding explicit
454 stored discriminant (i.e., we should have taken the first
457 else if (Present (Corresponding_Discriminant (gnat_entity
))
458 && (First_Discriminant (gnat_record
)
459 != First_Stored_Discriminant (gnat_record
)))
462 /* Otherwise, if we are not defining this and we have no GCC type
463 for the containing record, make one for it. Then we should
464 have made our own equivalent. */
465 else if (!definition
&& !present_gnu_tree (gnat_record
))
467 /* ??? If this is in a record whose scope is a protected
468 type and we have an Original_Record_Component, use it.
469 This is a workaround for major problems in protected type
471 Entity_Id Scop
= Scope (Scope (gnat_entity
));
472 if ((Is_Protected_Type (Scop
)
473 || (Is_Private_Type (Scop
)
474 && Present (Full_View (Scop
))
475 && Is_Protected_Type (Full_View (Scop
))))
476 && Present (Original_Record_Component (gnat_entity
)))
479 = gnat_to_gnu_entity (Original_Record_Component
486 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
487 gnu_decl
= get_gnu_tree (gnat_entity
);
493 /* Here we have no GCC type and this is a reference rather than a
494 definition. This should never happen. Most likely the cause is a
495 reference before declaration in the gnat tree for gnat_entity. */
499 case E_Loop_Parameter
:
500 case E_Out_Parameter
:
503 /* Simple variables, loop variables, Out parameters, and exceptions. */
506 bool used_by_ref
= false;
508 = ((kind
== E_Constant
|| kind
== E_Variable
)
509 && Is_True_Constant (gnat_entity
)
510 && (((Nkind (Declaration_Node (gnat_entity
))
511 == N_Object_Declaration
)
512 && Present (Expression (Declaration_Node (gnat_entity
))))
513 || Present (Renamed_Object (gnat_entity
))));
514 bool inner_const_flag
= const_flag
;
515 bool static_p
= Is_Statically_Allocated (gnat_entity
);
516 bool mutable_p
= false;
517 tree gnu_ext_name
= NULL_TREE
;
518 tree renamed_obj
= NULL_TREE
;
520 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
522 if (kind
== E_Exception
)
523 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
526 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
529 /* Get the type after elaborating the renamed object. */
530 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
532 /* For a debug renaming declaration, build a pure debug entity. */
533 if (Present (Debug_Renaming_Link (gnat_entity
)))
536 gnu_decl
= build_decl (VAR_DECL
, gnu_entity_id
, gnu_type
);
537 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
538 if (global_bindings_p ())
539 addr
= gen_rtx_CONST (VOIDmode
, const0_rtx
);
541 addr
= stack_pointer_rtx
;
542 SET_DECL_RTL (gnu_decl
, gen_rtx_MEM (Pmode
, addr
));
543 gnat_pushdecl (gnu_decl
, gnat_entity
);
547 /* If this is a loop variable, its type should be the base type.
548 This is because the code for processing a loop determines whether
549 a normal loop end test can be done by comparing the bounds of the
550 loop against those of the base type, which is presumed to be the
551 size used for computation. But this is not correct when the size
552 of the subtype is smaller than the type. */
553 if (kind
== E_Loop_Parameter
)
554 gnu_type
= get_base_type (gnu_type
);
556 /* Reject non-renamed objects whose types are unconstrained arrays or
557 any object whose type is a dummy type or VOID_TYPE. */
559 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
560 && No (Renamed_Object (gnat_entity
)))
561 || TYPE_IS_DUMMY_P (gnu_type
)
562 || TREE_CODE (gnu_type
) == VOID_TYPE
)
564 gcc_assert (type_annotate_only
);
567 return error_mark_node
;
570 /* If an alignment is specified, use it if valid. Note that
571 exceptions are objects but don't have alignments. We must do this
572 before we validate the size, since the alignment can affect the
574 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
576 gcc_assert (Present (Alignment (gnat_entity
)));
577 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
578 TYPE_ALIGN (gnu_type
));
579 gnu_type
= maybe_pad_type (gnu_type
, NULL_TREE
, align
, gnat_entity
,
580 "PAD", false, definition
, true);
583 /* If we are defining the object, see if it has a Size value and
584 validate it if so. If we are not defining the object and a Size
585 clause applies, simply retrieve the value. We don't want to ignore
586 the clause and it is expected to have been validated already. Then
587 get the new type, if any. */
589 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
590 gnat_entity
, VAR_DECL
, false,
591 Has_Size_Clause (gnat_entity
));
592 else if (Has_Size_Clause (gnat_entity
))
593 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
598 = make_type_from_size (gnu_type
, gnu_size
,
599 Has_Biased_Representation (gnat_entity
));
601 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
602 gnu_size
= NULL_TREE
;
605 /* If this object has self-referential size, it must be a record with
606 a default value. We are supposed to allocate an object of the
607 maximum size in this case unless it is a constant with an
608 initializing expression, in which case we can get the size from
609 that. Note that the resulting size may still be a variable, so
610 this may end up with an indirect allocation. */
611 if (No (Renamed_Object (gnat_entity
))
612 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
614 if (gnu_expr
&& kind
== E_Constant
)
616 tree size
= TYPE_SIZE (TREE_TYPE (gnu_expr
));
617 if (CONTAINS_PLACEHOLDER_P (size
))
619 /* If the initializing expression is itself a constant,
620 despite having a nominal type with self-referential
621 size, we can get the size directly from it. */
622 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
623 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
626 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
627 && TREE_CODE (TREE_OPERAND (gnu_expr
, 0)) == VAR_DECL
628 && (TREE_READONLY (TREE_OPERAND (gnu_expr
, 0))
629 || DECL_READONLY_ONCE_ELAB
630 (TREE_OPERAND (gnu_expr
, 0))))
631 gnu_size
= DECL_SIZE (TREE_OPERAND (gnu_expr
, 0));
634 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size
, gnu_expr
);
639 /* We may have no GNU_EXPR because No_Initialization is
640 set even though there's an Expression. */
641 else if (kind
== E_Constant
642 && (Nkind (Declaration_Node (gnat_entity
))
643 == N_Object_Declaration
)
644 && Present (Expression (Declaration_Node (gnat_entity
))))
646 = TYPE_SIZE (gnat_to_gnu_type
648 (Expression (Declaration_Node (gnat_entity
)))));
651 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
656 /* If the size is zero bytes, make it one byte since some linkers have
657 trouble with zero-sized objects. If the object will have a
658 template, that will make it nonzero so don't bother. Also avoid
659 doing that for an object renaming or an object with an address
660 clause, as we would lose useful information on the view size
661 (e.g. for null array slices) and we are not allocating the object
664 && integer_zerop (gnu_size
)
665 && !TREE_OVERFLOW (gnu_size
))
666 || (TYPE_SIZE (gnu_type
)
667 && integer_zerop (TYPE_SIZE (gnu_type
))
668 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type
))))
669 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
670 || !Is_Array_Type (Etype (gnat_entity
)))
671 && !Present (Renamed_Object (gnat_entity
))
672 && !Present (Address_Clause (gnat_entity
)))
673 gnu_size
= bitsize_unit_node
;
675 /* If this is an object with no specified size and alignment, and if
676 either it is atomic or we are not optimizing alignment for space
677 and it is a non-scalar variable, and the size of its type is a
678 constant, set the alignment to the smallest not less than the
679 size, or to the biggest meaningful one, whichever is smaller. */
680 if (!gnu_size
&& align
== 0
681 && (Is_Atomic (gnat_entity
)
683 && !Optimize_Alignment_Space (gnat_entity
)
684 && kind
== E_Variable
685 && AGGREGATE_TYPE_P (gnu_type
)
686 && !const_flag
&& No (Renamed_Object (gnat_entity
))
687 && !imported_p
&& No (Address_Clause (gnat_entity
))))
688 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
690 /* No point in jumping through all the hoops needed in order
691 to support BIGGEST_ALIGNMENT if we don't really have to. */
692 unsigned int align_cap
= Is_Atomic (gnat_entity
)
694 : MAX_FIXED_MODE_SIZE
;
696 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
697 || compare_tree_int (TYPE_SIZE (gnu_type
), align_cap
) >= 0)
700 align
= ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type
), 1));
702 /* But make sure not to under-align the object. */
703 if (align
< TYPE_ALIGN (gnu_type
))
704 align
= TYPE_ALIGN (gnu_type
);
706 /* And honor the minimum valid atomic alignment, if any. */
707 #ifdef MINIMUM_ATOMIC_ALIGNMENT
708 if (align
< MINIMUM_ATOMIC_ALIGNMENT
)
709 align
= MINIMUM_ATOMIC_ALIGNMENT
;
713 /* If the object is set to have atomic components, find the component
714 type and validate it.
716 ??? Note that we ignore Has_Volatile_Components on objects; it's
717 not at all clear what to do in that case. */
719 if (Has_Atomic_Components (gnat_entity
))
721 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
722 ? TREE_TYPE (gnu_type
) : gnu_type
);
724 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
725 && TYPE_MULTI_ARRAY_P (gnu_inner
))
726 gnu_inner
= TREE_TYPE (gnu_inner
);
728 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
731 /* Now check if the type of the object allows atomic access. Note
732 that we must test the type, even if this object has size and
733 alignment to allow such access, because we will be going
734 inside the padded record to assign to the object. We could fix
735 this by always copying via an intermediate value, but it's not
736 clear it's worth the effort. */
737 if (Is_Atomic (gnat_entity
))
738 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
740 /* If this is an aliased object with an unconstrained nominal subtype,
741 make a type that includes the template. */
742 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
743 && Is_Array_Type (Etype (gnat_entity
))
744 && !type_annotate_only
)
747 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity
))));
750 = build_unc_object_type_from_ptr (gnu_fat
, gnu_type
,
751 concat_id_with_name (gnu_entity_id
,
755 #ifdef MINIMUM_ATOMIC_ALIGNMENT
756 /* If the size is a constant and no alignment is specified, force
757 the alignment to be the minimum valid atomic alignment. The
758 restriction on constant size avoids problems with variable-size
759 temporaries; if the size is variable, there's no issue with
760 atomic access. Also don't do this for a constant, since it isn't
761 necessary and can interfere with constant replacement. Finally,
762 do not do it for Out parameters since that creates an
763 size inconsistency with In parameters. */
764 if (align
== 0 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
765 && !FLOAT_TYPE_P (gnu_type
)
766 && !const_flag
&& No (Renamed_Object (gnat_entity
))
767 && !imported_p
&& No (Address_Clause (gnat_entity
))
768 && kind
!= E_Out_Parameter
769 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
770 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
771 align
= MINIMUM_ATOMIC_ALIGNMENT
;
774 /* Make a new type with the desired size and alignment, if needed. */
775 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
776 "PAD", false, definition
, true);
778 /* Make a volatile version of this object's type if we are to make
779 the object volatile. We also interpret 13.3(19) conservatively
780 and disallow any optimizations for an object covered by it. */
781 if ((Treat_As_Volatile (gnat_entity
)
782 || (Is_Exported (gnat_entity
)
783 /* Exclude exported constants created by the compiler,
784 which should boil down to static dispatch tables and
785 make it possible to put them in read-only memory. */
786 && (Comes_From_Source (gnat_entity
) || !const_flag
))
787 || Is_Imported (gnat_entity
)
788 || Present (Address_Clause (gnat_entity
)))
789 && !TYPE_VOLATILE (gnu_type
))
790 gnu_type
= build_qualified_type (gnu_type
,
791 (TYPE_QUALS (gnu_type
)
792 | TYPE_QUAL_VOLATILE
));
794 /* If this is a renaming, avoid as much as possible to create a new
795 object. However, in several cases, creating it is required.
796 This processing needs to be applied to the raw expression so
797 as to make it more likely to rename the underlying object. */
798 if (Present (Renamed_Object (gnat_entity
)))
800 bool create_normal_object
= false;
802 /* If the renamed object had padding, strip off the reference
803 to the inner object and reset our type. */
804 if ((TREE_CODE (gnu_expr
) == COMPONENT_REF
805 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
807 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0))))
808 /* Strip useless conversions around the object. */
809 || TREE_CODE (gnu_expr
) == NOP_EXPR
)
811 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
812 gnu_type
= TREE_TYPE (gnu_expr
);
815 /* Case 1: If this is a constant renaming stemming from a function
816 call, treat it as a normal object whose initial value is what
817 is being renamed. RM 3.3 says that the result of evaluating a
818 function call is a constant object. As a consequence, it can
819 be the inner object of a constant renaming. In this case, the
820 renaming must be fully instantiated, i.e. it cannot be a mere
821 reference to (part of) an existing object. */
824 tree inner_object
= gnu_expr
;
825 while (handled_component_p (inner_object
))
826 inner_object
= TREE_OPERAND (inner_object
, 0);
827 if (TREE_CODE (inner_object
) == CALL_EXPR
)
828 create_normal_object
= true;
831 /* Otherwise, see if we can proceed with a stabilized version of
832 the renamed entity or if we need to make a new object. */
833 if (!create_normal_object
)
835 tree maybe_stable_expr
= NULL_TREE
;
838 /* Case 2: If the renaming entity need not be materialized and
839 the renamed expression is something we can stabilize, use
840 that for the renaming. At the global level, we can only do
841 this if we know no SAVE_EXPRs need be made, because the
842 expression we return might be used in arbitrary conditional
843 branches so we must force the SAVE_EXPRs evaluation
844 immediately and this requires a function context. */
845 if (!Materialize_Entity (gnat_entity
)
846 && (!global_bindings_p ()
847 || (staticp (gnu_expr
)
848 && !TREE_SIDE_EFFECTS (gnu_expr
))))
851 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
855 gnu_decl
= maybe_stable_expr
;
856 /* ??? No DECL_EXPR is created so we need to mark
857 the expression manually lest it is shared. */
858 if (global_bindings_p ())
859 TREE_VISITED (gnu_decl
) = 1;
860 save_gnu_tree (gnat_entity
, gnu_decl
, true);
865 /* The stabilization failed. Keep maybe_stable_expr
866 untouched here to let the pointer case below know
867 about that failure. */
870 /* Case 3: If this is a constant renaming and creating a
871 new object is allowed and cheap, treat it as a normal
872 object whose initial value is what is being renamed. */
873 if (const_flag
&& Is_Elementary_Type (Etype (gnat_entity
)))
876 /* Case 4: Make this into a constant pointer to the object we
877 are to rename and attach the object to the pointer if it is
878 something we can stabilize.
880 From the proper scope, attached objects will be referenced
881 directly instead of indirectly via the pointer to avoid
882 subtle aliasing problems with non-addressable entities.
883 They have to be stable because we must not evaluate the
884 variables in the expression every time the renaming is used.
885 The pointer is called a "renaming" pointer in this case.
887 In the rare cases where we cannot stabilize the renamed
888 object, we just make a "bare" pointer, and the renamed
889 entity is always accessed indirectly through it. */
892 gnu_type
= build_reference_type (gnu_type
);
893 inner_const_flag
= TREE_READONLY (gnu_expr
);
896 /* If the previous attempt at stabilizing failed, there
897 is no point in trying again and we reuse the result
898 without attaching it to the pointer. In this case it
899 will only be used as the initializing expression of
900 the pointer and thus needs no special treatment with
901 regard to multiple evaluations. */
902 if (maybe_stable_expr
)
905 /* Otherwise, try to stabilize and attach the expression
906 to the pointer if the stabilization succeeds.
908 Note that this might introduce SAVE_EXPRs and we don't
909 check whether we're at the global level or not. This
910 is fine since we are building a pointer initializer and
911 neither the pointer nor the initializing expression can
912 be accessed before the pointer elaboration has taken
913 place in a correct program.
915 These SAVE_EXPRs will be evaluated at the right place
916 by either the evaluation of the initializer for the
917 non-global case or the elaboration code for the global
918 case, and will be attached to the elaboration procedure
919 in the latter case. */
923 = maybe_stabilize_reference (gnu_expr
, true, &stable
);
926 renamed_obj
= maybe_stable_expr
;
928 /* Attaching is actually performed downstream, as soon
929 as we have a VAR_DECL for the pointer we make. */
933 = build_unary_op (ADDR_EXPR
, gnu_type
, maybe_stable_expr
);
935 gnu_size
= NULL_TREE
;
941 /* If this is an aliased object whose nominal subtype is unconstrained,
942 the object is a record that contains both the template and
943 the object. If there is an initializer, it will have already
944 been converted to the right type, but we need to create the
945 template if there is no initializer. */
947 && TREE_CODE (gnu_type
) == RECORD_TYPE
948 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
949 /* Beware that padding might have been introduced
950 via maybe_pad_type above. */
951 || (TYPE_IS_PADDING_P (gnu_type
)
952 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
954 && TYPE_CONTAINS_TEMPLATE_P
955 (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
959 = TYPE_IS_PADDING_P (gnu_type
)
960 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
961 : TYPE_FIELDS (gnu_type
);
964 = gnat_build_constructor
968 build_template (TREE_TYPE (template_field
),
969 TREE_TYPE (TREE_CHAIN (template_field
)),
974 /* Convert the expression to the type of the object except in the
975 case where the object's type is unconstrained or the object's type
976 is a padded record whose field is of self-referential size. In
977 the former case, converting will generate unnecessary evaluations
978 of the CONSTRUCTOR to compute the size and in the latter case, we
979 want to only copy the actual data. */
981 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
982 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
983 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
984 && TYPE_IS_PADDING_P (gnu_type
)
985 && (CONTAINS_PLACEHOLDER_P
986 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
987 gnu_expr
= convert (gnu_type
, gnu_expr
);
989 /* If this is a pointer and it does not have an initializing
990 expression, initialize it to NULL, unless the object is
993 && (POINTER_TYPE_P (gnu_type
) || TYPE_FAT_POINTER_P (gnu_type
))
994 && !Is_Imported (gnat_entity
) && !gnu_expr
)
995 gnu_expr
= integer_zero_node
;
997 /* If we are defining the object and it has an Address clause we must
998 get the address expression from the saved GCC tree for the
999 object if the object has a Freeze_Node. Otherwise, we elaborate
1000 the address expression here since the front-end has guaranteed
1001 in that case that the elaboration has no effects. Note that
1002 only the latter mechanism is currently in use. */
1003 if (definition
&& Present (Address_Clause (gnat_entity
)))
1006 = (present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
)
1007 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
1009 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
1011 /* Ignore the size. It's either meaningless or was handled
1013 gnu_size
= NULL_TREE
;
1014 /* Convert the type of the object to a reference type that can
1015 alias everything as per 13.3(19). */
1017 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
1018 gnu_address
= convert (gnu_type
, gnu_address
);
1020 const_flag
= !Is_Public (gnat_entity
);
1022 /* If we don't have an initializing expression for the underlying
1023 variable, the initializing expression for the pointer is the
1024 specified address. Otherwise, we have to make a COMPOUND_EXPR
1025 to assign both the address and the initial value. */
1027 gnu_expr
= gnu_address
;
1030 = build2 (COMPOUND_EXPR
, gnu_type
,
1032 (MODIFY_EXPR
, NULL_TREE
,
1033 build_unary_op (INDIRECT_REF
, NULL_TREE
,
1039 /* If it has an address clause and we are not defining it, mark it
1040 as an indirect object. Likewise for Stdcall objects that are
1042 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
1043 || (Is_Imported (gnat_entity
)
1044 && Has_Stdcall_Convention (gnat_entity
)))
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_size
= NULL_TREE
;
1052 gnu_expr
= NULL_TREE
;
1053 /* No point in taking the address of an initializing expression
1054 that isn't going to be used. */
1059 /* If we are at top level and this object is of variable size,
1060 make the actual type a hidden pointer to the real type and
1061 make the initializer be a memory allocation and initialization.
1062 Likewise for objects we aren't defining (presumed to be
1063 external references from other packages), but there we do
1064 not set up an initialization.
1066 If the object's size overflows, make an allocator too, so that
1067 Storage_Error gets raised. Note that we will never free
1068 such memory, so we presume it never will get allocated. */
1070 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
1071 global_bindings_p () || !definition
1074 && ! allocatable_size_p (gnu_size
,
1075 global_bindings_p () || !definition
1078 gnu_type
= build_reference_type (gnu_type
);
1079 gnu_size
= NULL_TREE
;
1083 /* In case this was a aliased object whose nominal subtype is
1084 unconstrained, the pointer above will be a thin pointer and
1085 build_allocator will automatically make the template.
1087 If we have a template initializer only (that we made above),
1088 pretend there is none and rely on what build_allocator creates
1089 again anyway. Otherwise (if we have a full initializer), get
1090 the data part and feed that to build_allocator.
1092 If we are elaborating a mutable object, tell build_allocator to
1093 ignore a possibly simpler size from the initializer, if any, as
1094 we must allocate the maximum possible size in this case. */
1098 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1100 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1101 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1104 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1106 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1107 && 1 == VEC_length (constructor_elt
,
1108 CONSTRUCTOR_ELTS (gnu_expr
)))
1112 = build_component_ref
1113 (gnu_expr
, NULL_TREE
,
1114 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1118 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1119 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
))
1120 && !Is_Imported (gnat_entity
))
1121 post_error ("?Storage_Error will be raised at run-time!",
1124 gnu_expr
= build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1125 0, 0, gnat_entity
, mutable_p
);
1129 gnu_expr
= NULL_TREE
;
1134 /* If this object would go into the stack and has an alignment larger
1135 than the largest stack alignment the back-end can honor, resort to
1136 a variable of "aligning type". */
1137 if (!global_bindings_p () && !static_p
&& definition
1138 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1140 /* Create the new variable. No need for extra room before the
1141 aligned field as this is in automatic storage. */
1143 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1144 TYPE_SIZE_UNIT (gnu_type
),
1145 BIGGEST_ALIGNMENT
, 0);
1147 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1148 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1149 false, false, false, NULL
, gnat_entity
);
1151 /* Initialize the aligned field if we have an initializer. */
1154 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1156 (gnu_new_var
, NULL_TREE
,
1157 TYPE_FIELDS (gnu_new_type
), false),
1161 /* And setup this entity as a reference to the aligned field. */
1162 gnu_type
= build_reference_type (gnu_type
);
1165 (ADDR_EXPR
, gnu_type
,
1166 build_component_ref (gnu_new_var
, NULL_TREE
,
1167 TYPE_FIELDS (gnu_new_type
), false));
1169 gnu_size
= NULL_TREE
;
1175 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1176 | TYPE_QUAL_CONST
));
1178 /* Convert the expression to the type of the object except in the
1179 case where the object's type is unconstrained or the object's type
1180 is a padded record whose field is of self-referential size. In
1181 the former case, converting will generate unnecessary evaluations
1182 of the CONSTRUCTOR to compute the size and in the latter case, we
1183 want to only copy the actual data. */
1185 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1186 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1187 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1188 && TYPE_IS_PADDING_P (gnu_type
)
1189 && (CONTAINS_PLACEHOLDER_P
1190 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
1191 gnu_expr
= convert (gnu_type
, gnu_expr
);
1193 /* If this name is external or there was a name specified, use it,
1194 unless this is a VMS exception object since this would conflict
1195 with the symbol we need to export in addition. Don't use the
1196 Interface_Name if there is an address clause (see CD30005). */
1197 if (!Is_VMS_Exception (gnat_entity
)
1198 && ((Present (Interface_Name (gnat_entity
))
1199 && No (Address_Clause (gnat_entity
)))
1200 || (Is_Public (gnat_entity
)
1201 && (!Is_Imported (gnat_entity
)
1202 || Is_Exported (gnat_entity
)))))
1203 gnu_ext_name
= create_concat_name (gnat_entity
, 0);
1205 /* If this is constant initialized to a static constant and the
1206 object has an aggregate type, force it to be statically
1208 if (const_flag
&& gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1209 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1210 && (AGGREGATE_TYPE_P (gnu_type
)
1211 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1212 && TYPE_IS_PADDING_P (gnu_type
))))
1215 gnu_decl
= create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1216 gnu_expr
, const_flag
,
1217 Is_Public (gnat_entity
),
1218 imported_p
|| !definition
,
1219 static_p
, attr_list
, gnat_entity
);
1220 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1221 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1222 if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1224 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1225 if (global_bindings_p ())
1227 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1228 record_global_renaming_pointer (gnu_decl
);
1232 if (definition
&& DECL_SIZE (gnu_decl
)
1233 && get_block_jmpbuf_decl ()
1234 && (TREE_CODE (DECL_SIZE (gnu_decl
)) != INTEGER_CST
1235 || (flag_stack_check
&& !STACK_CHECK_BUILTIN
1236 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1237 STACK_CHECK_MAX_VAR_SIZE
))))
1238 add_stmt_with_node (build_call_1_expr
1239 (update_setjmp_buf_decl
,
1240 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1241 get_block_jmpbuf_decl ())),
1244 /* If this is a public constant or we're not optimizing and we're not
1245 making a VAR_DECL for it, make one just for export or debugger use.
1246 Likewise if the address is taken or if either the object or type is
1247 aliased. Make an external declaration for a reference, unless this
1248 is a Standard entity since there no real symbol at the object level
1250 if (TREE_CODE (gnu_decl
) == CONST_DECL
1251 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1252 && (Is_Public (gnat_entity
)
1254 || Address_Taken (gnat_entity
)
1255 || Is_Aliased (gnat_entity
)
1256 || Is_Aliased (Etype (gnat_entity
))))
1259 = create_true_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1260 gnu_expr
, true, Is_Public (gnat_entity
),
1261 !definition
, static_p
, NULL
,
1264 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1267 /* If this is declared in a block that contains a block with an
1268 exception handler, we must force this variable in memory to
1269 suppress an invalid optimization. */
1270 if (Has_Nested_Block_With_Handler (Scope (gnat_entity
))
1271 && Exception_Mechanism
!= Back_End_Exceptions
)
1272 TREE_ADDRESSABLE (gnu_decl
) = 1;
1274 gnu_type
= TREE_TYPE (gnu_decl
);
1276 /* Back-annotate Alignment and Esize of the object if not already
1277 known, except for when the object is actually a pointer to the
1278 real object, since alignment and size of a pointer don't have
1279 anything to do with those of the designated object. Note that
1280 we pick the values of the type, not those of the object, to
1281 shield ourselves from low-level platform-dependent adjustments
1282 like alignment promotion. This is both consistent with all the
1283 treatment above, where alignment and size are set on the type of
1284 the object and not on the object directly, and makes it possible
1285 to support confirming representation clauses in all cases. */
1287 if (!used_by_ref
&& Unknown_Alignment (gnat_entity
))
1288 Set_Alignment (gnat_entity
,
1289 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
1291 if (!used_by_ref
&& Unknown_Esize (gnat_entity
))
1295 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1296 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1298 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
))));
1300 gnu_back_size
= TYPE_SIZE (gnu_type
);
1302 Set_Esize (gnat_entity
, annotate_value (gnu_back_size
));
1308 /* Return a TYPE_DECL for "void" that we previously made. */
1309 gnu_decl
= void_type_decl_node
;
1312 case E_Enumeration_Type
:
1313 /* A special case, for the types Character and Wide_Character in
1314 Standard, we do not list all the literals. So if the literals
1315 are not specified, make this an unsigned type. */
1316 if (No (First_Literal (gnat_entity
)))
1318 gnu_type
= make_unsigned_type (esize
);
1319 TYPE_NAME (gnu_type
) = gnu_entity_id
;
1321 /* Set the TYPE_STRING_FLAG for Ada Character and
1322 Wide_Character types. This is needed by the dwarf-2 debug writer to
1323 distinguish between unsigned integer types and character types. */
1324 TYPE_STRING_FLAG (gnu_type
) = 1;
1328 /* Normal case of non-character type, or non-Standard character type */
1330 /* Here we have a list of enumeral constants in First_Literal.
1331 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1332 the list to be places into TYPE_FIELDS. Each node in the list
1333 is a TREE_LIST node whose TREE_VALUE is the literal name
1334 and whose TREE_PURPOSE is the value of the literal.
1336 Esize contains the number of bits needed to represent the enumeral
1337 type, Type_Low_Bound also points to the first literal and
1338 Type_High_Bound points to the last literal. */
1340 Entity_Id gnat_literal
;
1341 tree gnu_literal_list
= NULL_TREE
;
1343 if (Is_Unsigned_Type (gnat_entity
))
1344 gnu_type
= make_unsigned_type (esize
);
1346 gnu_type
= make_signed_type (esize
);
1348 TREE_SET_CODE (gnu_type
, ENUMERAL_TYPE
);
1350 for (gnat_literal
= First_Literal (gnat_entity
);
1351 Present (gnat_literal
);
1352 gnat_literal
= Next_Literal (gnat_literal
))
1354 tree gnu_value
= UI_To_gnu (Enumeration_Rep (gnat_literal
),
1357 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1358 gnu_type
, gnu_value
, true, false, false,
1359 false, NULL
, gnat_literal
);
1361 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1362 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1363 gnu_value
, gnu_literal_list
);
1366 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1368 /* Note that the bounds are updated at the end of this function
1369 because to avoid an infinite recursion when we get the bounds of
1370 this type, since those bounds are objects of this type. */
1374 case E_Signed_Integer_Type
:
1375 case E_Ordinary_Fixed_Point_Type
:
1376 case E_Decimal_Fixed_Point_Type
:
1377 /* For integer types, just make a signed type the appropriate number
1379 gnu_type
= make_signed_type (esize
);
1382 case E_Modular_Integer_Type
:
1383 /* For modular types, make the unsigned type of the proper number of
1384 bits and then set up the modulus, if required. */
1386 enum machine_mode mode
;
1390 if (Is_Packed_Array_Type (gnat_entity
))
1391 esize
= UI_To_Int (RM_Size (gnat_entity
));
1393 /* Find the smallest mode at least ESIZE bits wide and make a class
1396 for (mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
1397 GET_MODE_BITSIZE (mode
) < esize
;
1398 mode
= GET_MODE_WIDER_MODE (mode
))
1401 gnu_type
= make_unsigned_type (GET_MODE_BITSIZE (mode
));
1402 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
1403 = (Is_Packed_Array_Type (gnat_entity
)
1404 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
1406 /* Get the modulus in this type. If it overflows, assume it is because
1407 it is equal to 2**Esize. Note that there is no overflow checking
1408 done on unsigned type, so we detect the overflow by looking for
1409 a modulus of zero, which is otherwise invalid. */
1410 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1412 if (!integer_zerop (gnu_modulus
))
1414 TYPE_MODULAR_P (gnu_type
) = 1;
1415 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1416 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1417 convert (gnu_type
, integer_one_node
));
1420 /* If we have to set TYPE_PRECISION different from its natural value,
1421 make a subtype to do do. Likewise if there is a modulus and
1422 it is not one greater than TYPE_MAX_VALUE. */
1423 if (TYPE_PRECISION (gnu_type
) != esize
1424 || (TYPE_MODULAR_P (gnu_type
)
1425 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type
), gnu_high
)))
1427 tree gnu_subtype
= make_node (INTEGER_TYPE
);
1429 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1430 TREE_TYPE (gnu_subtype
) = gnu_type
;
1431 TYPE_MIN_VALUE (gnu_subtype
) = TYPE_MIN_VALUE (gnu_type
);
1432 TYPE_MAX_VALUE (gnu_subtype
)
1433 = TYPE_MODULAR_P (gnu_type
)
1434 ? gnu_high
: TYPE_MAX_VALUE (gnu_type
);
1435 TYPE_PRECISION (gnu_subtype
) = esize
;
1436 TYPE_UNSIGNED (gnu_subtype
) = 1;
1437 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1438 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype
)
1439 = (Is_Packed_Array_Type (gnat_entity
)
1440 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
1441 layout_type (gnu_subtype
);
1443 gnu_type
= gnu_subtype
;
1448 case E_Signed_Integer_Subtype
:
1449 case E_Enumeration_Subtype
:
1450 case E_Modular_Integer_Subtype
:
1451 case E_Ordinary_Fixed_Point_Subtype
:
1452 case E_Decimal_Fixed_Point_Subtype
:
1454 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1455 that we do not want to call build_range_type since we would
1456 like each subtype node to be distinct. This will be important
1457 when memory aliasing is implemented.
1459 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1460 parent type; this fact is used by the arithmetic conversion
1463 We elaborate the Ancestor_Subtype if it is not in the current
1464 unit and one of our bounds is non-static. We do this to ensure
1465 consistent naming in the case where several subtypes share the same
1466 bounds by always elaborating the first such subtype first, thus
1470 && Present (Ancestor_Subtype (gnat_entity
))
1471 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1472 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1473 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1474 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1477 gnu_type
= make_node (INTEGER_TYPE
);
1478 if (Is_Packed_Array_Type (gnat_entity
)
1479 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1481 esize
= UI_To_Int (RM_Size (gnat_entity
));
1482 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1485 TYPE_PRECISION (gnu_type
) = esize
;
1486 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1488 TYPE_MIN_VALUE (gnu_type
)
1489 = convert (TREE_TYPE (gnu_type
),
1490 elaborate_expression (Type_Low_Bound (gnat_entity
),
1492 get_identifier ("L"), definition
, 1,
1493 Needs_Debug_Info (gnat_entity
)));
1495 TYPE_MAX_VALUE (gnu_type
)
1496 = convert (TREE_TYPE (gnu_type
),
1497 elaborate_expression (Type_High_Bound (gnat_entity
),
1499 get_identifier ("U"), definition
, 1,
1500 Needs_Debug_Info (gnat_entity
)));
1502 /* One of the above calls might have caused us to be elaborated,
1503 so don't blow up if so. */
1504 if (present_gnu_tree (gnat_entity
))
1506 maybe_present
= true;
1510 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1511 = Has_Biased_Representation (gnat_entity
);
1513 /* This should be an unsigned type if the lower bound is constant
1514 and non-negative or if the base type is unsigned; a signed type
1516 TYPE_UNSIGNED (gnu_type
)
1517 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type
))
1518 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type
)) == INTEGER_CST
1519 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type
)) >= 0)
1520 || TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1521 || Is_Unsigned_Type (gnat_entity
));
1523 layout_type (gnu_type
);
1525 /* Inherit our alias set from what we're a subtype of. Subtypes
1526 are not different types and a pointer can designate any instance
1527 within a subtype hierarchy. */
1528 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1530 /* If the type we are dealing with is to represent a packed array,
1531 we need to have the bits left justified on big-endian targets
1532 and right justified on little-endian targets. We also need to
1533 ensure that when the value is read (e.g. for comparison of two
1534 such values), we only get the good bits, since the unused bits
1535 are uninitialized. Both goals are accomplished by wrapping the
1536 modular value in an enclosing struct. */
1537 if (Is_Packed_Array_Type (gnat_entity
)
1538 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
1540 tree gnu_field_type
= gnu_type
;
1543 TYPE_RM_SIZE_NUM (gnu_field_type
)
1544 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
1545 gnu_type
= make_node (RECORD_TYPE
);
1546 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1548 /* Propagate the alignment of the modular type to the record.
1549 This means that bitpacked arrays have "ceil" alignment for
1550 their size, which may seem counter-intuitive but makes it
1551 possible to easily overlay them on modular types. */
1552 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_field_type
);
1553 TYPE_PACKED (gnu_type
) = 1;
1555 /* Create a stripped-down declaration of the original type, mainly
1557 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1558 NULL
, true, debug_info_p
, gnat_entity
);
1560 /* Don't notify the field as "addressable", since we won't be taking
1561 it's address and it would prevent create_field_decl from making a
1563 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1564 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1566 finish_record_type (gnu_type
, gnu_field
, 0, false);
1567 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1568 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1570 copy_alias_set (gnu_type
, gnu_field_type
);
1573 /* If the type we are dealing with has got a smaller alignment than the
1574 natural one, we need to wrap it up in a record type and under-align
1575 the latter. We reuse the padding machinery for this purpose. */
1576 else if (Known_Alignment (gnat_entity
)
1577 && UI_Is_In_Int_Range (Alignment (gnat_entity
))
1578 && (align
= UI_To_Int (Alignment (gnat_entity
)) * BITS_PER_UNIT
)
1579 && align
< TYPE_ALIGN (gnu_type
))
1581 tree gnu_field_type
= gnu_type
;
1584 gnu_type
= make_node (RECORD_TYPE
);
1585 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "PAD");
1587 TYPE_ALIGN (gnu_type
) = align
;
1588 TYPE_PACKED (gnu_type
) = 1;
1590 /* Create a stripped-down declaration of the original type, mainly
1592 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1593 NULL
, true, debug_info_p
, gnat_entity
);
1595 /* Don't notify the field as "addressable", since we won't be taking
1596 it's address and it would prevent create_field_decl from making a
1598 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1599 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1601 finish_record_type (gnu_type
, gnu_field
, 0, false);
1602 TYPE_IS_PADDING_P (gnu_type
) = 1;
1603 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1605 copy_alias_set (gnu_type
, gnu_field_type
);
1608 /* Otherwise reset the alignment lest we computed it above. */
1614 case E_Floating_Point_Type
:
1615 /* If this is a VAX floating-point type, use an integer of the proper
1616 size. All the operations will be handled with ASM statements. */
1617 if (Vax_Float (gnat_entity
))
1619 gnu_type
= make_signed_type (esize
);
1620 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1621 SET_TYPE_DIGITS_VALUE (gnu_type
,
1622 UI_To_gnu (Digits_Value (gnat_entity
),
1627 /* The type of the Low and High bounds can be our type if this is
1628 a type from Standard, so set them at the end of the function. */
1629 gnu_type
= make_node (REAL_TYPE
);
1630 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1631 layout_type (gnu_type
);
1634 case E_Floating_Point_Subtype
:
1635 if (Vax_Float (gnat_entity
))
1637 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1643 && Present (Ancestor_Subtype (gnat_entity
))
1644 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1645 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1646 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1647 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1650 gnu_type
= make_node (REAL_TYPE
);
1651 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1652 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1654 TYPE_MIN_VALUE (gnu_type
)
1655 = convert (TREE_TYPE (gnu_type
),
1656 elaborate_expression (Type_Low_Bound (gnat_entity
),
1657 gnat_entity
, get_identifier ("L"),
1659 Needs_Debug_Info (gnat_entity
)));
1661 TYPE_MAX_VALUE (gnu_type
)
1662 = convert (TREE_TYPE (gnu_type
),
1663 elaborate_expression (Type_High_Bound (gnat_entity
),
1664 gnat_entity
, get_identifier ("U"),
1666 Needs_Debug_Info (gnat_entity
)));
1668 /* One of the above calls might have caused us to be elaborated,
1669 so don't blow up if so. */
1670 if (present_gnu_tree (gnat_entity
))
1672 maybe_present
= true;
1676 layout_type (gnu_type
);
1678 /* Inherit our alias set from what we're a subtype of, as for
1679 integer subtypes. */
1680 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1684 /* Array and String Types and Subtypes
1686 Unconstrained array types are represented by E_Array_Type and
1687 constrained array types are represented by E_Array_Subtype. There
1688 are no actual objects of an unconstrained array type; all we have
1689 are pointers to that type.
1691 The following fields are defined on array types and subtypes:
1693 Component_Type Component type of the array.
1694 Number_Dimensions Number of dimensions (an int).
1695 First_Index Type of first index. */
1700 tree gnu_template_fields
= NULL_TREE
;
1701 tree gnu_template_type
= make_node (RECORD_TYPE
);
1702 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
1703 tree gnu_fat_type
= make_node (RECORD_TYPE
);
1704 int ndim
= Number_Dimensions (gnat_entity
);
1706 = (Convention (gnat_entity
) == Convention_Fortran
) ? ndim
- 1 : 0;
1708 = (Convention (gnat_entity
) == Convention_Fortran
) ? - 1 : 1;
1710 tree
*gnu_index_types
= (tree
*) alloca (ndim
* sizeof (tree
*));
1711 tree
*gnu_temp_fields
= (tree
*) alloca (ndim
* sizeof (tree
*));
1712 tree gnu_comp_size
= 0;
1713 tree gnu_max_size
= size_one_node
;
1714 tree gnu_max_size_unit
;
1715 Entity_Id gnat_ind_subtype
;
1716 Entity_Id gnat_ind_base_subtype
;
1717 tree gnu_template_reference
;
1720 TYPE_NAME (gnu_template_type
)
1721 = create_concat_name (gnat_entity
, "XUB");
1723 /* Make a node for the array. If we are not defining the array
1724 suppress expanding incomplete types. */
1725 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
1728 defer_incomplete_level
++, this_deferred
= true;
1730 /* Build the fat pointer type. Use a "void *" object instead of
1731 a pointer to the array type since we don't have the array type
1732 yet (it will reference the fat pointer via the bounds). */
1733 tem
= chainon (chainon (NULL_TREE
,
1734 create_field_decl (get_identifier ("P_ARRAY"),
1736 gnu_fat_type
, 0, 0, 0, 0)),
1737 create_field_decl (get_identifier ("P_BOUNDS"),
1739 gnu_fat_type
, 0, 0, 0, 0));
1741 /* Make sure we can put this into a register. */
1742 TYPE_ALIGN (gnu_fat_type
) = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
1744 /* Do not finalize this record type since the types of its fields
1745 are still incomplete at this point. */
1746 finish_record_type (gnu_fat_type
, tem
, 0, true);
1747 TYPE_IS_FAT_POINTER_P (gnu_fat_type
) = 1;
1749 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1750 is the fat pointer. This will be used to access the individual
1751 fields once we build them. */
1752 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
1753 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
1754 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
1755 gnu_template_reference
1756 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
1757 TREE_READONLY (gnu_template_reference
) = 1;
1759 /* Now create the GCC type for each index and add the fields for
1760 that index to the template. */
1761 for (index
= firstdim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1762 gnat_ind_base_subtype
1763 = First_Index (Implementation_Base_Type (gnat_entity
));
1764 index
< ndim
&& index
>= 0;
1766 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1767 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1769 char field_name
[10];
1770 tree gnu_ind_subtype
1771 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype
)));
1772 tree gnu_base_subtype
1773 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1775 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1777 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1778 tree gnu_min_field
, gnu_max_field
, gnu_min
, gnu_max
;
1780 /* Make the FIELD_DECLs for the minimum and maximum of this
1781 type and then make extractions of that field from the
1783 sprintf (field_name
, "LB%d", index
);
1784 gnu_min_field
= create_field_decl (get_identifier (field_name
),
1786 gnu_template_type
, 0, 0, 0, 0);
1787 field_name
[0] = 'U';
1788 gnu_max_field
= create_field_decl (get_identifier (field_name
),
1790 gnu_template_type
, 0, 0, 0, 0);
1792 Sloc_to_locus (Sloc (gnat_entity
),
1793 &DECL_SOURCE_LOCATION (gnu_min_field
));
1794 Sloc_to_locus (Sloc (gnat_entity
),
1795 &DECL_SOURCE_LOCATION (gnu_max_field
));
1796 gnu_temp_fields
[index
] = chainon (gnu_min_field
, gnu_max_field
);
1798 /* We can't use build_component_ref here since the template
1799 type isn't complete yet. */
1800 gnu_min
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1801 gnu_template_reference
, gnu_min_field
,
1803 gnu_max
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1804 gnu_template_reference
, gnu_max_field
,
1806 TREE_READONLY (gnu_min
) = TREE_READONLY (gnu_max
) = 1;
1808 /* Make a range type with the new ranges, but using
1809 the Ada subtype. Then we convert to sizetype. */
1810 gnu_index_types
[index
]
1811 = create_index_type (convert (sizetype
, gnu_min
),
1812 convert (sizetype
, gnu_max
),
1813 build_range_type (gnu_ind_subtype
,
1816 /* Update the maximum size of the array, in elements. */
1818 = size_binop (MULT_EXPR
, gnu_max_size
,
1819 size_binop (PLUS_EXPR
, size_one_node
,
1820 size_binop (MINUS_EXPR
, gnu_base_max
,
1823 TYPE_NAME (gnu_index_types
[index
])
1824 = create_concat_name (gnat_entity
, field_name
);
1827 for (index
= 0; index
< ndim
; index
++)
1829 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
1831 /* Install all the fields into the template. */
1832 finish_record_type (gnu_template_type
, gnu_template_fields
, 0, false);
1833 TYPE_READONLY (gnu_template_type
) = 1;
1835 /* Now make the array of arrays and update the pointer to the array
1836 in the fat pointer. Note that it is the first field. */
1837 tem
= gnat_to_gnu_type (Component_Type (gnat_entity
));
1839 /* Try to get a smaller form of the component if needed. */
1840 if ((Is_Packed (gnat_entity
)
1841 || Has_Component_Size_Clause (gnat_entity
))
1842 && !Is_Bit_Packed_Array (gnat_entity
)
1843 && !Has_Aliased_Components (gnat_entity
)
1844 && !Strict_Alignment (Component_Type (gnat_entity
))
1845 && TREE_CODE (tem
) == RECORD_TYPE
1846 && host_integerp (TYPE_SIZE (tem
), 1))
1847 tem
= make_packable_type (tem
, false);
1849 if (Has_Atomic_Components (gnat_entity
))
1850 check_ok_for_atomic (tem
, gnat_entity
, true);
1852 /* Get and validate any specified Component_Size, but if Packed,
1853 ignore it since the front end will have taken care of it. */
1855 = validate_size (Component_Size (gnat_entity
), tem
,
1857 (Is_Bit_Packed_Array (gnat_entity
)
1858 ? TYPE_DECL
: VAR_DECL
),
1859 true, Has_Component_Size_Clause (gnat_entity
));
1861 /* If the component type is a RECORD_TYPE that has a self-referential
1862 size, use the maxium size. */
1863 if (!gnu_comp_size
&& TREE_CODE (tem
) == RECORD_TYPE
1864 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem
)))
1865 gnu_comp_size
= max_size (TYPE_SIZE (tem
), true);
1867 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_entity
))
1870 tem
= make_type_from_size (tem
, gnu_comp_size
, false);
1872 tem
= maybe_pad_type (tem
, gnu_comp_size
, 0, gnat_entity
,
1873 "C_PAD", false, definition
, true);
1874 /* If a padding record was made, declare it now since it will
1875 never be declared otherwise. This is necessary to ensure
1876 that its subtrees are properly marked. */
1877 if (tem
!= orig_tem
)
1878 create_type_decl (TYPE_NAME (tem
), tem
, NULL
, true, false,
1882 if (Has_Volatile_Components (gnat_entity
))
1883 tem
= build_qualified_type (tem
,
1884 TYPE_QUALS (tem
) | TYPE_QUAL_VOLATILE
);
1886 /* If Component_Size is not already specified, annotate it with the
1887 size of the component. */
1888 if (Unknown_Component_Size (gnat_entity
))
1889 Set_Component_Size (gnat_entity
, annotate_value (TYPE_SIZE (tem
)));
1891 gnu_max_size_unit
= size_binop (MAX_EXPR
, size_zero_node
,
1892 size_binop (MULT_EXPR
, gnu_max_size
,
1893 TYPE_SIZE_UNIT (tem
)));
1894 gnu_max_size
= size_binop (MAX_EXPR
, bitsize_zero_node
,
1895 size_binop (MULT_EXPR
,
1896 convert (bitsizetype
,
1900 for (index
= ndim
- 1; index
>= 0; index
--)
1902 tem
= build_array_type (tem
, gnu_index_types
[index
]);
1903 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
1904 if (array_type_has_nonaliased_component (gnat_entity
, tem
))
1905 TYPE_NONALIASED_COMPONENT (tem
) = 1;
1908 /* If an alignment is specified, use it if valid. But ignore it for
1909 types that represent the unpacked base type for packed arrays. If
1910 the alignment was requested with an explicit user alignment clause,
1912 if (No (Packed_Array_Type (gnat_entity
))
1913 && Known_Alignment (gnat_entity
))
1915 gcc_assert (Present (Alignment (gnat_entity
)));
1917 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
1919 if (Present (Alignment_Clause (gnat_entity
)))
1920 TYPE_USER_ALIGN (tem
) = 1;
1923 TYPE_CONVENTION_FORTRAN_P (tem
)
1924 = (Convention (gnat_entity
) == Convention_Fortran
);
1925 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
1927 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1928 corresponding fat pointer. */
1929 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
)
1930 = TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
1931 TYPE_MODE (gnu_type
) = BLKmode
;
1932 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
1933 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
1935 /* If the maximum size doesn't overflow, use it. */
1936 if (TREE_CODE (gnu_max_size
) == INTEGER_CST
1937 && !TREE_OVERFLOW (gnu_max_size
))
1939 = size_binop (MIN_EXPR
, gnu_max_size
, TYPE_SIZE (tem
));
1940 if (TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
1941 && !TREE_OVERFLOW (gnu_max_size_unit
))
1942 TYPE_SIZE_UNIT (tem
)
1943 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
1944 TYPE_SIZE_UNIT (tem
));
1946 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
1947 tem
, NULL
, !Comes_From_Source (gnat_entity
),
1948 debug_info_p
, gnat_entity
);
1950 /* Give the fat pointer type a name. */
1951 create_type_decl (create_concat_name (gnat_entity
, "XUP"),
1952 gnu_fat_type
, NULL
, !Comes_From_Source (gnat_entity
),
1953 debug_info_p
, gnat_entity
);
1955 /* Create the type to be used as what a thin pointer designates: an
1956 record type for the object and its template with the field offsets
1957 shifted to have the template at a negative offset. */
1958 tem
= build_unc_object_type (gnu_template_type
, tem
,
1959 create_concat_name (gnat_entity
, "XUT"));
1960 shift_unc_components_for_thin_pointers (tem
);
1962 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
1963 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
1965 /* Give the thin pointer type a name. */
1966 create_type_decl (create_concat_name (gnat_entity
, "XUX"),
1967 build_pointer_type (tem
), NULL
,
1968 !Comes_From_Source (gnat_entity
), debug_info_p
,
1973 case E_String_Subtype
:
1974 case E_Array_Subtype
:
1976 /* This is the actual data type for array variables. Multidimensional
1977 arrays are implemented in the gnu tree as arrays of arrays. Note
1978 that for the moment arrays which have sparse enumeration subtypes as
1979 index components create sparse arrays, which is obviously space
1980 inefficient but so much easier to code for now.
1982 Also note that the subtype never refers to the unconstrained
1983 array type, which is somewhat at variance with Ada semantics.
1985 First check to see if this is simply a renaming of the array
1986 type. If so, the result is the array type. */
1988 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1989 if (!Is_Constrained (gnat_entity
))
1994 int array_dim
= Number_Dimensions (gnat_entity
);
1996 = ((Convention (gnat_entity
) == Convention_Fortran
)
1997 ? array_dim
- 1 : 0);
1999 = (Convention (gnat_entity
) == Convention_Fortran
) ? -1 : 1;
2000 Entity_Id gnat_ind_subtype
;
2001 Entity_Id gnat_ind_base_subtype
;
2002 tree gnu_base_type
= gnu_type
;
2003 tree
*gnu_index_type
= (tree
*) alloca (array_dim
* sizeof (tree
*));
2004 tree gnu_comp_size
= NULL_TREE
;
2005 tree gnu_max_size
= size_one_node
;
2006 tree gnu_max_size_unit
;
2007 bool need_index_type_struct
= false;
2008 bool max_overflow
= false;
2010 /* First create the gnu types for each index. Create types for
2011 debugging information to point to the index types if the
2012 are not integer types, have variable bounds, or are
2013 wider than sizetype. */
2015 for (index
= first_dim
, gnat_ind_subtype
= First_Index (gnat_entity
),
2016 gnat_ind_base_subtype
2017 = First_Index (Implementation_Base_Type (gnat_entity
));
2018 index
< array_dim
&& index
>= 0;
2020 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
2021 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
2023 tree gnu_index_subtype
2024 = get_unpadded_type (Etype (gnat_ind_subtype
));
2026 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_subtype
));
2028 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_subtype
));
2029 tree gnu_base_subtype
2030 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
2032 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
2034 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
2035 tree gnu_base_type
= get_base_type (gnu_base_subtype
);
2036 tree gnu_base_base_min
2037 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_type
));
2038 tree gnu_base_base_max
2039 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_type
));
2043 /* If the minimum and maximum values both overflow in
2044 SIZETYPE, but the difference in the original type
2045 does not overflow in SIZETYPE, ignore the overflow
2047 if ((TYPE_PRECISION (gnu_index_subtype
)
2048 > TYPE_PRECISION (sizetype
)
2049 || TYPE_UNSIGNED (gnu_index_subtype
)
2050 != TYPE_UNSIGNED (sizetype
))
2051 && TREE_CODE (gnu_min
) == INTEGER_CST
2052 && TREE_CODE (gnu_max
) == INTEGER_CST
2053 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
2055 (fold_build2 (MINUS_EXPR
, gnu_index_subtype
,
2056 TYPE_MAX_VALUE (gnu_index_subtype
),
2057 TYPE_MIN_VALUE (gnu_index_subtype
)))))
2059 TREE_OVERFLOW (gnu_min
) = 0;
2060 TREE_OVERFLOW (gnu_max
) = 0;
2063 /* Similarly, if the range is null, use bounds of 1..0 for
2064 the sizetype bounds. */
2065 else if ((TYPE_PRECISION (gnu_index_subtype
)
2066 > TYPE_PRECISION (sizetype
)
2067 || TYPE_UNSIGNED (gnu_index_subtype
)
2068 != TYPE_UNSIGNED (sizetype
))
2069 && TREE_CODE (gnu_min
) == INTEGER_CST
2070 && TREE_CODE (gnu_max
) == INTEGER_CST
2071 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
2072 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype
),
2073 TYPE_MIN_VALUE (gnu_index_subtype
)))
2074 gnu_min
= size_one_node
, gnu_max
= size_zero_node
;
2076 /* Now compute the size of this bound. We need to provide
2077 GCC with an upper bound to use but have to deal with the
2078 "superflat" case. There are three ways to do this. If we
2079 can prove that the array can never be superflat, we can
2080 just use the high bound of the index subtype. If we can
2081 prove that the low bound minus one can't overflow, we
2082 can do this as MAX (hb, lb - 1). Otherwise, we have to use
2083 the expression hb >= lb ? hb : lb - 1. */
2084 gnu_high
= size_binop (MINUS_EXPR
, gnu_min
, size_one_node
);
2086 /* See if the base array type is already flat. If it is, we
2087 are probably compiling an ACVC test, but it will cause the
2088 code below to malfunction if we don't handle it specially. */
2089 if (TREE_CODE (gnu_base_min
) == INTEGER_CST
2090 && TREE_CODE (gnu_base_max
) == INTEGER_CST
2091 && !TREE_OVERFLOW (gnu_base_min
)
2092 && !TREE_OVERFLOW (gnu_base_max
)
2093 && tree_int_cst_lt (gnu_base_max
, gnu_base_min
))
2094 gnu_high
= size_zero_node
, gnu_min
= size_one_node
;
2096 /* If gnu_high is now an integer which overflowed, the array
2097 cannot be superflat. */
2098 else if (TREE_CODE (gnu_high
) == INTEGER_CST
2099 && TREE_OVERFLOW (gnu_high
))
2101 else if (TYPE_UNSIGNED (gnu_base_subtype
)
2102 || TREE_CODE (gnu_high
) == INTEGER_CST
)
2103 gnu_high
= size_binop (MAX_EXPR
, gnu_max
, gnu_high
);
2107 (sizetype
, build_binary_op (GE_EXPR
, integer_type_node
,
2111 gnu_index_type
[index
]
2112 = create_index_type (gnu_min
, gnu_high
, gnu_index_subtype
,
2115 /* Also compute the maximum size of the array. Here we
2116 see if any constraint on the index type of the base type
2117 can be used in the case of self-referential bound on
2118 the index type of the subtype. We look for a non-"infinite"
2119 and non-self-referential bound from any type involved and
2120 handle each bound separately. */
2122 if ((TREE_CODE (gnu_min
) == INTEGER_CST
2123 && !TREE_OVERFLOW (gnu_min
)
2124 && !operand_equal_p (gnu_min
, gnu_base_base_min
, 0))
2125 || !CONTAINS_PLACEHOLDER_P (gnu_min
)
2126 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
2127 && !TREE_OVERFLOW (gnu_base_min
)))
2128 gnu_base_min
= gnu_min
;
2130 if ((TREE_CODE (gnu_max
) == INTEGER_CST
2131 && !TREE_OVERFLOW (gnu_max
)
2132 && !operand_equal_p (gnu_max
, gnu_base_base_max
, 0))
2133 || !CONTAINS_PLACEHOLDER_P (gnu_max
)
2134 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
2135 && !TREE_OVERFLOW (gnu_base_max
)))
2136 gnu_base_max
= gnu_max
;
2138 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
2139 && TREE_OVERFLOW (gnu_base_min
))
2140 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
2141 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
2142 && TREE_OVERFLOW (gnu_base_max
))
2143 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
2144 max_overflow
= true;
2146 gnu_base_min
= size_binop (MAX_EXPR
, gnu_base_min
, gnu_min
);
2147 gnu_base_max
= size_binop (MIN_EXPR
, gnu_base_max
, gnu_max
);
2150 = size_binop (MAX_EXPR
,
2151 size_binop (PLUS_EXPR
, size_one_node
,
2152 size_binop (MINUS_EXPR
, gnu_base_max
,
2156 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2157 && TREE_OVERFLOW (gnu_this_max
))
2158 max_overflow
= true;
2161 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2163 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype
))
2164 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype
))
2166 || TREE_CODE (gnu_index_subtype
) != INTEGER_TYPE
2167 || (TREE_TYPE (gnu_index_subtype
)
2168 && (TREE_CODE (TREE_TYPE (gnu_index_subtype
))
2170 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype
)
2171 || (TYPE_PRECISION (gnu_index_subtype
)
2172 > TYPE_PRECISION (sizetype
)))
2173 need_index_type_struct
= true;
2176 /* Then flatten: create the array of arrays. For an array type
2177 used to implement a packed array, get the component type from
2178 the original array type since the representation clauses that
2179 can affect it are on the latter. */
2180 if (Is_Packed_Array_Type (gnat_entity
)
2181 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)))
2183 gnu_type
= gnat_to_gnu_type (Original_Array_Type (gnat_entity
));
2184 for (index
= array_dim
- 1; index
>= 0; index
--)
2185 gnu_type
= TREE_TYPE (gnu_type
);
2187 /* One of the above calls might have caused us to be elaborated,
2188 so don't blow up if so. */
2189 if (present_gnu_tree (gnat_entity
))
2191 maybe_present
= true;
2197 gnu_type
= gnat_to_gnu_type (Component_Type (gnat_entity
));
2199 /* One of the above calls might have caused us to be elaborated,
2200 so don't blow up if so. */
2201 if (present_gnu_tree (gnat_entity
))
2203 maybe_present
= true;
2207 /* Try to get a smaller form of the component if needed. */
2208 if ((Is_Packed (gnat_entity
)
2209 || Has_Component_Size_Clause (gnat_entity
))
2210 && !Is_Bit_Packed_Array (gnat_entity
)
2211 && !Has_Aliased_Components (gnat_entity
)
2212 && !Strict_Alignment (Component_Type (gnat_entity
))
2213 && TREE_CODE (gnu_type
) == RECORD_TYPE
2214 && host_integerp (TYPE_SIZE (gnu_type
), 1))
2215 gnu_type
= make_packable_type (gnu_type
, false);
2217 /* Get and validate any specified Component_Size, but if Packed,
2218 ignore it since the front end will have taken care of it. */
2220 = validate_size (Component_Size (gnat_entity
), gnu_type
,
2222 (Is_Bit_Packed_Array (gnat_entity
)
2223 ? TYPE_DECL
: VAR_DECL
), true,
2224 Has_Component_Size_Clause (gnat_entity
));
2226 /* If the component type is a RECORD_TYPE that has a
2227 self-referential size, use the maxium size. */
2229 && TREE_CODE (gnu_type
) == RECORD_TYPE
2230 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2231 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
2233 if (gnu_comp_size
&& !Is_Bit_Packed_Array (gnat_entity
))
2237 = make_type_from_size (gnu_type
, gnu_comp_size
, false);
2238 orig_gnu_type
= gnu_type
;
2239 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0,
2240 gnat_entity
, "C_PAD", false,
2242 /* If a padding record was made, declare it now since it
2243 will never be declared otherwise. This is necessary
2244 to ensure that its subtrees are properly marked. */
2245 if (gnu_type
!= orig_gnu_type
)
2246 create_type_decl (TYPE_NAME (gnu_type
), gnu_type
, NULL
,
2247 true, false, gnat_entity
);
2250 if (Has_Volatile_Components (Base_Type (gnat_entity
)))
2251 gnu_type
= build_qualified_type (gnu_type
,
2252 (TYPE_QUALS (gnu_type
)
2253 | TYPE_QUAL_VOLATILE
));
2256 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2257 TYPE_SIZE_UNIT (gnu_type
));
2258 gnu_max_size
= size_binop (MULT_EXPR
,
2259 convert (bitsizetype
, gnu_max_size
),
2260 TYPE_SIZE (gnu_type
));
2262 for (index
= array_dim
- 1; index
>= 0; index
--)
2264 gnu_type
= build_array_type (gnu_type
, gnu_index_type
[index
]);
2265 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2266 if (array_type_has_nonaliased_component (gnat_entity
, gnu_type
))
2267 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2270 /* If we are at file level and this is a multi-dimensional array, we
2271 need to make a variable corresponding to the stride of the
2272 inner dimensions. */
2273 if (global_bindings_p () && array_dim
> 1)
2275 tree gnu_str_name
= get_identifier ("ST");
2278 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2279 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2280 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2281 gnu_str_name
= concat_id_with_name (gnu_str_name
, "ST"))
2283 tree eltype
= TREE_TYPE (gnu_arr_type
);
2285 TYPE_SIZE (gnu_arr_type
)
2286 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
2287 TYPE_SIZE (gnu_arr_type
),
2288 gnu_str_name
, definition
, 0);
2290 /* ??? For now, store the size as a multiple of the
2291 alignment of the element type in bytes so that we
2292 can see the alignment from the tree. */
2293 TYPE_SIZE_UNIT (gnu_arr_type
)
2295 (MULT_EXPR
, sizetype
,
2296 elaborate_expression_1
2297 (gnat_entity
, gnat_entity
,
2298 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
2299 TYPE_SIZE_UNIT (gnu_arr_type
),
2300 size_int (TYPE_ALIGN (eltype
)
2302 concat_id_with_name (gnu_str_name
, "A_U"),
2304 size_int (TYPE_ALIGN (eltype
) / BITS_PER_UNIT
));
2306 /* ??? create_type_decl is not invoked on the inner types so
2307 the MULT_EXPR node built above will never be marked. */
2308 TREE_VISITED (TYPE_SIZE_UNIT (gnu_arr_type
)) = 1;
2312 /* If we need to write out a record type giving the names of
2313 the bounds, do it now. */
2314 if (need_index_type_struct
&& debug_info_p
)
2316 tree gnu_bound_rec_type
= make_node (RECORD_TYPE
);
2317 tree gnu_field_list
= NULL_TREE
;
2320 TYPE_NAME (gnu_bound_rec_type
)
2321 = create_concat_name (gnat_entity
, "XA");
2323 for (index
= array_dim
- 1; index
>= 0; index
--)
2326 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type
[index
]));
2328 if (TREE_CODE (gnu_type_name
) == TYPE_DECL
)
2329 gnu_type_name
= DECL_NAME (gnu_type_name
);
2331 gnu_field
= create_field_decl (gnu_type_name
,
2334 0, NULL_TREE
, NULL_TREE
, 0);
2335 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2336 gnu_field_list
= gnu_field
;
2339 finish_record_type (gnu_bound_rec_type
, gnu_field_list
,
2343 TYPE_CONVENTION_FORTRAN_P (gnu_type
)
2344 = (Convention (gnat_entity
) == Convention_Fortran
);
2345 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2346 = (Is_Packed_Array_Type (gnat_entity
)
2347 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity
)));
2349 /* If our size depends on a placeholder and the maximum size doesn't
2350 overflow, use it. */
2351 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2352 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2353 && TREE_OVERFLOW (gnu_max_size
))
2354 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2355 && TREE_OVERFLOW (gnu_max_size_unit
))
2358 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2359 TYPE_SIZE (gnu_type
));
2360 TYPE_SIZE_UNIT (gnu_type
)
2361 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2362 TYPE_SIZE_UNIT (gnu_type
));
2365 /* Set our alias set to that of our base type. This gives all
2366 array subtypes the same alias set. */
2367 copy_alias_set (gnu_type
, gnu_base_type
);
2370 /* If this is a packed type, make this type the same as the packed
2371 array type, but do some adjusting in the type first. */
2373 if (Present (Packed_Array_Type (gnat_entity
)))
2375 Entity_Id gnat_index
;
2376 tree gnu_inner_type
;
2378 /* First finish the type we had been making so that we output
2379 debugging information for it */
2381 = build_qualified_type (gnu_type
,
2382 (TYPE_QUALS (gnu_type
)
2383 | (TYPE_QUAL_VOLATILE
2384 * Treat_As_Volatile (gnat_entity
))));
2385 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2386 !Comes_From_Source (gnat_entity
),
2387 debug_info_p
, gnat_entity
);
2388 if (!Comes_From_Source (gnat_entity
))
2389 DECL_ARTIFICIAL (gnu_decl
) = 1;
2391 /* Save it as our equivalent in case the call below elaborates
2393 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2395 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2397 this_made_decl
= true;
2398 gnu_type
= TREE_TYPE (gnu_decl
);
2399 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2401 gnu_inner_type
= gnu_type
;
2402 while (TREE_CODE (gnu_inner_type
) == RECORD_TYPE
2403 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type
)
2404 || TYPE_IS_PADDING_P (gnu_inner_type
)))
2405 gnu_inner_type
= TREE_TYPE (TYPE_FIELDS (gnu_inner_type
));
2407 /* We need to point the type we just made to our index type so
2408 the actual bounds can be put into a template. */
2410 if ((TREE_CODE (gnu_inner_type
) == ARRAY_TYPE
2411 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type
))
2412 || (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
2413 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
)))
2415 if (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
)
2417 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2418 If it is, we need to make another type. */
2419 if (TYPE_MODULAR_P (gnu_inner_type
))
2423 gnu_subtype
= make_node (INTEGER_TYPE
);
2425 TREE_TYPE (gnu_subtype
) = gnu_inner_type
;
2426 TYPE_MIN_VALUE (gnu_subtype
)
2427 = TYPE_MIN_VALUE (gnu_inner_type
);
2428 TYPE_MAX_VALUE (gnu_subtype
)
2429 = TYPE_MAX_VALUE (gnu_inner_type
);
2430 TYPE_PRECISION (gnu_subtype
)
2431 = TYPE_PRECISION (gnu_inner_type
);
2432 TYPE_UNSIGNED (gnu_subtype
)
2433 = TYPE_UNSIGNED (gnu_inner_type
);
2434 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2435 layout_type (gnu_subtype
);
2437 gnu_inner_type
= gnu_subtype
;
2440 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
) = 1;
2443 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type
, NULL_TREE
);
2445 for (gnat_index
= First_Index (gnat_entity
);
2446 Present (gnat_index
); gnat_index
= Next_Index (gnat_index
))
2447 SET_TYPE_ACTUAL_BOUNDS
2449 tree_cons (NULL_TREE
,
2450 get_unpadded_type (Etype (gnat_index
)),
2451 TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2453 if (Convention (gnat_entity
) != Convention_Fortran
)
2454 SET_TYPE_ACTUAL_BOUNDS
2456 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2458 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2459 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2460 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner_type
;
2464 /* Abort if packed array with no packed array type field set. */
2466 gcc_assert (!Is_Packed (gnat_entity
));
2470 case E_String_Literal_Subtype
:
2471 /* Create the type for a string literal. */
2473 Entity_Id gnat_full_type
2474 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2475 && Present (Full_View (Etype (gnat_entity
)))
2476 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2477 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2478 tree gnu_string_array_type
2479 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2480 tree gnu_string_index_type
2481 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2482 (TYPE_DOMAIN (gnu_string_array_type
))));
2483 tree gnu_lower_bound
2484 = convert (gnu_string_index_type
,
2485 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2486 int length
= UI_To_Int (String_Literal_Length (gnat_entity
));
2487 tree gnu_length
= ssize_int (length
- 1);
2488 tree gnu_upper_bound
2489 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2491 convert (gnu_string_index_type
, gnu_length
));
2493 = build_range_type (gnu_string_index_type
,
2494 gnu_lower_bound
, gnu_upper_bound
);
2496 = create_index_type (convert (sizetype
,
2497 TYPE_MIN_VALUE (gnu_range_type
)),
2499 TYPE_MAX_VALUE (gnu_range_type
)),
2500 gnu_range_type
, gnat_entity
);
2503 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity
)),
2505 copy_alias_set (gnu_type
, gnu_string_type
);
2509 /* Record Types and Subtypes
2511 The following fields are defined on record types:
2513 Has_Discriminants True if the record has discriminants
2514 First_Discriminant Points to head of list of discriminants
2515 First_Entity Points to head of list of fields
2516 Is_Tagged_Type True if the record is tagged
2518 Implementation of Ada records and discriminated records:
2520 A record type definition is transformed into the equivalent of a C
2521 struct definition. The fields that are the discriminants which are
2522 found in the Full_Type_Declaration node and the elements of the
2523 Component_List found in the Record_Type_Definition node. The
2524 Component_List can be a recursive structure since each Variant of
2525 the Variant_Part of the Component_List has a Component_List.
2527 Processing of a record type definition comprises starting the list of
2528 field declarations here from the discriminants and the calling the
2529 function components_to_record to add the rest of the fields from the
2530 component list and return the gnu type node. The function
2531 components_to_record will call itself recursively as it traverses
2535 if (Has_Complex_Representation (gnat_entity
))
2538 = build_complex_type
2540 (Etype (Defining_Entity
2541 (First (Component_Items
2544 (Declaration_Node (gnat_entity
)))))))));
2550 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2551 Node_Id record_definition
= Type_Definition (full_definition
);
2552 Entity_Id gnat_field
;
2554 tree gnu_field_list
= NULL_TREE
;
2555 tree gnu_get_parent
;
2556 /* Set PACKED in keeping with gnat_to_gnu_field. */
2558 = Is_Packed (gnat_entity
)
2560 : Component_Alignment (gnat_entity
) == Calign_Storage_Unit
2562 : (Known_Alignment (gnat_entity
)
2563 || (Strict_Alignment (gnat_entity
)
2564 && Known_Static_Esize (gnat_entity
)))
2567 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2568 bool all_rep
= has_rep
;
2570 = (Is_Tagged_Type (gnat_entity
)
2571 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2573 /* See if all fields have a rep clause. Stop when we find one
2575 for (gnat_field
= First_Entity (gnat_entity
);
2576 Present (gnat_field
) && all_rep
;
2577 gnat_field
= Next_Entity (gnat_field
))
2578 if ((Ekind (gnat_field
) == E_Component
2579 || Ekind (gnat_field
) == E_Discriminant
)
2580 && No (Component_Clause (gnat_field
)))
2583 /* If this is a record extension, go a level further to find the
2584 record definition. Also, verify we have a Parent_Subtype. */
2587 if (!type_annotate_only
2588 || Present (Record_Extension_Part (record_definition
)))
2589 record_definition
= Record_Extension_Part (record_definition
);
2591 gcc_assert (type_annotate_only
2592 || Present (Parent_Subtype (gnat_entity
)));
2595 /* Make a node for the record. If we are not defining the record,
2596 suppress expanding incomplete types. */
2597 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2598 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2599 TYPE_PACKED (gnu_type
) = (packed
!= 0) || has_rep
;
2602 defer_incomplete_level
++, this_deferred
= true;
2604 /* If both a size and rep clause was specified, put the size in
2605 the record type now so that it can get the proper mode. */
2606 if (has_rep
&& Known_Esize (gnat_entity
))
2607 TYPE_SIZE (gnu_type
) = UI_To_gnu (Esize (gnat_entity
), sizetype
);
2609 /* Always set the alignment here so that it can be used to
2610 set the mode, if it is making the alignment stricter. If
2611 it is invalid, it will be checked again below. If this is to
2612 be Atomic, choose a default alignment of a word unless we know
2613 the size and it's smaller. */
2614 if (Known_Alignment (gnat_entity
))
2615 TYPE_ALIGN (gnu_type
)
2616 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2617 else if (Is_Atomic (gnat_entity
))
2618 TYPE_ALIGN (gnu_type
)
2619 = esize
>= BITS_PER_WORD
? BITS_PER_WORD
: ceil_alignment (esize
);
2620 /* If a type needs strict alignment, the minimum size will be the
2621 type size instead of the RM size (see validate_size). Cap the
2622 alignment, lest it causes this type size to become too large. */
2623 else if (Strict_Alignment (gnat_entity
)
2624 && Known_Static_Esize (gnat_entity
))
2626 unsigned int raw_size
= UI_To_Int (Esize (gnat_entity
));
2627 unsigned int raw_align
= raw_size
& -raw_size
;
2628 if (raw_align
< BIGGEST_ALIGNMENT
)
2629 TYPE_ALIGN (gnu_type
) = raw_align
;
2632 TYPE_ALIGN (gnu_type
) = 0;
2634 /* If we have a Parent_Subtype, make a field for the parent. If
2635 this record has rep clauses, force the position to zero. */
2636 if (Present (Parent_Subtype (gnat_entity
)))
2638 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
2641 /* A major complexity here is that the parent subtype will
2642 reference our discriminants in its Discriminant_Constraint
2643 list. But those must reference the parent component of this
2644 record which is of the parent subtype we have not built yet!
2645 To break the circle we first build a dummy COMPONENT_REF which
2646 represents the "get to the parent" operation and initialize
2647 each of those discriminants to a COMPONENT_REF of the above
2648 dummy parent referencing the corresponding discriminant of the
2649 base type of the parent subtype. */
2650 gnu_get_parent
= build3 (COMPONENT_REF
, void_type_node
,
2651 build0 (PLACEHOLDER_EXPR
, gnu_type
),
2652 build_decl (FIELD_DECL
, NULL_TREE
,
2656 if (Has_Discriminants (gnat_entity
))
2657 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2658 Present (gnat_field
);
2659 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2660 if (Present (Corresponding_Discriminant (gnat_field
)))
2663 build3 (COMPONENT_REF
,
2664 get_unpadded_type (Etype (gnat_field
)),
2666 gnat_to_gnu_field_decl (Corresponding_Discriminant
2671 /* Then we build the parent subtype. */
2672 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
2674 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2675 initially built. The discriminants must reference the fields
2676 of the parent subtype and not those of its base type for the
2677 placeholder machinery to properly work. */
2678 if (Has_Discriminants (gnat_entity
))
2679 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2680 Present (gnat_field
);
2681 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2682 if (Present (Corresponding_Discriminant (gnat_field
)))
2684 Entity_Id field
= Empty
;
2685 for (field
= First_Stored_Discriminant (gnat_parent
);
2687 field
= Next_Stored_Discriminant (field
))
2688 if (same_discriminant_p (gnat_field
, field
))
2690 gcc_assert (Present (field
));
2691 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
2692 = gnat_to_gnu_field_decl (field
);
2695 /* The "get to the parent" COMPONENT_REF must be given its
2697 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
2699 /* ...and reference the _parent field of this record. */
2701 = create_field_decl (get_identifier
2702 (Get_Name_String (Name_uParent
)),
2703 gnu_parent
, gnu_type
, 0,
2704 has_rep
? TYPE_SIZE (gnu_parent
) : 0,
2705 has_rep
? bitsize_zero_node
: 0, 1);
2706 DECL_INTERNAL_P (gnu_field_list
) = 1;
2707 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field_list
;
2710 /* Make the fields for the discriminants and put them into the record
2711 unless it's an Unchecked_Union. */
2712 if (Has_Discriminants (gnat_entity
))
2713 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2714 Present (gnat_field
);
2715 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2717 /* If this is a record extension and this discriminant
2718 is the renaming of another discriminant, we've already
2719 handled the discriminant above. */
2720 if (Present (Parent_Subtype (gnat_entity
))
2721 && Present (Corresponding_Discriminant (gnat_field
)))
2725 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
);
2727 /* Make an expression using a PLACEHOLDER_EXPR from the
2728 FIELD_DECL node just created and link that with the
2729 corresponding GNAT defining identifier. Then add to the
2731 save_gnu_tree (gnat_field
,
2732 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2733 build0 (PLACEHOLDER_EXPR
,
2734 DECL_CONTEXT (gnu_field
)),
2735 gnu_field
, NULL_TREE
),
2738 if (!Is_Unchecked_Union (gnat_entity
))
2740 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2741 gnu_field_list
= gnu_field
;
2745 /* Put the discriminants into the record (backwards), so we can
2746 know the appropriate discriminant to use for the names of the
2748 TYPE_FIELDS (gnu_type
) = gnu_field_list
;
2750 /* Add the listed fields into the record and finish it up. */
2751 components_to_record (gnu_type
, Component_List (record_definition
),
2752 gnu_field_list
, packed
, definition
, NULL
,
2753 false, all_rep
, false,
2754 Is_Unchecked_Union (gnat_entity
));
2756 /* We used to remove the associations of the discriminants and
2757 _Parent for validity checking, but we may need them if there's
2758 Freeze_Node for a subtype used in this record. */
2759 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2760 TYPE_BY_REFERENCE_P (gnu_type
) = Is_By_Reference_Type (gnat_entity
);
2762 /* If it is a tagged record force the type to BLKmode to insure
2763 that these objects will always be placed in memory. Do the
2764 same thing for limited record types. */
2765 if (Is_Tagged_Type (gnat_entity
) || Is_Limited_Record (gnat_entity
))
2766 TYPE_MODE (gnu_type
) = BLKmode
;
2768 /* If this is a derived type, we must make the alias set of this type
2769 the same as that of the type we are derived from. We assume here
2770 that the other type is already frozen. */
2771 if (Etype (gnat_entity
) != gnat_entity
2772 && !(Is_Private_Type (Etype (gnat_entity
))
2773 && Full_View (Etype (gnat_entity
)) == gnat_entity
))
2774 copy_alias_set (gnu_type
, gnat_to_gnu_type (Etype (gnat_entity
)));
2776 /* Fill in locations of fields. */
2777 annotate_rep (gnat_entity
, gnu_type
);
2779 /* If there are any entities in the chain corresponding to
2780 components that we did not elaborate, ensure we elaborate their
2781 types if they are Itypes. */
2782 for (gnat_temp
= First_Entity (gnat_entity
);
2783 Present (gnat_temp
); gnat_temp
= Next_Entity (gnat_temp
))
2784 if ((Ekind (gnat_temp
) == E_Component
2785 || Ekind (gnat_temp
) == E_Discriminant
)
2786 && Is_Itype (Etype (gnat_temp
))
2787 && !present_gnu_tree (gnat_temp
))
2788 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2792 case E_Class_Wide_Subtype
:
2793 /* If an equivalent type is present, that is what we should use.
2794 Otherwise, fall through to handle this like a record subtype
2795 since it may have constraints. */
2796 if (gnat_equiv_type
!= gnat_entity
)
2798 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
2799 maybe_present
= true;
2803 /* ... fall through ... */
2805 case E_Record_Subtype
:
2807 /* If Cloned_Subtype is Present it means this record subtype has
2808 identical layout to that type or subtype and we should use
2809 that GCC type for this one. The front end guarantees that
2810 the component list is shared. */
2811 if (Present (Cloned_Subtype (gnat_entity
)))
2813 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
2815 maybe_present
= true;
2818 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2819 changing the type, make a new type with each field having the
2820 type of the field in the new subtype but having the position
2821 computed by transforming every discriminant reference according
2822 to the constraints. We don't see any difference between
2823 private and nonprivate type here since derivations from types should
2824 have been deferred until the completion of the private type. */
2827 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
2832 defer_incomplete_level
++, this_deferred
= true;
2834 /* Get the base type initially for its alignment and sizes. But
2835 if it is a padded type, we do all the other work with the
2837 gnu_base_type
= gnat_to_gnu_type (gnat_base_type
);
2839 if (TREE_CODE (gnu_base_type
) == RECORD_TYPE
2840 && TYPE_IS_PADDING_P (gnu_base_type
))
2841 gnu_type
= gnu_orig_type
= TREE_TYPE (TYPE_FIELDS (gnu_base_type
));
2843 gnu_type
= gnu_orig_type
= gnu_base_type
;
2845 if (present_gnu_tree (gnat_entity
))
2847 maybe_present
= true;
2851 /* When the type has discriminants, and these discriminants
2852 affect the shape of what it built, factor them in.
2854 If we are making a subtype of an Unchecked_Union (must be an
2855 Itype), just return the type.
2857 We can't just use Is_Constrained because private subtypes without
2858 discriminants of full types with discriminants with default
2859 expressions are Is_Constrained but aren't constrained! */
2861 if (IN (Ekind (gnat_base_type
), Record_Kind
)
2862 && !Is_For_Access_Subtype (gnat_entity
)
2863 && !Is_Unchecked_Union (gnat_base_type
)
2864 && Is_Constrained (gnat_entity
)
2865 && Stored_Constraint (gnat_entity
) != No_Elist
2866 && Present (Discriminant_Constraint (gnat_entity
)))
2868 Entity_Id gnat_field
;
2869 tree gnu_field_list
= 0;
2871 = compute_field_positions (gnu_orig_type
, NULL_TREE
,
2872 size_zero_node
, bitsize_zero_node
,
2875 = substitution_list (gnat_entity
, gnat_base_type
, NULL_TREE
,
2879 gnu_type
= make_node (RECORD_TYPE
);
2880 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2881 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2882 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2884 for (gnat_field
= First_Entity (gnat_entity
);
2885 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2886 if ((Ekind (gnat_field
) == E_Component
2887 || Ekind (gnat_field
) == E_Discriminant
)
2888 && (Underlying_Type (Scope (Original_Record_Component
2891 && (No (Corresponding_Discriminant (gnat_field
))
2892 || !Is_Tagged_Type (gnat_base_type
)))
2895 = gnat_to_gnu_field_decl (Original_Record_Component
2898 = TREE_VALUE (purpose_member (gnu_old_field
,
2900 tree gnu_pos
= TREE_PURPOSE (gnu_offset
);
2901 tree gnu_bitpos
= TREE_VALUE (TREE_VALUE (gnu_offset
));
2903 = gnat_to_gnu_type (Etype (gnat_field
));
2904 tree gnu_size
= TYPE_SIZE (gnu_field_type
);
2905 tree gnu_new_pos
= 0;
2906 unsigned int offset_align
2907 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset
)),
2911 /* If there was a component clause, the field types must be
2912 the same for the type and subtype, so copy the data from
2913 the old field to avoid recomputation here. Also if the
2914 field is justified modular and the optimization in
2915 gnat_to_gnu_field was applied. */
2916 if (Present (Component_Clause
2917 (Original_Record_Component (gnat_field
)))
2918 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
2919 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
2920 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
2921 == TREE_TYPE (gnu_old_field
)))
2923 gnu_size
= DECL_SIZE (gnu_old_field
);
2924 gnu_field_type
= TREE_TYPE (gnu_old_field
);
2927 /* If the old field was packed and of constant size, we
2928 have to get the old size here, as it might differ from
2929 what the Etype conveys and the latter might overlap
2930 onto the following field. Try to arrange the type for
2931 possible better packing along the way. */
2932 else if (DECL_PACKED (gnu_old_field
)
2933 && TREE_CODE (DECL_SIZE (gnu_old_field
))
2936 gnu_size
= DECL_SIZE (gnu_old_field
);
2937 if (TYPE_MODE (gnu_field_type
) == BLKmode
2938 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
2939 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
2941 = make_packable_type (gnu_field_type
, true);
2944 if (CONTAINS_PLACEHOLDER_P (gnu_pos
))
2945 for (gnu_temp
= gnu_subst_list
;
2946 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2947 gnu_pos
= substitute_in_expr (gnu_pos
,
2948 TREE_PURPOSE (gnu_temp
),
2949 TREE_VALUE (gnu_temp
));
2951 /* If the size is now a constant, we can set it as the
2952 size of the field when we make it. Otherwise, we need
2953 to deal with it specially. */
2954 if (TREE_CONSTANT (gnu_pos
))
2955 gnu_new_pos
= bit_from_pos (gnu_pos
, gnu_bitpos
);
2959 (DECL_NAME (gnu_old_field
), gnu_field_type
, gnu_type
,
2960 DECL_PACKED (gnu_old_field
), gnu_size
, gnu_new_pos
,
2961 !DECL_NONADDRESSABLE_P (gnu_old_field
));
2963 if (!TREE_CONSTANT (gnu_pos
))
2965 normalize_offset (&gnu_pos
, &gnu_bitpos
, offset_align
);
2966 DECL_FIELD_OFFSET (gnu_field
) = gnu_pos
;
2967 DECL_FIELD_BIT_OFFSET (gnu_field
) = gnu_bitpos
;
2968 SET_DECL_OFFSET_ALIGN (gnu_field
, offset_align
);
2969 DECL_SIZE (gnu_field
) = gnu_size
;
2970 DECL_SIZE_UNIT (gnu_field
)
2971 = convert (sizetype
,
2972 size_binop (CEIL_DIV_EXPR
, gnu_size
,
2973 bitsize_unit_node
));
2974 layout_decl (gnu_field
, DECL_OFFSET_ALIGN (gnu_field
));
2977 DECL_INTERNAL_P (gnu_field
)
2978 = DECL_INTERNAL_P (gnu_old_field
);
2979 SET_DECL_ORIGINAL_FIELD
2980 (gnu_field
, (DECL_ORIGINAL_FIELD (gnu_old_field
)
2981 ? DECL_ORIGINAL_FIELD (gnu_old_field
)
2983 DECL_DISCRIMINANT_NUMBER (gnu_field
)
2984 = DECL_DISCRIMINANT_NUMBER (gnu_old_field
);
2985 TREE_THIS_VOLATILE (gnu_field
)
2986 = TREE_THIS_VOLATILE (gnu_old_field
);
2987 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2988 gnu_field_list
= gnu_field
;
2989 save_gnu_tree (gnat_field
, gnu_field
, false);
2992 /* Now go through the entities again looking for Itypes that
2993 we have not elaborated but should (e.g., Etypes of fields
2994 that have Original_Components). */
2995 for (gnat_field
= First_Entity (gnat_entity
);
2996 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2997 if ((Ekind (gnat_field
) == E_Discriminant
2998 || Ekind (gnat_field
) == E_Component
)
2999 && !present_gnu_tree (Etype (gnat_field
)))
3000 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
3002 /* Do not finalize it since we're going to modify it below. */
3003 finish_record_type (gnu_type
, nreverse (gnu_field_list
),
3006 /* Now set the size, alignment and alias set of the new type to
3007 match that of the old one, doing any substitutions, as
3009 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
3010 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_base_type
);
3011 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_base_type
);
3012 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_ADA_SIZE (gnu_base_type
));
3013 copy_alias_set (gnu_type
, gnu_base_type
);
3015 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
3016 for (gnu_temp
= gnu_subst_list
;
3017 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
3018 TYPE_SIZE (gnu_type
)
3019 = substitute_in_expr (TYPE_SIZE (gnu_type
),
3020 TREE_PURPOSE (gnu_temp
),
3021 TREE_VALUE (gnu_temp
));
3023 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type
)))
3024 for (gnu_temp
= gnu_subst_list
;
3025 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
3026 TYPE_SIZE_UNIT (gnu_type
)
3027 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type
),
3028 TREE_PURPOSE (gnu_temp
),
3029 TREE_VALUE (gnu_temp
));
3031 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type
)))
3032 for (gnu_temp
= gnu_subst_list
;
3033 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
3035 (gnu_type
, substitute_in_expr (TYPE_ADA_SIZE (gnu_type
),
3036 TREE_PURPOSE (gnu_temp
),
3037 TREE_VALUE (gnu_temp
)));
3039 /* Reapply variable_size since we have changed the sizes. */
3040 TYPE_SIZE (gnu_type
) = variable_size (TYPE_SIZE (gnu_type
));
3041 TYPE_SIZE_UNIT (gnu_type
)
3042 = variable_size (TYPE_SIZE_UNIT (gnu_type
));
3044 /* Recompute the mode of this record type now that we know its
3046 compute_record_mode (gnu_type
);
3048 /* Fill in locations of fields. */
3049 annotate_rep (gnat_entity
, gnu_type
);
3051 /* We've built a new type, make an XVS type to show what this
3052 is a subtype of. Some debuggers require the XVS type to be
3053 output first, so do it in that order. */
3056 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
3057 tree gnu_orig_name
= TYPE_NAME (gnu_orig_type
);
3059 if (TREE_CODE (gnu_orig_name
) == TYPE_DECL
)
3060 gnu_orig_name
= DECL_NAME (gnu_orig_name
);
3062 TYPE_NAME (gnu_subtype_marker
)
3063 = create_concat_name (gnat_entity
, "XVS");
3064 finish_record_type (gnu_subtype_marker
,
3065 create_field_decl (gnu_orig_name
,
3073 /* Now we can finalize it. */
3074 rest_of_record_type_compilation (gnu_type
);
3077 /* Otherwise, go down all the components in the new type and
3078 make them equivalent to those in the base type. */
3080 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
3081 gnat_temp
= Next_Entity (gnat_temp
))
3082 if ((Ekind (gnat_temp
) == E_Discriminant
3083 && !Is_Unchecked_Union (gnat_base_type
))
3084 || Ekind (gnat_temp
) == E_Component
)
3085 save_gnu_tree (gnat_temp
,
3086 gnat_to_gnu_field_decl
3087 (Original_Record_Component (gnat_temp
)), false);
3091 case E_Access_Subprogram_Type
:
3092 case E_Anonymous_Access_Subprogram_Type
:
3093 /* If we are not defining this entity, and we have incomplete
3094 entities being processed above us, make a dummy type and
3095 fill it in later. */
3096 if (!definition
&& defer_incomplete_level
!= 0)
3098 struct incomplete
*p
3099 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3102 = build_pointer_type
3103 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3104 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3105 !Comes_From_Source (gnat_entity
),
3106 debug_info_p
, gnat_entity
);
3107 this_made_decl
= true;
3108 gnu_type
= TREE_TYPE (gnu_decl
);
3109 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3112 p
->old_type
= TREE_TYPE (gnu_type
);
3113 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3114 p
->next
= defer_incomplete_list
;
3115 defer_incomplete_list
= p
;
3119 /* ... fall through ... */
3121 case E_Allocator_Type
:
3123 case E_Access_Attribute_Type
:
3124 case E_Anonymous_Access_Type
:
3125 case E_General_Access_Type
:
3127 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
3128 Entity_Id gnat_desig_equiv
= Gigi_Equivalent_Type (gnat_desig_type
);
3129 bool is_from_limited_with
3130 = (IN (Ekind (gnat_desig_equiv
), Incomplete_Kind
)
3131 && From_With_Type (gnat_desig_equiv
));
3133 /* Get the "full view" of this entity. If this is an incomplete
3134 entity from a limited with, treat its non-limited view as the full
3135 view. Otherwise, if this is an incomplete or private type, use the
3136 full view. In the former case, we might point to a private type,
3137 in which case, we need its full view. Also, we want to look at the
3138 actual type used for the representation, so this takes a total of
3140 Entity_Id gnat_desig_full_direct_first
3141 = (is_from_limited_with
? Non_Limited_View (gnat_desig_equiv
)
3142 : (IN (Ekind (gnat_desig_equiv
), Incomplete_Or_Private_Kind
)
3143 ? Full_View (gnat_desig_equiv
) : Empty
));
3144 Entity_Id gnat_desig_full_direct
3145 = ((is_from_limited_with
3146 && Present (gnat_desig_full_direct_first
)
3147 && IN (Ekind (gnat_desig_full_direct_first
), Private_Kind
))
3148 ? Full_View (gnat_desig_full_direct_first
)
3149 : gnat_desig_full_direct_first
);
3150 Entity_Id gnat_desig_full
3151 = Gigi_Equivalent_Type (gnat_desig_full_direct
);
3153 /* This the type actually used to represent the designated type,
3154 either gnat_desig_full or gnat_desig_equiv. */
3155 Entity_Id gnat_desig_rep
;
3157 /* Nonzero if this is a pointer to an unconstrained array. */
3158 bool is_unconstrained_array
;
3160 /* We want to know if we'll be seeing the freeze node for any
3161 incomplete type we may be pointing to. */
3163 = (Present (gnat_desig_full
)
3164 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
3165 : In_Extended_Main_Code_Unit (gnat_desig_type
));
3167 /* Nonzero if we make a dummy type here. */
3168 bool got_fat_p
= false;
3169 /* Nonzero if the dummy is a fat pointer. */
3170 bool made_dummy
= false;
3171 tree gnu_desig_type
= NULL_TREE
;
3172 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
3174 if (!targetm
.valid_pointer_mode (p_mode
))
3177 /* If either the designated type or its full view is an unconstrained
3178 array subtype, replace it with the type it's a subtype of. This
3179 avoids problems with multiple copies of unconstrained array types.
3180 Likewise, if the designated type is a subtype of an incomplete
3181 record type, use the parent type to avoid order of elaboration
3182 issues. This can lose some code efficiency, but there is no
3184 if (Ekind (gnat_desig_equiv
) == E_Array_Subtype
3185 && ! Is_Constrained (gnat_desig_equiv
))
3186 gnat_desig_equiv
= Etype (gnat_desig_equiv
);
3187 if (Present (gnat_desig_full
)
3188 && ((Ekind (gnat_desig_full
) == E_Array_Subtype
3189 && ! Is_Constrained (gnat_desig_full
))
3190 || (Ekind (gnat_desig_full
) == E_Record_Subtype
3191 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)))
3192 gnat_desig_full
= Etype (gnat_desig_full
);
3194 /* Now set the type that actually marks the representation of
3195 the designated type and also flag whether we have a unconstrained
3197 gnat_desig_rep
= gnat_desig_full
? gnat_desig_full
: gnat_desig_equiv
;
3198 is_unconstrained_array
3199 = (Is_Array_Type (gnat_desig_rep
)
3200 && ! Is_Constrained (gnat_desig_rep
));
3202 /* If we are pointing to an incomplete type whose completion is an
3203 unconstrained array, make a fat pointer type. The two types in our
3204 fields will be pointers to dummy nodes and will be replaced in
3205 update_pointer_to. Similarly, if the type itself is a dummy type or
3206 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3207 in case we have any thin pointers to it. */
3208 if (is_unconstrained_array
3209 && (Present (gnat_desig_full
)
3210 || (present_gnu_tree (gnat_desig_equiv
)
3211 && TYPE_IS_DUMMY_P (TREE_TYPE
3212 (get_gnu_tree (gnat_desig_equiv
))))
3213 || (No (gnat_desig_full
) && ! in_main_unit
3214 && defer_incomplete_level
!= 0
3215 && ! present_gnu_tree (gnat_desig_equiv
))
3216 || (in_main_unit
&& is_from_limited_with
3217 && Present (Freeze_Node (gnat_desig_rep
)))))
3220 = (present_gnu_tree (gnat_desig_rep
)
3221 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep
))
3222 : make_dummy_type (gnat_desig_rep
));
3225 /* Show the dummy we get will be a fat pointer. */
3226 got_fat_p
= made_dummy
= true;
3228 /* If the call above got something that has a pointer, that
3229 pointer is our type. This could have happened either
3230 because the type was elaborated or because somebody
3231 else executed the code below. */
3232 gnu_type
= TYPE_POINTER_TO (gnu_old
);
3235 tree gnu_template_type
= make_node (ENUMERAL_TYPE
);
3236 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
3237 tree gnu_array_type
= make_node (ENUMERAL_TYPE
);
3238 tree gnu_ptr_array
= build_pointer_type (gnu_array_type
);
3240 TYPE_NAME (gnu_template_type
)
3241 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3243 TYPE_DUMMY_P (gnu_template_type
) = 1;
3245 TYPE_NAME (gnu_array_type
)
3246 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3248 TYPE_DUMMY_P (gnu_array_type
) = 1;
3250 gnu_type
= make_node (RECORD_TYPE
);
3251 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type
, gnu_old
);
3252 TYPE_POINTER_TO (gnu_old
) = gnu_type
;
3254 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3256 = chainon (chainon (NULL_TREE
,
3258 (get_identifier ("P_ARRAY"),
3260 gnu_type
, 0, 0, 0, 0)),
3261 create_field_decl (get_identifier ("P_BOUNDS"),
3263 gnu_type
, 0, 0, 0, 0));
3265 /* Make sure we can place this into a register. */
3266 TYPE_ALIGN (gnu_type
)
3267 = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
3268 TYPE_IS_FAT_POINTER_P (gnu_type
) = 1;
3270 /* Do not finalize this record type since the types of
3271 its fields are incomplete. */
3272 finish_record_type (gnu_type
, fields
, 0, true);
3274 TYPE_OBJECT_RECORD_TYPE (gnu_old
) = make_node (RECORD_TYPE
);
3275 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old
))
3276 = concat_id_with_name (get_entity_name (gnat_desig_equiv
),
3278 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old
)) = 1;
3282 /* If we already know what the full type is, use it. */
3283 else if (Present (gnat_desig_full
)
3284 && present_gnu_tree (gnat_desig_full
))
3285 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3287 /* Get the type of the thing we are to point to and build a pointer
3288 to it. If it is a reference to an incomplete or private type with a
3289 full view that is a record, make a dummy type node and get the
3290 actual type later when we have verified it is safe. */
3291 else if ((! in_main_unit
3292 && ! present_gnu_tree (gnat_desig_equiv
)
3293 && Present (gnat_desig_full
)
3294 && ! present_gnu_tree (gnat_desig_full
)
3295 && Is_Record_Type (gnat_desig_full
))
3296 /* Likewise if we are pointing to a record or array and we
3297 are to defer elaborating incomplete types. We do this
3298 since this access type may be the full view of some
3299 private type. Note that the unconstrained array case is
3301 || ((! in_main_unit
|| imported_p
)
3302 && defer_incomplete_level
!= 0
3303 && ! present_gnu_tree (gnat_desig_equiv
)
3304 && ((Is_Record_Type (gnat_desig_rep
)
3305 || Is_Array_Type (gnat_desig_rep
))))
3306 /* If this is a reference from a limited_with type back to our
3307 main unit and there's a Freeze_Node for it, either we have
3308 already processed the declaration and made the dummy type,
3309 in which case we just reuse the latter, or we have not yet,
3310 in which case we make the dummy type and it will be reused
3311 when the declaration is processed. In both cases, the
3312 pointer eventually created below will be automatically
3313 adjusted when the Freeze_Node is processed. Note that the
3314 unconstrained array case is handled above. */
3315 || (in_main_unit
&& is_from_limited_with
3316 && Present (Freeze_Node (gnat_desig_rep
))))
3318 gnu_desig_type
= make_dummy_type (gnat_desig_equiv
);
3322 /* Otherwise handle the case of a pointer to itself. */
3323 else if (gnat_desig_equiv
== gnat_entity
)
3326 = build_pointer_type_for_mode (void_type_node
, p_mode
,
3327 No_Strict_Aliasing (gnat_entity
));
3328 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3331 /* If expansion is disabled, the equivalent type of a concurrent
3332 type is absent, so build a dummy pointer type. */
3333 else if (type_annotate_only
&& No (gnat_desig_equiv
))
3334 gnu_type
= ptr_void_type_node
;
3336 /* Finally, handle the straightforward case where we can just
3337 elaborate our designated type and point to it. */
3339 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_equiv
);
3341 /* It is possible that a call to gnat_to_gnu_type above resolved our
3342 type. If so, just return it. */
3343 if (present_gnu_tree (gnat_entity
))
3345 maybe_present
= true;
3349 /* If we have a GCC type for the designated type, possibly modify it
3350 if we are pointing only to constant objects and then make a pointer
3351 to it. Don't do this for unconstrained arrays. */
3352 if (!gnu_type
&& gnu_desig_type
)
3354 if (Is_Access_Constant (gnat_entity
)
3355 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3358 = build_qualified_type
3360 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3362 /* Some extra processing is required if we are building a
3363 pointer to an incomplete type (in the GCC sense). We might
3364 have such a type if we just made a dummy, or directly out
3365 of the call to gnat_to_gnu_type above if we are processing
3366 an access type for a record component designating the
3367 record type itself. */
3368 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3370 /* We must ensure that the pointer to variant we make will
3371 be processed by update_pointer_to when the initial type
3372 is completed. Pretend we made a dummy and let further
3373 processing act as usual. */
3376 /* We must ensure that update_pointer_to will not retrieve
3377 the dummy variant when building a properly qualified
3378 version of the complete type. We take advantage of the
3379 fact that get_qualified_type is requiring TYPE_NAMEs to
3380 match to influence build_qualified_type and then also
3381 update_pointer_to here. */
3382 TYPE_NAME (gnu_desig_type
)
3383 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3388 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3389 No_Strict_Aliasing (gnat_entity
));
3392 /* If we are not defining this object and we made a dummy pointer,
3393 save our current definition, evaluate the actual type, and replace
3394 the tentative type we made with the actual one. If we are to defer
3395 actually looking up the actual type, make an entry in the
3396 deferred list. If this is from a limited with, we have to defer
3397 to the end of the current spec in two cases: first if the
3398 designated type is in the current unit and second if the access
3400 if ((! in_main_unit
|| is_from_limited_with
) && made_dummy
)
3403 = TYPE_FAT_POINTER_P (gnu_type
)
3404 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type
) : TREE_TYPE (gnu_type
);
3406 if (esize
== POINTER_SIZE
3407 && (got_fat_p
|| TYPE_FAT_POINTER_P (gnu_type
)))
3409 = build_pointer_type
3410 (TYPE_OBJECT_RECORD_TYPE
3411 (TYPE_UNCONSTRAINED_ARRAY (gnu_type
)));
3413 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3414 !Comes_From_Source (gnat_entity
),
3415 debug_info_p
, gnat_entity
);
3416 this_made_decl
= true;
3417 gnu_type
= TREE_TYPE (gnu_decl
);
3418 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3421 if (defer_incomplete_level
== 0
3422 && ! (is_from_limited_with
3424 || In_Extended_Main_Code_Unit (gnat_entity
))))
3425 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type
),
3426 gnat_to_gnu_type (gnat_desig_equiv
));
3428 /* Note that the call to gnat_to_gnu_type here might have
3429 updated gnu_old_type directly, in which case it is not a
3430 dummy type any more when we get into update_pointer_to.
3432 This may happen for instance when the designated type is a
3433 record type, because their elaboration starts with an
3434 initial node from make_dummy_type, which may yield the same
3435 node as the one we got.
3437 Besides, variants of this non-dummy type might have been
3438 created along the way. update_pointer_to is expected to
3439 properly take care of those situations. */
3442 struct incomplete
*p
3443 = (struct incomplete
*) xmalloc (sizeof
3444 (struct incomplete
));
3445 struct incomplete
**head
3446 = (is_from_limited_with
3448 || In_Extended_Main_Code_Unit (gnat_entity
))
3449 ? &defer_limited_with
: &defer_incomplete_list
);
3451 p
->old_type
= gnu_old_type
;
3452 p
->full_type
= gnat_desig_equiv
;
3460 case E_Access_Protected_Subprogram_Type
:
3461 case E_Anonymous_Access_Protected_Subprogram_Type
:
3462 if (type_annotate_only
&& No (gnat_equiv_type
))
3463 gnu_type
= ptr_void_type_node
;
3466 /* The runtime representation is the equivalent type. */
3467 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
3471 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3472 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3473 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3474 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3475 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3480 case E_Access_Subtype
:
3482 /* We treat this as identical to its base type; any constraint is
3483 meaningful only to the front end.
3485 The designated type must be elaborated as well, if it does
3486 not have its own freeze node. Designated (sub)types created
3487 for constrained components of records with discriminants are
3488 not frozen by the front end and thus not elaborated by gigi,
3489 because their use may appear before the base type is frozen,
3490 and because it is not clear that they are needed anywhere in
3491 Gigi. With the current model, there is no correct place where
3492 they could be elaborated. */
3494 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3495 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3496 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3497 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3498 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3500 /* If we are not defining this entity, and we have incomplete
3501 entities being processed above us, make a dummy type and
3502 elaborate it later. */
3503 if (!definition
&& defer_incomplete_level
!= 0)
3505 struct incomplete
*p
3506 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3508 = build_pointer_type
3509 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3511 p
->old_type
= TREE_TYPE (gnu_ptr_type
);
3512 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3513 p
->next
= defer_incomplete_list
;
3514 defer_incomplete_list
= p
;
3516 else if (!IN (Ekind (Base_Type
3517 (Directly_Designated_Type (gnat_entity
))),
3518 Incomplete_Or_Private_Kind
))
3519 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3523 maybe_present
= true;
3526 /* Subprogram Entities
3528 The following access functions are defined for subprograms (functions
3531 First_Formal The first formal parameter.
3532 Is_Imported Indicates that the subprogram has appeared in
3533 an INTERFACE or IMPORT pragma. For now we
3534 assume that the external language is C.
3535 Is_Exported Likewise but for an EXPORT pragma.
3536 Is_Inlined True if the subprogram is to be inlined.
3538 In addition for function subprograms we have:
3540 Etype Return type of the function.
3542 Each parameter is first checked by calling must_pass_by_ref on its
3543 type to determine if it is passed by reference. For parameters which
3544 are copied in, if they are Ada In Out or Out parameters, their return
3545 value becomes part of a record which becomes the return type of the
3546 function (C function - note that this applies only to Ada procedures
3547 so there is no Ada return type). Additional code to store back the
3548 parameters will be generated on the caller side. This transformation
3549 is done here, not in the front-end.
3551 The intended result of the transformation can be seen from the
3552 equivalent source rewritings that follow:
3554 struct temp {int a,b};
3555 procedure P (A,B: In Out ...) is temp P (int A,B)
3558 end P; return {A,B};
3565 For subprogram types we need to perform mainly the same conversions to
3566 GCC form that are needed for procedures and function declarations. The
3567 only difference is that at the end, we make a type declaration instead
3568 of a function declaration. */
3570 case E_Subprogram_Type
:
3574 /* The first GCC parameter declaration (a PARM_DECL node). The
3575 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3576 actually is the head of this parameter list. */
3577 tree gnu_param_list
= NULL_TREE
;
3578 /* Likewise for the stub associated with an exported procedure. */
3579 tree gnu_stub_param_list
= NULL_TREE
;
3580 /* The type returned by a function. If the subprogram is a procedure
3581 this type should be void_type_node. */
3582 tree gnu_return_type
= void_type_node
;
3583 /* List of fields in return type of procedure with copy-in copy-out
3585 tree gnu_field_list
= NULL_TREE
;
3586 /* Non-null for subprograms containing parameters passed by copy-in
3587 copy-out (Ada In Out or Out parameters not passed by reference),
3588 in which case it is the list of nodes used to specify the values of
3589 the in out/out parameters that are returned as a record upon
3590 procedure return. The TREE_PURPOSE of an element of this list is
3591 a field of the record and the TREE_VALUE is the PARM_DECL
3592 corresponding to that field. This list will be saved in the
3593 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3594 tree gnu_return_list
= NULL_TREE
;
3595 /* If an import pragma asks to map this subprogram to a GCC builtin,
3596 this is the builtin DECL node. */
3597 tree gnu_builtin_decl
= NULL_TREE
;
3598 /* For the stub associated with an exported procedure. */
3599 tree gnu_stub_type
= NULL_TREE
, gnu_stub_name
= NULL_TREE
;
3600 tree gnu_ext_name
= create_concat_name (gnat_entity
, NULL
);
3601 Entity_Id gnat_param
;
3602 bool inline_flag
= Is_Inlined (gnat_entity
);
3603 bool public_flag
= Is_Public (gnat_entity
) || imported_p
;
3605 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
3606 bool pure_flag
= Is_Pure (gnat_entity
);
3607 bool volatile_flag
= No_Return (gnat_entity
);
3608 bool returns_by_ref
= false;
3609 bool returns_unconstrained
= false;
3610 bool returns_by_target_ptr
= false;
3611 bool has_copy_in_out
= false;
3612 bool has_stub
= false;
3615 if (kind
== E_Subprogram_Type
&& !definition
)
3616 /* A parameter may refer to this type, so defer completion
3617 of any incomplete types. */
3618 defer_incomplete_level
++, this_deferred
= true;
3620 /* If the subprogram has an alias, it is probably inherited, so
3621 we can use the original one. If the original "subprogram"
3622 is actually an enumeration literal, it may be the first use
3623 of its type, so we must elaborate that type now. */
3624 if (Present (Alias (gnat_entity
)))
3626 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3627 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
3629 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
),
3632 /* Elaborate any Itypes in the parameters of this entity. */
3633 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
3634 Present (gnat_temp
);
3635 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
3636 if (Is_Itype (Etype (gnat_temp
)))
3637 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3642 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3643 corresponding DECL node.
3645 We still want the parameter associations to take place because the
3646 proper generation of calls depends on it (a GNAT parameter without
3647 a corresponding GCC tree has a very specific meaning), so we don't
3649 if (Convention (gnat_entity
) == Convention_Intrinsic
)
3650 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
3652 /* ??? What if we don't find the builtin node above ? warn ? err ?
3653 In the current state we neither warn nor err, and calls will just
3654 be handled as for regular subprograms. */
3656 if (kind
== E_Function
|| kind
== E_Subprogram_Type
)
3657 gnu_return_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3659 /* If this function returns by reference, make the actual
3660 return type of this function the pointer and mark the decl. */
3661 if (Returns_By_Ref (gnat_entity
))
3663 returns_by_ref
= true;
3664 gnu_return_type
= build_pointer_type (gnu_return_type
);
3667 /* If the Mechanism is By_Reference, ensure the return type uses
3668 the machine's by-reference mechanism, which may not the same
3669 as above (e.g., it might be by passing a fake parameter). */
3670 else if (kind
== E_Function
3671 && Mechanism (gnat_entity
) == By_Reference
)
3673 TREE_ADDRESSABLE (gnu_return_type
) = 1;
3675 /* We expect this bit to be reset by gigi shortly, so can avoid a
3676 type node copy here. This actually also prevents troubles with
3677 the generation of debug information for the function, because
3678 we might have issued such info for this type already, and would
3679 be attaching a distinct type node to the function if we made a
3683 /* If we are supposed to return an unconstrained array,
3684 actually return a fat pointer and make a note of that. Return
3685 a pointer to an unconstrained record of variable size. */
3686 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3688 gnu_return_type
= TREE_TYPE (gnu_return_type
);
3689 returns_unconstrained
= true;
3692 /* If the type requires a transient scope, the result is allocated
3693 on the secondary stack, so the result type of the function is
3695 else if (Requires_Transient_Scope (Etype (gnat_entity
)))
3697 gnu_return_type
= build_pointer_type (gnu_return_type
);
3698 returns_unconstrained
= true;
3701 /* If the type is a padded type and the underlying type would not
3702 be passed by reference or this function has a foreign convention,
3703 return the underlying type. */
3704 else if (TREE_CODE (gnu_return_type
) == RECORD_TYPE
3705 && TYPE_IS_PADDING_P (gnu_return_type
)
3706 && (!default_pass_by_ref (TREE_TYPE
3707 (TYPE_FIELDS (gnu_return_type
)))
3708 || Has_Foreign_Convention (gnat_entity
)))
3709 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
3711 /* If the return type is unconstrained, that means it must have a
3712 maximum size. We convert the function into a procedure and its
3713 caller will pass a pointer to an object of that maximum size as the
3714 first parameter when we call the function. */
3715 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
3717 returns_by_target_ptr
= true;
3719 = create_param_decl (get_identifier ("TARGET"),
3720 build_reference_type (gnu_return_type
),
3722 gnu_return_type
= void_type_node
;
3725 /* If the return type has a size that overflows, we cannot have
3726 a function that returns that type. This usage doesn't make
3727 sense anyway, so give an error here. */
3728 if (TYPE_SIZE_UNIT (gnu_return_type
)
3729 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
3730 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
3732 post_error ("cannot return type whose size overflows",
3734 gnu_return_type
= copy_node (gnu_return_type
);
3735 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
3736 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
3737 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
3738 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
3741 /* Look at all our parameters and get the type of
3742 each. While doing this, build a copy-out structure if
3745 /* Loop over the parameters and get their associated GCC tree.
3746 While doing this, build a copy-out structure if we need one. */
3747 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
3748 Present (gnat_param
);
3749 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
3751 tree gnu_param_name
= get_entity_name (gnat_param
);
3752 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
3753 tree gnu_param
, gnu_field
;
3754 bool copy_in_copy_out
= false;
3755 Mechanism_Type mech
= Mechanism (gnat_param
);
3757 /* Builtins are expanded inline and there is no real call sequence
3758 involved. So the type expected by the underlying expander is
3759 always the type of each argument "as is". */
3760 if (gnu_builtin_decl
)
3762 /* Handle the first parameter of a valued procedure specially. */
3763 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
3764 mech
= By_Copy_Return
;
3765 /* Otherwise, see if a Mechanism was supplied that forced this
3766 parameter to be passed one way or another. */
3767 else if (mech
== Default
3768 || mech
== By_Copy
|| mech
== By_Reference
)
3770 else if (By_Descriptor_Last
<= mech
&& mech
<= By_Descriptor
)
3771 mech
= By_Descriptor
;
3774 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
3775 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
3776 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
3778 mech
= By_Reference
;
3784 post_error ("unsupported mechanism for&", gnat_param
);
3789 = gnat_to_gnu_param (gnat_param
, mech
, gnat_entity
,
3790 Has_Foreign_Convention (gnat_entity
),
3793 /* We are returned either a PARM_DECL or a type if no parameter
3794 needs to be passed; in either case, adjust the type. */
3795 if (DECL_P (gnu_param
))
3796 gnu_param_type
= TREE_TYPE (gnu_param
);
3799 gnu_param_type
= gnu_param
;
3800 gnu_param
= NULL_TREE
;
3805 /* If it's an exported subprogram, we build a parameter list
3806 in parallel, in case we need to emit a stub for it. */
3807 if (Is_Exported (gnat_entity
))
3810 = chainon (gnu_param
, gnu_stub_param_list
);
3811 /* Change By_Descriptor parameter to By_Reference for
3812 the internal version of an exported subprogram. */
3813 if (mech
== By_Descriptor
)
3816 = gnat_to_gnu_param (gnat_param
, By_Reference
,
3822 gnu_param
= copy_node (gnu_param
);
3825 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
3826 Sloc_to_locus (Sloc (gnat_param
),
3827 &DECL_SOURCE_LOCATION (gnu_param
));
3828 save_gnu_tree (gnat_param
, gnu_param
, false);
3830 /* If a parameter is a pointer, this function may modify
3831 memory through it and thus shouldn't be considered
3832 a pure function. Also, the memory may be modified
3833 between two calls, so they can't be CSE'ed. The latter
3834 case also handles by-ref parameters. */
3835 if (POINTER_TYPE_P (gnu_param_type
)
3836 || TYPE_FAT_POINTER_P (gnu_param_type
))
3840 if (copy_in_copy_out
)
3842 if (!has_copy_in_out
)
3844 gcc_assert (TREE_CODE (gnu_return_type
) == VOID_TYPE
);
3845 gnu_return_type
= make_node (RECORD_TYPE
);
3846 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
3847 has_copy_in_out
= true;
3850 gnu_field
= create_field_decl (gnu_param_name
, gnu_param_type
,
3851 gnu_return_type
, 0, 0, 0, 0);
3852 Sloc_to_locus (Sloc (gnat_param
),
3853 &DECL_SOURCE_LOCATION (gnu_field
));
3854 TREE_CHAIN (gnu_field
) = gnu_field_list
;
3855 gnu_field_list
= gnu_field
;
3856 gnu_return_list
= tree_cons (gnu_field
, gnu_param
,
3861 /* Do not compute record for out parameters if subprogram is
3862 stubbed since structures are incomplete for the back-end. */
3863 if (gnu_field_list
&& Convention (gnat_entity
) != Convention_Stubbed
)
3864 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
3867 /* If we have a CICO list but it has only one entry, we convert
3868 this function into a function that simply returns that one
3870 if (list_length (gnu_return_list
) == 1)
3871 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_return_list
));
3873 if (Has_Stdcall_Convention (gnat_entity
))
3874 prepend_one_attribute_to
3875 (&attr_list
, ATTR_MACHINE_ATTRIBUTE
,
3876 get_identifier ("stdcall"), NULL_TREE
,
3879 /* The lists have been built in reverse. */
3880 gnu_param_list
= nreverse (gnu_param_list
);
3882 gnu_stub_param_list
= nreverse (gnu_stub_param_list
);
3883 gnu_return_list
= nreverse (gnu_return_list
);
3885 if (Ekind (gnat_entity
) == E_Function
)
3886 Set_Mechanism (gnat_entity
,
3887 (returns_by_ref
|| returns_unconstrained
3888 ? By_Reference
: By_Copy
));
3890 = create_subprog_type (gnu_return_type
, gnu_param_list
,
3891 gnu_return_list
, returns_unconstrained
,
3892 returns_by_ref
, returns_by_target_ptr
);
3896 = create_subprog_type (gnu_return_type
, gnu_stub_param_list
,
3897 gnu_return_list
, returns_unconstrained
,
3898 returns_by_ref
, returns_by_target_ptr
);
3900 /* A subprogram (something that doesn't return anything) shouldn't
3901 be considered Pure since there would be no reason for such a
3902 subprogram. Note that procedures with Out (or In Out) parameters
3903 have already been converted into a function with a return type. */
3904 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
3907 /* The semantics of "pure" in Ada essentially matches that of "const"
3908 in the back-end. In particular, both properties are orthogonal to
3909 the "nothrow" property. But this is true only if the EH circuitry
3910 is explicit in the internal representation of the back-end. If we
3911 are to completely hide the EH circuitry from it, we need to declare
3912 that calls to pure Ada subprograms that can throw have side effects
3913 since they can trigger an "abnormal" transfer of control flow; thus
3914 they can be neither "const" nor "pure" in the back-end sense. */
3916 = build_qualified_type (gnu_type
,
3917 TYPE_QUALS (gnu_type
)
3918 | (Exception_Mechanism
== Back_End_Exceptions
3919 ? TYPE_QUAL_CONST
* pure_flag
: 0)
3920 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
3922 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3926 = build_qualified_type (gnu_stub_type
,
3927 TYPE_QUALS (gnu_stub_type
)
3928 | (Exception_Mechanism
== Back_End_Exceptions
3929 ? TYPE_QUAL_CONST
* pure_flag
: 0)
3930 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
3932 /* If we have a builtin decl for that function, check the signatures
3933 compatibilities. If the signatures are compatible, use the builtin
3934 decl. If they are not, we expect the checker predicate to have
3935 posted the appropriate errors, and just continue with what we have
3937 if (gnu_builtin_decl
)
3939 tree gnu_builtin_type
= TREE_TYPE (gnu_builtin_decl
);
3941 if (compatible_signatures_p (gnu_type
, gnu_builtin_type
))
3943 gnu_decl
= gnu_builtin_decl
;
3944 gnu_type
= gnu_builtin_type
;
3949 /* If there was no specified Interface_Name and the external and
3950 internal names of the subprogram are the same, only use the
3951 internal name to allow disambiguation of nested subprograms. */
3952 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_id
)
3953 gnu_ext_name
= NULL_TREE
;
3955 /* If we are defining the subprogram and it has an Address clause
3956 we must get the address expression from the saved GCC tree for the
3957 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3958 the address expression here since the front-end has guaranteed
3959 in that case that the elaboration has no effects. If there is
3960 an Address clause and we are not defining the object, just
3961 make it a constant. */
3962 if (Present (Address_Clause (gnat_entity
)))
3964 tree gnu_address
= NULL_TREE
;
3968 = (present_gnu_tree (gnat_entity
)
3969 ? get_gnu_tree (gnat_entity
)
3970 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
3972 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
3974 /* Convert the type of the object to a reference type that can
3975 alias everything as per 13.3(19). */
3977 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
3979 gnu_address
= convert (gnu_type
, gnu_address
);
3982 = create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
3983 gnu_address
, false, Is_Public (gnat_entity
),
3984 extern_flag
, false, NULL
, gnat_entity
);
3985 DECL_BY_REF_P (gnu_decl
) = 1;
3988 else if (kind
== E_Subprogram_Type
)
3989 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3990 !Comes_From_Source (gnat_entity
),
3991 debug_info_p
, gnat_entity
);
3996 gnu_stub_name
= gnu_ext_name
;
3997 gnu_ext_name
= create_concat_name (gnat_entity
, "internal");
3998 public_flag
= false;
4001 gnu_decl
= create_subprog_decl (gnu_entity_id
, gnu_ext_name
,
4002 gnu_type
, gnu_param_list
,
4003 inline_flag
, public_flag
,
4004 extern_flag
, attr_list
,
4009 = create_subprog_decl (gnu_entity_id
, gnu_stub_name
,
4010 gnu_stub_type
, gnu_stub_param_list
,
4012 extern_flag
, attr_list
,
4014 SET_DECL_FUNCTION_STUB (gnu_decl
, gnu_stub_decl
);
4017 /* This is unrelated to the stub built right above. */
4018 DECL_STUBBED_P (gnu_decl
)
4019 = Convention (gnat_entity
) == Convention_Stubbed
;
4024 case E_Incomplete_Type
:
4025 case E_Incomplete_Subtype
:
4026 case E_Private_Type
:
4027 case E_Private_Subtype
:
4028 case E_Limited_Private_Type
:
4029 case E_Limited_Private_Subtype
:
4030 case E_Record_Type_With_Private
:
4031 case E_Record_Subtype_With_Private
:
4033 /* Get the "full view" of this entity. If this is an incomplete
4034 entity from a limited with, treat its non-limited view as the
4035 full view. Otherwise, use either the full view or the underlying
4036 full view, whichever is present. This is used in all the tests
4039 = (IN (Ekind (gnat_entity
), Incomplete_Kind
)
4040 && From_With_Type (gnat_entity
))
4041 ? Non_Limited_View (gnat_entity
)
4042 : Present (Full_View (gnat_entity
))
4043 ? Full_View (gnat_entity
)
4044 : Underlying_Full_View (gnat_entity
);
4046 /* If this is an incomplete type with no full view, it must be a Taft
4047 Amendment type, in which case we return a dummy type. Otherwise,
4048 just get the type from its Etype. */
4051 if (kind
== E_Incomplete_Type
)
4052 gnu_type
= make_dummy_type (gnat_entity
);
4055 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
4057 maybe_present
= true;
4062 /* If we already made a type for the full view, reuse it. */
4063 else if (present_gnu_tree (full_view
))
4065 gnu_decl
= get_gnu_tree (full_view
);
4069 /* Otherwise, if we are not defining the type now, get the type
4070 from the full view. But always get the type from the full view
4071 for define on use types, since otherwise we won't see them! */
4072 else if (!definition
4073 || (Is_Itype (full_view
)
4074 && No (Freeze_Node (gnat_entity
)))
4075 || (Is_Itype (gnat_entity
)
4076 && No (Freeze_Node (full_view
))))
4078 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
4079 maybe_present
= true;
4083 /* For incomplete types, make a dummy type entry which will be
4085 gnu_type
= make_dummy_type (gnat_entity
);
4087 /* Save this type as the full declaration's type so we can do any
4088 needed updates when we see it. */
4089 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4090 !Comes_From_Source (gnat_entity
),
4091 debug_info_p
, gnat_entity
);
4092 save_gnu_tree (full_view
, gnu_decl
, 0);
4096 /* Simple class_wide types are always viewed as their root_type
4097 by Gigi unless an Equivalent_Type is specified. */
4098 case E_Class_Wide_Type
:
4099 gnu_decl
= gnat_to_gnu_entity (gnat_equiv_type
, NULL_TREE
, 0);
4100 maybe_present
= true;
4104 case E_Task_Subtype
:
4105 case E_Protected_Type
:
4106 case E_Protected_Subtype
:
4107 if (type_annotate_only
&& No (gnat_equiv_type
))
4108 gnu_type
= void_type_node
;
4110 gnu_type
= gnat_to_gnu_type (gnat_equiv_type
);
4112 maybe_present
= true;
4116 gnu_decl
= create_label_decl (gnu_entity_id
);
4121 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4122 we've already saved it, so we don't try to. */
4123 gnu_decl
= error_mark_node
;
4131 /* If we had a case where we evaluated another type and it might have
4132 defined this one, handle it here. */
4133 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4135 gnu_decl
= get_gnu_tree (gnat_entity
);
4139 /* If we are processing a type and there is either no decl for it or
4140 we just made one, do some common processing for the type, such as
4141 handling alignment and possible padding. */
4143 if ((!gnu_decl
|| this_made_decl
) && IN (kind
, Type_Kind
))
4145 if (Is_Tagged_Type (gnat_entity
)
4146 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4147 TYPE_ALIGN_OK (gnu_type
) = 1;
4149 if (AGGREGATE_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4150 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4152 /* ??? Don't set the size for a String_Literal since it is either
4153 confirming or we don't handle it properly (if the low bound is
4155 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4156 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
, gnat_entity
,
4158 Has_Size_Clause (gnat_entity
));
4160 /* If a size was specified, see if we can make a new type of that size
4161 by rearranging the type, for example from a fat to a thin pointer. */
4165 = make_type_from_size (gnu_type
, gnu_size
,
4166 Has_Biased_Representation (gnat_entity
));
4168 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4169 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4173 /* If the alignment hasn't already been processed and this is
4174 not an unconstrained array, see if an alignment is specified.
4175 If not, we pick a default alignment for atomic objects. */
4176 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4178 else if (Known_Alignment (gnat_entity
))
4180 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4181 TYPE_ALIGN (gnu_type
));
4183 /* Warn on suspiciously large alignments. This should catch
4184 errors about the (alignment,byte)/(size,bit) discrepancy. */
4185 if (align
> BIGGEST_ALIGNMENT
&& Has_Alignment_Clause (gnat_entity
))
4189 /* If a size was specified, take it into account. Otherwise
4190 use the RM size for records as the type size has already
4191 been adjusted to the alignment. */
4194 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
4195 || TREE_CODE (gnu_type
) == UNION_TYPE
4196 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
4197 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
4198 size
= rm_size (gnu_type
);
4200 size
= TYPE_SIZE (gnu_type
);
4202 /* Consider an alignment as suspicious if the alignment/size
4203 ratio is greater or equal to the byte/bit ratio. */
4204 if (host_integerp (size
, 1)
4205 && align
>= TREE_INT_CST_LOW (size
) * BITS_PER_UNIT
)
4206 post_error_ne ("?suspiciously large alignment specified for&",
4207 Expression (Alignment_Clause (gnat_entity
)),
4211 else if (Is_Atomic (gnat_entity
) && !gnu_size
4212 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4213 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4214 align
= MIN (BIGGEST_ALIGNMENT
,
4215 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4216 else if (Is_Atomic (gnat_entity
) && gnu_size
4217 && host_integerp (gnu_size
, 1)
4218 && integer_pow2p (gnu_size
))
4219 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4221 /* See if we need to pad the type. If we did, and made a record,
4222 the name of the new type may be changed. So get it back for
4223 us when we make the new TYPE_DECL below. */
4224 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
, "PAD",
4225 true, definition
, false);
4226 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4227 && TYPE_IS_PADDING_P (gnu_type
))
4229 gnu_entity_id
= TYPE_NAME (gnu_type
);
4230 if (TREE_CODE (gnu_entity_id
) == TYPE_DECL
)
4231 gnu_entity_id
= DECL_NAME (gnu_entity_id
);
4234 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4236 /* If we are at global level, GCC will have applied variable_size to
4237 the type, but that won't have done anything. So, if it's not
4238 a constant or self-referential, call elaborate_expression_1 to
4239 make a variable for the size rather than calculating it each time.
4240 Handle both the RM size and the actual size. */
4241 if (global_bindings_p ()
4242 && TYPE_SIZE (gnu_type
)
4243 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4244 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4246 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4247 && operand_equal_p (TYPE_ADA_SIZE (gnu_type
),
4248 TYPE_SIZE (gnu_type
), 0))
4250 TYPE_SIZE (gnu_type
)
4251 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4252 TYPE_SIZE (gnu_type
),
4253 get_identifier ("SIZE"),
4255 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_SIZE (gnu_type
));
4259 TYPE_SIZE (gnu_type
)
4260 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4261 TYPE_SIZE (gnu_type
),
4262 get_identifier ("SIZE"),
4265 /* ??? For now, store the size as a multiple of the alignment
4266 in bytes so that we can see the alignment from the tree. */
4267 TYPE_SIZE_UNIT (gnu_type
)
4269 (MULT_EXPR
, sizetype
,
4270 elaborate_expression_1
4271 (gnat_entity
, gnat_entity
,
4272 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4273 TYPE_SIZE_UNIT (gnu_type
),
4274 size_int (TYPE_ALIGN (gnu_type
)
4276 get_identifier ("SIZE_A_UNIT"),
4278 size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4280 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4283 elaborate_expression_1 (gnat_entity
,
4285 TYPE_ADA_SIZE (gnu_type
),
4286 get_identifier ("RM_SIZE"),
4291 /* If this is a record type or subtype, call elaborate_expression_1 on
4292 any field position. Do this for both global and local types.
4293 Skip any fields that we haven't made trees for to avoid problems with
4294 class wide types. */
4295 if (IN (kind
, Record_Kind
))
4296 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4297 gnat_temp
= Next_Entity (gnat_temp
))
4298 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4300 tree gnu_field
= get_gnu_tree (gnat_temp
);
4302 /* ??? Unfortunately, GCC needs to be able to prove the
4303 alignment of this offset and if it's a variable, it can't.
4304 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4305 right now, we have to put in an explicit multiply and
4306 divide by that value. */
4307 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4309 DECL_FIELD_OFFSET (gnu_field
)
4311 (MULT_EXPR
, sizetype
,
4312 elaborate_expression_1
4313 (gnat_temp
, gnat_temp
,
4314 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4315 DECL_FIELD_OFFSET (gnu_field
),
4316 size_int (DECL_OFFSET_ALIGN (gnu_field
)
4318 get_identifier ("OFFSET"),
4320 size_int (DECL_OFFSET_ALIGN (gnu_field
) / BITS_PER_UNIT
));
4322 /* ??? The context of gnu_field is not necessarily gnu_type so
4323 the MULT_EXPR node built above may not be marked by the call
4324 to create_type_decl below. Mark it manually for now. */
4325 if (global_bindings_p ())
4326 TREE_VISITED (DECL_FIELD_OFFSET (gnu_field
)) = 1;
4330 gnu_type
= build_qualified_type (gnu_type
,
4331 (TYPE_QUALS (gnu_type
)
4332 | (TYPE_QUAL_VOLATILE
4333 * Treat_As_Volatile (gnat_entity
))));
4335 if (Is_Atomic (gnat_entity
))
4336 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
4338 if (Present (Alignment_Clause (gnat_entity
)))
4339 TYPE_USER_ALIGN (gnu_type
) = 1;
4341 if (Universal_Aliasing (gnat_entity
))
4342 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type
)) = 1;
4345 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4346 !Comes_From_Source (gnat_entity
),
4347 debug_info_p
, gnat_entity
);
4349 TREE_TYPE (gnu_decl
) = gnu_type
;
4352 if (IN (kind
, Type_Kind
) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4354 gnu_type
= TREE_TYPE (gnu_decl
);
4356 /* Back-annotate the Alignment of the type if not already in the
4357 tree. Likewise for sizes. */
4358 if (Unknown_Alignment (gnat_entity
))
4359 Set_Alignment (gnat_entity
,
4360 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4362 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4364 /* If the size is self-referential, we annotate the maximum
4365 value of that size. */
4366 tree gnu_size
= TYPE_SIZE (gnu_type
);
4368 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4369 gnu_size
= max_size (gnu_size
, true);
4371 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4373 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4375 /* In this mode the tag and the parent components are not
4376 generated by the front-end, so the sizes must be adjusted
4378 int size_offset
, new_size
;
4380 if (Is_Derived_Type (gnat_entity
))
4383 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity
))));
4384 Set_Alignment (gnat_entity
,
4385 Alignment (Etype (Base_Type (gnat_entity
))));
4388 size_offset
= POINTER_SIZE
;
4390 new_size
= UI_To_Int (Esize (gnat_entity
)) + size_offset
;
4391 Set_Esize (gnat_entity
,
4392 UI_From_Int (((new_size
+ (POINTER_SIZE
- 1))
4393 / POINTER_SIZE
) * POINTER_SIZE
));
4394 Set_RM_Size (gnat_entity
, Esize (gnat_entity
));
4398 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
4399 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4402 if (!Comes_From_Source (gnat_entity
) && DECL_P (gnu_decl
))
4403 DECL_ARTIFICIAL (gnu_decl
) = 1;
4405 if (!debug_info_p
&& DECL_P (gnu_decl
)
4406 && TREE_CODE (gnu_decl
) != FUNCTION_DECL
4407 && No (Renamed_Object (gnat_entity
)))
4408 DECL_IGNORED_P (gnu_decl
) = 1;
4410 /* If we haven't already, associate the ..._DECL node that we just made with
4411 the input GNAT entity node. */
4413 save_gnu_tree (gnat_entity
, gnu_decl
, false);
4415 /* If this is an enumeral or floating-point type, we were not able to set
4416 the bounds since they refer to the type. These bounds are always static.
4418 For enumeration types, also write debugging information and declare the
4419 enumeration literal table, if needed. */
4421 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
4422 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
4424 tree gnu_scalar_type
= gnu_type
;
4426 /* If this is a padded type, we need to use the underlying type. */
4427 if (TREE_CODE (gnu_scalar_type
) == RECORD_TYPE
4428 && TYPE_IS_PADDING_P (gnu_scalar_type
))
4429 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
4431 /* If this is a floating point type and we haven't set a floating
4432 point type yet, use this in the evaluation of the bounds. */
4433 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
4434 longest_float_type_node
= gnu_type
;
4436 TYPE_MIN_VALUE (gnu_scalar_type
)
4437 = gnat_to_gnu (Type_Low_Bound (gnat_entity
));
4438 TYPE_MAX_VALUE (gnu_scalar_type
)
4439 = gnat_to_gnu (Type_High_Bound (gnat_entity
));
4441 if (TREE_CODE (gnu_scalar_type
) == ENUMERAL_TYPE
)
4443 /* Since this has both a typedef and a tag, avoid outputting
4445 DECL_ARTIFICIAL (gnu_decl
) = 1;
4446 rest_of_type_decl_compilation (gnu_decl
);
4450 /* If we deferred processing of incomplete types, re-enable it. If there
4451 were no other disables and we have some to process, do so. */
4452 if (this_deferred
&& --defer_incomplete_level
== 0)
4454 if (defer_incomplete_list
)
4456 struct incomplete
*incp
, *next
;
4458 /* We are back to level 0 for the deferring of incomplete types.
4459 But processing these incomplete types below may itself require
4460 deferring, so preserve what we have and restart from scratch. */
4461 incp
= defer_incomplete_list
;
4462 defer_incomplete_list
= NULL
;
4464 /* For finalization, however, all types must be complete so we
4465 cannot do the same because deferred incomplete types may end up
4466 referencing each other. Process them all recursively first. */
4467 defer_finalize_level
++;
4469 for (; incp
; incp
= next
)
4474 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4475 gnat_to_gnu_type (incp
->full_type
));
4479 defer_finalize_level
--;
4482 /* All the deferred incomplete types have been processed so we can
4483 now proceed with the finalization of the deferred types. */
4484 if (defer_finalize_level
== 0 && defer_finalize_list
)
4489 for (i
= 0; VEC_iterate (tree
, defer_finalize_list
, i
, t
); i
++)
4490 rest_of_type_decl_compilation_no_defer (t
);
4492 VEC_free (tree
, heap
, defer_finalize_list
);
4496 /* If we are not defining this type, see if it's in the incomplete list.
4497 If so, handle that list entry now. */
4498 else if (!definition
)
4500 struct incomplete
*incp
;
4502 for (incp
= defer_incomplete_list
; incp
; incp
= incp
->next
)
4503 if (incp
->old_type
&& incp
->full_type
== gnat_entity
)
4505 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4506 TREE_TYPE (gnu_decl
));
4507 incp
->old_type
= NULL_TREE
;
4514 if (Is_Packed_Array_Type (gnat_entity
)
4515 && Is_Itype (Associated_Node_For_Itype (gnat_entity
))
4516 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity
)))
4517 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity
)))
4518 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity
), NULL_TREE
, 0);
4523 /* Similar, but if the returned value is a COMPONENT_REF, return the
4527 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
4529 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4531 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
4532 gnu_field
= TREE_OPERAND (gnu_field
, 1);
4537 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4538 Every TYPE_DECL generated for a type definition must be passed
4539 to this function once everything else has been done for it. */
4542 rest_of_type_decl_compilation (tree decl
)
4544 /* We need to defer finalizing the type if incomplete types
4545 are being deferred or if they are being processed. */
4546 if (defer_incomplete_level
|| defer_finalize_level
)
4547 VEC_safe_push (tree
, heap
, defer_finalize_list
, decl
);
4549 rest_of_type_decl_compilation_no_defer (decl
);
4552 /* Same as above but without deferring the compilation. This
4553 function should not be invoked directly on a TYPE_DECL. */
4556 rest_of_type_decl_compilation_no_defer (tree decl
)
4558 const int toplev
= global_bindings_p ();
4559 tree t
= TREE_TYPE (decl
);
4561 rest_of_decl_compilation (decl
, toplev
, 0);
4563 /* Now process all the variants. This is needed for STABS. */
4564 for (t
= TYPE_MAIN_VARIANT (t
); t
; t
= TYPE_NEXT_VARIANT (t
))
4566 if (t
== TREE_TYPE (decl
))
4569 if (!TYPE_STUB_DECL (t
))
4571 TYPE_STUB_DECL (t
) = build_decl (TYPE_DECL
, DECL_NAME (decl
), t
);
4572 DECL_ARTIFICIAL (TYPE_STUB_DECL (t
)) = 1;
4575 rest_of_type_compilation (t
, toplev
);
4579 /* Finalize any From_With_Type incomplete types. We do this after processing
4580 our compilation unit and after processing its spec, if this is a body. */
4583 finalize_from_with_types (void)
4585 struct incomplete
*incp
= defer_limited_with
;
4586 struct incomplete
*next
;
4588 defer_limited_with
= 0;
4589 for (; incp
; incp
= next
)
4593 if (incp
->old_type
!= 0)
4594 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4595 gnat_to_gnu_type (incp
->full_type
));
4600 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4601 kind of type (such E_Task_Type) that has a different type which Gigi
4602 uses for its representation. If the type does not have a special type
4603 for its representation, return GNAT_ENTITY. If a type is supposed to
4604 exist, but does not, abort unless annotating types, in which case
4605 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4608 Gigi_Equivalent_Type (Entity_Id gnat_entity
)
4610 Entity_Id gnat_equiv
= gnat_entity
;
4612 if (No (gnat_entity
))
4615 switch (Ekind (gnat_entity
))
4617 case E_Class_Wide_Subtype
:
4618 if (Present (Equivalent_Type (gnat_entity
)))
4619 gnat_equiv
= Equivalent_Type (gnat_entity
);
4622 case E_Access_Protected_Subprogram_Type
:
4623 case E_Anonymous_Access_Protected_Subprogram_Type
:
4624 gnat_equiv
= Equivalent_Type (gnat_entity
);
4627 case E_Class_Wide_Type
:
4628 gnat_equiv
= ((Present (Equivalent_Type (gnat_entity
)))
4629 ? Equivalent_Type (gnat_entity
)
4630 : Root_Type (gnat_entity
));
4634 case E_Task_Subtype
:
4635 case E_Protected_Type
:
4636 case E_Protected_Subtype
:
4637 gnat_equiv
= Corresponding_Record_Type (gnat_entity
);
4644 gcc_assert (Present (gnat_equiv
) || type_annotate_only
);
4648 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4649 using MECH as its passing mechanism, to be placed in the parameter
4650 list built for GNAT_SUBPROG. Assume a foreign convention for the
4651 latter if FOREIGN is true. Also set CICO to true if the parameter
4652 must use the copy-in copy-out implementation mechanism.
4654 The returned tree is a PARM_DECL, except for those cases where no
4655 parameter needs to be actually passed to the subprogram; the type
4656 of this "shadow" parameter is then returned instead. */
4659 gnat_to_gnu_param (Entity_Id gnat_param
, Mechanism_Type mech
,
4660 Entity_Id gnat_subprog
, bool foreign
, bool *cico
)
4662 tree gnu_param_name
= get_entity_name (gnat_param
);
4663 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
4664 bool in_param
= (Ekind (gnat_param
) == E_In_Parameter
);
4665 /* The parameter can be indirectly modified if its address is taken. */
4666 bool ro_param
= in_param
&& !Address_Taken (gnat_param
);
4667 bool by_return
= false, by_component_ptr
= false, by_ref
= false;
4670 /* Copy-return is used only for the first parameter of a valued procedure.
4671 It's a copy mechanism for which a parameter is never allocated. */
4672 if (mech
== By_Copy_Return
)
4674 gcc_assert (Ekind (gnat_param
) == E_Out_Parameter
);
4679 /* If this is either a foreign function or if the underlying type won't
4680 be passed by reference, strip off possible padding type. */
4681 if (TREE_CODE (gnu_param_type
) == RECORD_TYPE
4682 && TYPE_IS_PADDING_P (gnu_param_type
))
4684 tree unpadded_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
4686 if (mech
== By_Reference
4688 || (!must_pass_by_ref (unpadded_type
)
4689 && (mech
== By_Copy
|| !default_pass_by_ref (unpadded_type
))))
4690 gnu_param_type
= unpadded_type
;
4693 /* If this is a read-only parameter, make a variant of the type that is
4694 read-only. ??? However, if this is an unconstrained array, that type
4695 can be very complex, so skip it for now. Likewise for any other
4696 self-referential type. */
4698 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
4699 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
4700 gnu_param_type
= build_qualified_type (gnu_param_type
,
4701 (TYPE_QUALS (gnu_param_type
)
4702 | TYPE_QUAL_CONST
));
4704 /* For foreign conventions, pass arrays as pointers to the element type.
4705 First check for unconstrained array and get the underlying array. */
4706 if (foreign
&& TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4708 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type
))));
4710 /* VMS descriptors are themselves passed by reference. */
4711 if (mech
== By_Descriptor
)
4713 = build_pointer_type (build_vms_descriptor (gnu_param_type
,
4714 Mechanism (gnat_param
),
4717 /* Arrays are passed as pointers to element type for foreign conventions. */
4720 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
4722 /* Strip off any multi-dimensional entries, then strip
4723 off the last array to get the component type. */
4724 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
4725 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
4726 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4728 by_component_ptr
= true;
4729 gnu_param_type
= TREE_TYPE (gnu_param_type
);
4732 gnu_param_type
= build_qualified_type (gnu_param_type
,
4733 (TYPE_QUALS (gnu_param_type
)
4734 | TYPE_QUAL_CONST
));
4736 gnu_param_type
= build_pointer_type (gnu_param_type
);
4739 /* Fat pointers are passed as thin pointers for foreign conventions. */
4740 else if (foreign
&& TYPE_FAT_POINTER_P (gnu_param_type
))
4742 = make_type_from_size (gnu_param_type
, size_int (POINTER_SIZE
), 0);
4744 /* If we must pass or were requested to pass by reference, do so.
4745 If we were requested to pass by copy, do so.
4746 Otherwise, for foreign conventions, pass In Out or Out parameters
4747 or aggregates by reference. For COBOL and Fortran, pass all
4748 integer and FP types that way too. For Convention Ada, use
4749 the standard Ada default. */
4750 else if (must_pass_by_ref (gnu_param_type
)
4751 || mech
== By_Reference
4754 && (!in_param
|| AGGREGATE_TYPE_P (gnu_param_type
)))
4756 && (Convention (gnat_subprog
) == Convention_Fortran
4757 || Convention (gnat_subprog
) == Convention_COBOL
)
4758 && (INTEGRAL_TYPE_P (gnu_param_type
)
4759 || FLOAT_TYPE_P (gnu_param_type
)))
4761 && default_pass_by_ref (gnu_param_type
)))))
4763 gnu_param_type
= build_reference_type (gnu_param_type
);
4767 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
4771 if (mech
== By_Copy
&& (by_ref
|| by_component_ptr
))
4772 post_error ("?cannot pass & by copy", gnat_param
);
4774 /* If this is an Out parameter that isn't passed by reference and isn't
4775 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4776 it will be a VAR_DECL created when we process the procedure, so just
4777 return its type. For the special parameter of a valued procedure,
4780 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4781 Out parameters with discriminants or implicit initial values to be
4782 handled like In Out parameters. These type are normally built as
4783 aggregates, hence passed by reference, except for some packed arrays
4784 which end up encoded in special integer types.
4786 The exception we need to make is then for packed arrays of records
4787 with discriminants or implicit initial values. We have no light/easy
4788 way to check for the latter case, so we merely check for packed arrays
4789 of records. This may lead to useless copy-in operations, but in very
4790 rare cases only, as these would be exceptions in a set of already
4791 exceptional situations. */
4792 if (Ekind (gnat_param
) == E_Out_Parameter
4795 || (mech
!= By_Descriptor
4796 && !POINTER_TYPE_P (gnu_param_type
)
4797 && !AGGREGATE_TYPE_P (gnu_param_type
)))
4798 && !(Is_Array_Type (Etype (gnat_param
))
4799 && Is_Packed (Etype (gnat_param
))
4800 && Is_Composite_Type (Component_Type (Etype (gnat_param
)))))
4801 return gnu_param_type
;
4803 gnu_param
= create_param_decl (gnu_param_name
, gnu_param_type
,
4804 ro_param
|| by_ref
|| by_component_ptr
);
4805 DECL_BY_REF_P (gnu_param
) = by_ref
;
4806 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr
;
4807 DECL_BY_DESCRIPTOR_P (gnu_param
) = (mech
== By_Descriptor
);
4808 DECL_POINTS_TO_READONLY_P (gnu_param
)
4809 = (ro_param
&& (by_ref
|| by_component_ptr
));
4811 /* If no Mechanism was specified, indicate what we're using, then
4812 back-annotate it. */
4813 if (mech
== Default
)
4814 mech
= (by_ref
|| by_component_ptr
) ? By_Reference
: By_Copy
;
4816 Set_Mechanism (gnat_param
, mech
);
4820 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4823 same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
4825 while (Present (Corresponding_Discriminant (discr1
)))
4826 discr1
= Corresponding_Discriminant (discr1
);
4828 while (Present (Corresponding_Discriminant (discr2
)))
4829 discr2
= Corresponding_Discriminant (discr2
);
4832 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
4835 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4836 a non-aliased component in the back-end sense. */
4839 array_type_has_nonaliased_component (Entity_Id gnat_type
, tree gnu_type
)
4841 /* If the type below this is a multi-array type, then
4842 this does not have aliased components. */
4843 if (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
4844 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
4847 if (Has_Aliased_Components (gnat_type
))
4850 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type
));
4853 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4854 be elaborated at the point of its definition, but do nothing else. */
4857 elaborate_entity (Entity_Id gnat_entity
)
4859 switch (Ekind (gnat_entity
))
4861 case E_Signed_Integer_Subtype
:
4862 case E_Modular_Integer_Subtype
:
4863 case E_Enumeration_Subtype
:
4864 case E_Ordinary_Fixed_Point_Subtype
:
4865 case E_Decimal_Fixed_Point_Subtype
:
4866 case E_Floating_Point_Subtype
:
4868 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
4869 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
4871 /* ??? Tests for avoiding static constraint error expression
4872 is needed until the front stops generating bogus conversions
4873 on bounds of real types. */
4875 if (!Raises_Constraint_Error (gnat_lb
))
4876 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
4877 1, 0, Needs_Debug_Info (gnat_entity
));
4878 if (!Raises_Constraint_Error (gnat_hb
))
4879 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
4880 1, 0, Needs_Debug_Info (gnat_entity
));
4886 Node_Id full_definition
= Declaration_Node (gnat_entity
);
4887 Node_Id record_definition
= Type_Definition (full_definition
);
4889 /* If this is a record extension, go a level further to find the
4890 record definition. */
4891 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
4892 record_definition
= Record_Extension_Part (record_definition
);
4896 case E_Record_Subtype
:
4897 case E_Private_Subtype
:
4898 case E_Limited_Private_Subtype
:
4899 case E_Record_Subtype_With_Private
:
4900 if (Is_Constrained (gnat_entity
)
4901 && Has_Discriminants (Base_Type (gnat_entity
))
4902 && Present (Discriminant_Constraint (gnat_entity
)))
4904 Node_Id gnat_discriminant_expr
;
4905 Entity_Id gnat_field
;
4907 for (gnat_field
= First_Discriminant (Base_Type (gnat_entity
)),
4908 gnat_discriminant_expr
4909 = First_Elmt (Discriminant_Constraint (gnat_entity
));
4910 Present (gnat_field
);
4911 gnat_field
= Next_Discriminant (gnat_field
),
4912 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
4913 /* ??? For now, ignore access discriminants. */
4914 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
4915 elaborate_expression (Node (gnat_discriminant_expr
),
4917 get_entity_name (gnat_field
), 1, 0, 0);
4924 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4925 any entities on its entity chain similarly. */
4928 mark_out_of_scope (Entity_Id gnat_entity
)
4930 Entity_Id gnat_sub_entity
;
4931 unsigned int kind
= Ekind (gnat_entity
);
4933 /* If this has an entity list, process all in the list. */
4934 if (IN (kind
, Class_Wide_Kind
) || IN (kind
, Concurrent_Kind
)
4935 || IN (kind
, Private_Kind
)
4936 || kind
== E_Block
|| kind
== E_Entry
|| kind
== E_Entry_Family
4937 || kind
== E_Function
|| kind
== E_Generic_Function
4938 || kind
== E_Generic_Package
|| kind
== E_Generic_Procedure
4939 || kind
== E_Loop
|| kind
== E_Operator
|| kind
== E_Package
4940 || kind
== E_Package_Body
|| kind
== E_Procedure
4941 || kind
== E_Record_Type
|| kind
== E_Record_Subtype
4942 || kind
== E_Subprogram_Body
|| kind
== E_Subprogram_Type
)
4943 for (gnat_sub_entity
= First_Entity (gnat_entity
);
4944 Present (gnat_sub_entity
);
4945 gnat_sub_entity
= Next_Entity (gnat_sub_entity
))
4946 if (Scope (gnat_sub_entity
) == gnat_entity
4947 && gnat_sub_entity
!= gnat_entity
)
4948 mark_out_of_scope (gnat_sub_entity
);
4950 /* Now clear this if it has been defined, but only do so if it isn't
4951 a subprogram or parameter. We could refine this, but it isn't
4952 worth it. If this is statically allocated, it is supposed to
4953 hang around out of cope. */
4954 if (present_gnu_tree (gnat_entity
) && !Is_Statically_Allocated (gnat_entity
)
4955 && kind
!= E_Procedure
&& kind
!= E_Function
&& !IN (kind
, Formal_Kind
))
4957 save_gnu_tree (gnat_entity
, NULL_TREE
, true);
4958 save_gnu_tree (gnat_entity
, error_mark_node
, true);
4962 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4963 is a multi-dimensional array type, do this recursively. */
4966 copy_alias_set (tree gnu_new_type
, tree gnu_old_type
)
4968 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
4969 of a one-dimensional array, since the padding has the same alias set
4970 as the field type, but if it's a multi-dimensional array, we need to
4971 see the inner types. */
4972 while (TREE_CODE (gnu_old_type
) == RECORD_TYPE
4973 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type
)
4974 || TYPE_IS_PADDING_P (gnu_old_type
)))
4975 gnu_old_type
= TREE_TYPE (TYPE_FIELDS (gnu_old_type
));
4977 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4978 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4979 so we need to go down to what does. */
4980 if (TREE_CODE (gnu_old_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4982 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type
))));
4984 if (TREE_CODE (gnu_new_type
) == ARRAY_TYPE
4985 && TREE_CODE (TREE_TYPE (gnu_new_type
)) == ARRAY_TYPE
4986 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type
)))
4987 copy_alias_set (TREE_TYPE (gnu_new_type
), TREE_TYPE (gnu_old_type
));
4989 TYPE_ALIAS_SET (gnu_new_type
) = get_alias_set (gnu_old_type
);
4990 record_component_aliases (gnu_new_type
);
4993 /* Return a TREE_LIST describing the substitutions needed to reflect
4994 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4995 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4996 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
4997 gives the tree for the discriminant and TREE_VALUES is the replacement
4998 value. They are in the form of operands to substitute_in_expr.
4999 DEFINITION is as in gnat_to_gnu_entity. */
5002 substitution_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
,
5003 tree gnu_list
, bool definition
)
5005 Entity_Id gnat_discrim
;
5009 gnat_type
= Implementation_Base_Type (gnat_subtype
);
5011 if (Has_Discriminants (gnat_type
))
5012 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
5013 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
5014 Present (gnat_discrim
);
5015 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
5016 gnat_value
= Next_Elmt (gnat_value
))
5017 /* Ignore access discriminants. */
5018 if (!Is_Access_Type (Etype (Node (gnat_value
))))
5019 gnu_list
= tree_cons (gnat_to_gnu_field_decl (gnat_discrim
),
5020 elaborate_expression
5021 (Node (gnat_value
), gnat_subtype
,
5022 get_entity_name (gnat_discrim
), definition
,
5029 /* Return true if the size represented by GNU_SIZE can be handled by an
5030 allocation. If STATIC_P is true, consider only what can be done with a
5031 static allocation. */
5034 allocatable_size_p (tree gnu_size
, bool static_p
)
5036 HOST_WIDE_INT our_size
;
5038 /* If this is not a static allocation, the only case we want to forbid
5039 is an overflowing size. That will be converted into a raise a
5042 return !(TREE_CODE (gnu_size
) == INTEGER_CST
5043 && TREE_OVERFLOW (gnu_size
));
5045 /* Otherwise, we need to deal with both variable sizes and constant
5046 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5047 since assemblers may not like very large sizes. */
5048 if (!host_integerp (gnu_size
, 1))
5051 our_size
= tree_low_cst (gnu_size
, 1);
5052 return (int) our_size
== our_size
;
5055 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5056 NAME, ARGS and ERROR_POINT. */
5059 prepend_one_attribute_to (struct attrib
** attr_list
,
5060 enum attr_type attr_type
,
5063 Node_Id attr_error_point
)
5065 struct attrib
* attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
5067 attr
->type
= attr_type
;
5068 attr
->name
= attr_name
;
5069 attr
->args
= attr_args
;
5070 attr
->error_point
= attr_error_point
;
5072 attr
->next
= *attr_list
;
5076 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5079 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
5083 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
5084 gnat_temp
= Next_Rep_Item (gnat_temp
))
5085 if (Nkind (gnat_temp
) == N_Pragma
)
5087 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
5088 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
5089 enum attr_type etype
;
5091 if (Present (gnat_assoc
) && Present (First (gnat_assoc
))
5092 && Present (Next (First (gnat_assoc
)))
5093 && (Nkind (Expression (Next (First (gnat_assoc
))))
5094 == N_String_Literal
))
5096 gnu_arg0
= get_identifier (TREE_STRING_POINTER
5099 (First (gnat_assoc
))))));
5100 if (Present (Next (Next (First (gnat_assoc
))))
5101 && (Nkind (Expression (Next (Next (First (gnat_assoc
)))))
5102 == N_String_Literal
))
5103 gnu_arg1
= get_identifier (TREE_STRING_POINTER
5107 (First (gnat_assoc
)))))));
5110 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp
))))
5112 case Pragma_Machine_Attribute
:
5113 etype
= ATTR_MACHINE_ATTRIBUTE
;
5116 case Pragma_Linker_Alias
:
5117 etype
= ATTR_LINK_ALIAS
;
5120 case Pragma_Linker_Section
:
5121 etype
= ATTR_LINK_SECTION
;
5124 case Pragma_Linker_Constructor
:
5125 etype
= ATTR_LINK_CONSTRUCTOR
;
5128 case Pragma_Linker_Destructor
:
5129 etype
= ATTR_LINK_DESTRUCTOR
;
5132 case Pragma_Weak_External
:
5133 etype
= ATTR_WEAK_EXTERNAL
;
5141 /* Prepend to the list now. Make a list of the argument we might
5142 have, as GCC expects it. */
5143 prepend_one_attribute_to
5146 (gnu_arg1
!= NULL_TREE
)
5147 ? build_tree_list (NULL_TREE
, gnu_arg1
) : NULL_TREE
,
5148 Present (Next (First (gnat_assoc
)))
5149 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
);
5153 /* Get the unpadded version of a GNAT type. */
5156 get_unpadded_type (Entity_Id gnat_entity
)
5158 tree type
= gnat_to_gnu_type (gnat_entity
);
5160 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5161 type
= TREE_TYPE (TYPE_FIELDS (type
));
5166 /* Called when we need to protect a variable object using a save_expr. */
5169 maybe_variable (tree gnu_operand
)
5171 if (TREE_CONSTANT (gnu_operand
) || TREE_READONLY (gnu_operand
)
5172 || TREE_CODE (gnu_operand
) == SAVE_EXPR
5173 || TREE_CODE (gnu_operand
) == NULL_EXPR
)
5176 if (TREE_CODE (gnu_operand
) == UNCONSTRAINED_ARRAY_REF
)
5178 tree gnu_result
= build1 (UNCONSTRAINED_ARRAY_REF
,
5179 TREE_TYPE (gnu_operand
),
5180 variable_size (TREE_OPERAND (gnu_operand
, 0)));
5182 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
)
5183 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand
)));
5187 return variable_size (gnu_operand
);
5190 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5191 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5192 return the GCC tree to use for that expression. GNU_NAME is the
5193 qualification to use if an external name is appropriate and DEFINITION is
5194 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
5195 we need a result. Otherwise, we are just elaborating this for
5196 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
5197 purposes even if it isn't needed for code generation. */
5200 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5201 tree gnu_name
, bool definition
, bool need_value
,
5206 /* If we already elaborated this expression (e.g., it was involved
5207 in the definition of a private type), use the old value. */
5208 if (present_gnu_tree (gnat_expr
))
5209 return get_gnu_tree (gnat_expr
);
5211 /* If we don't need a value and this is static or a discriminant, we
5212 don't need to do anything. */
5213 else if (!need_value
5214 && (Is_OK_Static_Expression (gnat_expr
)
5215 || (Nkind (gnat_expr
) == N_Identifier
5216 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
5219 /* Otherwise, convert this tree to its GCC equivalent. */
5221 = elaborate_expression_1 (gnat_expr
, gnat_entity
, gnat_to_gnu (gnat_expr
),
5222 gnu_name
, definition
, need_debug
);
5224 /* Save the expression in case we try to elaborate this entity again. Since
5225 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5226 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
5227 save_gnu_tree (gnat_expr
, gnu_expr
, true);
5229 return need_value
? gnu_expr
: error_mark_node
;
5232 /* Similar, but take a GNU expression. */
5235 elaborate_expression_1 (Node_Id gnat_expr
, Entity_Id gnat_entity
,
5236 tree gnu_expr
, tree gnu_name
, bool definition
,
5239 tree gnu_decl
= NULL_TREE
;
5240 /* Strip any conversions to see if the expression is a readonly variable.
5241 ??? This really should remain readonly, but we have to think about
5242 the typing of the tree here. */
5243 tree gnu_inner_expr
= remove_conversions (gnu_expr
, true);
5244 bool expr_global
= Is_Public (gnat_entity
) || global_bindings_p ();
5247 /* In most cases, we won't see a naked FIELD_DECL here because a
5248 discriminant reference will have been replaced with a COMPONENT_REF
5249 when the type is being elaborated. However, there are some cases
5250 involving child types where we will. So convert it to a COMPONENT_REF
5251 here. We have to hope it will be at the highest level of the
5252 expression in these cases. */
5253 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
5254 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
5255 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
5256 gnu_expr
, NULL_TREE
);
5258 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5259 that is a constant, make a variable that is initialized to contain the
5260 bound when the package containing the definition is elaborated. If
5261 this entity is defined at top level and a bound or discriminant value
5262 isn't a constant or a reference to a discriminant, replace the bound
5263 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5264 rely here on the fact that an expression cannot contain both the
5265 discriminant and some other variable. */
5267 expr_variable
= (!CONSTANT_CLASS_P (gnu_expr
)
5268 && !(TREE_CODE (gnu_inner_expr
) == VAR_DECL
5269 && (TREE_READONLY (gnu_inner_expr
)
5270 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr
)))
5271 && !CONTAINS_PLACEHOLDER_P (gnu_expr
));
5273 /* If this is a static expression or contains a discriminant, we don't
5274 need the variable for debugging (and can't elaborate anyway if a
5277 && (Is_OK_Static_Expression (gnat_expr
)
5278 || CONTAINS_PLACEHOLDER_P (gnu_expr
)))
5281 /* Now create the variable if we need it. */
5282 if (need_debug
|| (expr_variable
&& expr_global
))
5284 = create_var_decl (create_concat_name (gnat_entity
,
5285 IDENTIFIER_POINTER (gnu_name
)),
5286 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
5287 !need_debug
, Is_Public (gnat_entity
),
5288 !definition
, false, NULL
, gnat_entity
);
5290 /* We only need to use this variable if we are in global context since GCC
5291 can do the right thing in the local case. */
5292 if (expr_global
&& expr_variable
)
5294 else if (!expr_variable
)
5297 return maybe_variable (gnu_expr
);
5300 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5301 starting bit position so that it is aligned to ALIGN bits, and leaving at
5302 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5303 record is guaranteed to get. */
5306 make_aligning_type (tree type
, unsigned int align
, tree size
,
5307 unsigned int base_align
, int room
)
5309 /* We will be crafting a record type with one field at a position set to be
5310 the next multiple of ALIGN past record'address + room bytes. We use a
5311 record placeholder to express record'address. */
5313 tree record_type
= make_node (RECORD_TYPE
);
5314 tree record
= build0 (PLACEHOLDER_EXPR
, record_type
);
5317 = convert (sizetype
, build_unary_op (ADDR_EXPR
, NULL_TREE
, record
));
5319 /* The diagram below summarizes the shape of what we manipulate:
5321 <--------- pos ---------->
5322 { +------------+-------------+-----------------+
5323 record =>{ |############| ... | field (type) |
5324 { +------------+-------------+-----------------+
5325 |<-- room -->|<- voffset ->|<---- size ----->|
5328 record_addr vblock_addr
5330 Every length is in sizetype bytes there, except "pos" which has to be
5331 set as a bit position in the GCC tree for the record. */
5333 tree room_st
= size_int (room
);
5334 tree vblock_addr_st
= size_binop (PLUS_EXPR
, record_addr_st
, room_st
);
5335 tree voffset_st
, pos
, field
;
5337 tree name
= TYPE_NAME (type
);
5339 if (TREE_CODE (name
) == TYPE_DECL
)
5340 name
= DECL_NAME (name
);
5342 TYPE_NAME (record_type
) = concat_id_with_name (name
, "_ALIGN");
5344 /* Compute VOFFSET and then POS. The next byte position multiple of some
5345 alignment after some address is obtained by "and"ing the alignment minus
5346 1 with the two's complement of the address. */
5348 voffset_st
= size_binop (BIT_AND_EXPR
,
5349 size_diffop (size_zero_node
, vblock_addr_st
),
5350 ssize_int ((align
/ BITS_PER_UNIT
) - 1));
5352 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5354 pos
= size_binop (MULT_EXPR
,
5355 convert (bitsizetype
,
5356 size_binop (PLUS_EXPR
, room_st
, voffset_st
)),
5359 /* Craft the GCC record representation. We exceptionally do everything
5360 manually here because 1) our generic circuitry is not quite ready to
5361 handle the complex position/size expressions we are setting up, 2) we
5362 have a strong simplifying factor at hand: we know the maximum possible
5363 value of voffset, and 3) we have to set/reset at least the sizes in
5364 accordance with this maximum value anyway, as we need them to convey
5365 what should be "alloc"ated for this type.
5367 Use -1 as the 'addressable' indication for the field to prevent the
5368 creation of a bitfield. We don't need one, it would have damaging
5369 consequences on the alignment computation, and create_field_decl would
5370 make one without this special argument, for instance because of the
5371 complex position expression. */
5373 field
= create_field_decl (get_identifier ("F"), type
, record_type
,
5375 TYPE_FIELDS (record_type
) = field
;
5377 TYPE_ALIGN (record_type
) = base_align
;
5378 TYPE_USER_ALIGN (record_type
) = 1;
5380 TYPE_SIZE (record_type
)
5381 = size_binop (PLUS_EXPR
,
5382 size_binop (MULT_EXPR
, convert (bitsizetype
, size
),
5384 bitsize_int (align
+ room
* BITS_PER_UNIT
));
5385 TYPE_SIZE_UNIT (record_type
)
5386 = size_binop (PLUS_EXPR
, size
,
5387 size_int (room
+ align
/ BITS_PER_UNIT
));
5389 TYPE_MODE (record_type
) = BLKmode
;
5391 copy_alias_set (record_type
, type
);
5395 /* Return the result of rounding T up to ALIGN. */
5397 static inline unsigned HOST_WIDE_INT
5398 round_up_to_align (unsigned HOST_WIDE_INT t
, unsigned int align
)
5406 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5407 as the field type of a packed record if IN_RECORD is true, or as the
5408 component type of a packed array if IN_RECORD is false. See if we can
5409 rewrite it either as a type that has a non-BLKmode, which we can pack
5410 tighter in the packed record case, or as a smaller type with BLKmode.
5411 If so, return the new type. If not, return the original type. */
5414 make_packable_type (tree type
, bool in_record
)
5416 unsigned HOST_WIDE_INT size
= tree_low_cst (TYPE_SIZE (type
), 1);
5417 unsigned HOST_WIDE_INT new_size
;
5418 tree new_type
, old_field
, field_list
= NULL_TREE
;
5420 /* No point in doing anything if the size is zero. */
5424 new_type
= make_node (TREE_CODE (type
));
5426 /* Copy the name and flags from the old type to that of the new. Note
5427 that we rely on the pointer equality created here for TYPE_NAME at
5428 the end of gnat_to_gnu. */
5429 TYPE_NAME (new_type
) = TYPE_NAME (type
);
5430 TYPE_JUSTIFIED_MODULAR_P (new_type
) = TYPE_JUSTIFIED_MODULAR_P (type
);
5431 TYPE_CONTAINS_TEMPLATE_P (new_type
) = TYPE_CONTAINS_TEMPLATE_P (type
);
5432 if (TREE_CODE (type
) == RECORD_TYPE
)
5433 TYPE_IS_PADDING_P (new_type
) = TYPE_IS_PADDING_P (type
);
5435 /* If we are in a record and have a small size, set the alignment to
5436 try for an integral mode. Otherwise set it to try for a smaller
5437 type with BLKmode. */
5438 if (in_record
&& size
<= MAX_FIXED_MODE_SIZE
)
5440 TYPE_ALIGN (new_type
) = ceil_alignment (size
);
5441 new_size
= round_up_to_align (size
, TYPE_ALIGN (new_type
));
5445 unsigned HOST_WIDE_INT align
;
5447 /* Do not try to shrink the size if the RM size is not constant. */
5448 if (TYPE_CONTAINS_TEMPLATE_P (type
)
5449 || !host_integerp (TYPE_ADA_SIZE (type
), 1))
5452 /* Round the RM size up to a unit boundary to get the minimal size
5453 for a BLKmode record. Give up if it's already the size. */
5454 new_size
= TREE_INT_CST_LOW (TYPE_ADA_SIZE (type
));
5455 new_size
= round_up_to_align (new_size
, BITS_PER_UNIT
);
5456 if (new_size
== size
)
5459 align
= new_size
& -new_size
;
5460 TYPE_ALIGN (new_type
) = MIN (TYPE_ALIGN (type
), align
);
5463 TYPE_USER_ALIGN (new_type
) = 1;
5465 /* Now copy the fields, keeping the position and size as we don't
5466 want to propagate packedness downward. But make an exception
5467 for the last field in order to ditch the padding bits. */
5468 for (old_field
= TYPE_FIELDS (type
); old_field
;
5469 old_field
= TREE_CHAIN (old_field
))
5471 tree new_field_type
= TREE_TYPE (old_field
);
5472 tree new_field
, new_size
;
5474 if (TYPE_MODE (new_field_type
) == BLKmode
5475 && (TREE_CODE (new_field_type
) == RECORD_TYPE
5476 || TREE_CODE (new_field_type
) == UNION_TYPE
5477 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
5478 && host_integerp (TYPE_SIZE (new_field_type
), 1))
5479 new_field_type
= make_packable_type (new_field_type
, true);
5481 if (!TREE_CHAIN (old_field
) && !TYPE_PACKED (type
))
5482 new_size
= rm_size (new_field_type
);
5484 new_size
= DECL_SIZE (old_field
);
5486 new_field
= create_field_decl (DECL_NAME (old_field
), new_field_type
,
5487 new_type
, TYPE_PACKED (type
), new_size
,
5488 bit_position (old_field
),
5489 !DECL_NONADDRESSABLE_P (old_field
));
5491 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
5492 SET_DECL_ORIGINAL_FIELD
5493 (new_field
, (DECL_ORIGINAL_FIELD (old_field
)
5494 ? DECL_ORIGINAL_FIELD (old_field
) : old_field
));
5496 if (TREE_CODE (new_type
) == QUAL_UNION_TYPE
)
5497 DECL_QUALIFIER (new_field
) = DECL_QUALIFIER (old_field
);
5499 TREE_CHAIN (new_field
) = field_list
;
5500 field_list
= new_field
;
5503 finish_record_type (new_type
, nreverse (field_list
), 2, true);
5504 copy_alias_set (new_type
, type
);
5506 /* If this is a padding record, we never want to make the size smaller
5507 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5508 if ((TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5509 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
5511 TYPE_SIZE (new_type
) = TYPE_SIZE (type
);
5512 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (type
);
5516 TYPE_SIZE (new_type
) = bitsize_int (new_size
);
5517 TYPE_SIZE_UNIT (new_type
)
5518 = size_int ((new_size
+ BITS_PER_UNIT
- 1) / BITS_PER_UNIT
);
5521 if (!TYPE_CONTAINS_TEMPLATE_P (type
))
5522 SET_TYPE_ADA_SIZE (new_type
, TYPE_ADA_SIZE (type
));
5524 compute_record_mode (new_type
);
5526 /* Try harder to get a packable type if necessary, for example
5527 in case the record itself contains a BLKmode field. */
5528 if (in_record
&& TYPE_MODE (new_type
) == BLKmode
)
5529 TYPE_MODE (new_type
)
5530 = mode_for_size_tree (TYPE_SIZE (new_type
), MODE_INT
, 1);
5532 /* If neither the mode nor the size has shrunk, return the old type. */
5533 if (TYPE_MODE (new_type
) == BLKmode
&& new_size
>= size
)
5539 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5540 if needed. We have already verified that SIZE and TYPE are large enough.
5542 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5545 IS_USER_TYPE is true if we must be sure we complete the original type.
5547 DEFINITION is true if this type is being defined.
5549 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
5550 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
5554 maybe_pad_type (tree type
, tree size
, unsigned int align
,
5555 Entity_Id gnat_entity
, const char *name_trailer
,
5556 bool is_user_type
, bool definition
, bool same_rm_size
)
5558 tree orig_size
= TYPE_SIZE (type
);
5559 unsigned int orig_align
= align
;
5563 /* If TYPE is a padded type, see if it agrees with any size and alignment
5564 we were given. If so, return the original type. Otherwise, strip
5565 off the padding, since we will either be returning the inner type
5566 or repadding it. If no size or alignment is specified, use that of
5567 the original padded type. */
5568 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5571 || operand_equal_p (round_up (size
,
5572 MAX (align
, TYPE_ALIGN (type
))),
5573 round_up (TYPE_SIZE (type
),
5574 MAX (align
, TYPE_ALIGN (type
))),
5576 && (align
== 0 || align
== TYPE_ALIGN (type
)))
5580 size
= TYPE_SIZE (type
);
5582 align
= TYPE_ALIGN (type
);
5584 type
= TREE_TYPE (TYPE_FIELDS (type
));
5585 orig_size
= TYPE_SIZE (type
);
5588 /* If the size is either not being changed or is being made smaller (which
5589 is not done here (and is only valid for bitfields anyway), show the size
5590 isn't changing. Likewise, clear the alignment if it isn't being
5591 changed. Then return if we aren't doing anything. */
5593 && (operand_equal_p (size
, orig_size
, 0)
5594 || (TREE_CODE (orig_size
) == INTEGER_CST
5595 && tree_int_cst_lt (size
, orig_size
))))
5598 if (align
== TYPE_ALIGN (type
))
5601 if (align
== 0 && !size
)
5604 /* We used to modify the record in place in some cases, but that could
5605 generate incorrect debugging information. So make a new record
5607 record
= make_node (RECORD_TYPE
);
5609 if (Present (gnat_entity
))
5610 TYPE_NAME (record
) = create_concat_name (gnat_entity
, name_trailer
);
5612 /* If we were making a type, complete the original type and give it a
5615 create_type_decl (get_entity_name (gnat_entity
), type
,
5616 NULL
, !Comes_From_Source (gnat_entity
),
5618 && TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
5619 && DECL_IGNORED_P (TYPE_NAME (type
))),
5622 /* If we are changing the alignment and the input type is a record with
5623 BLKmode and a small constant size, try to make a form that has an
5624 integral mode. That might allow this record to have an integral mode,
5625 which will be much more efficient. There is no point in doing this if a
5626 size is specified unless it is also smaller than the maximum mode size
5627 and it is incorrect to do this if the size of the original type is not a
5628 multiple of the alignment. */
5630 && TREE_CODE (type
) == RECORD_TYPE
5631 && TYPE_MODE (type
) == BLKmode
5632 && TREE_CODE (orig_size
) == INTEGER_CST
5633 && compare_tree_int (orig_size
, MAX_FIXED_MODE_SIZE
) <= 0
5635 || (TREE_CODE (size
) == INTEGER_CST
5636 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) <= 0))
5637 && value_factor_p (orig_size
, align
))
5638 type
= make_packable_type (type
, true);
5640 field
= create_field_decl (get_identifier ("F"), type
, record
, 0,
5641 NULL_TREE
, bitsize_zero_node
, 1);
5643 DECL_INTERNAL_P (field
) = 1;
5644 TYPE_SIZE (record
) = size
? size
: orig_size
;
5645 TYPE_SIZE_UNIT (record
)
5646 = (size
? convert (sizetype
,
5647 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
))
5648 : TYPE_SIZE_UNIT (type
));
5650 TYPE_ALIGN (record
) = align
;
5652 TYPE_USER_ALIGN (record
) = align
;
5654 TYPE_IS_PADDING_P (record
) = 1;
5655 TYPE_VOLATILE (record
)
5656 = Present (gnat_entity
) && Treat_As_Volatile (gnat_entity
);
5657 /* Do not finalize it until after the auxiliary record is built. */
5658 finish_record_type (record
, field
, 1, true);
5660 /* Keep the RM_Size of the padded record as that of the old record
5662 SET_TYPE_ADA_SIZE (record
, same_rm_size
? size
: rm_size (type
));
5664 /* Unless debugging information isn't being written for the input type,
5665 write a record that shows what we are a subtype of and also make a
5666 variable that indicates our size, if variable. */
5667 if (TYPE_NAME (record
)
5668 && AGGREGATE_TYPE_P (type
)
5669 && (TREE_CODE (TYPE_NAME (type
)) != TYPE_DECL
5670 || !DECL_IGNORED_P (TYPE_NAME (type
))))
5672 tree marker
= make_node (RECORD_TYPE
);
5673 tree name
= TYPE_NAME (record
);
5674 tree orig_name
= TYPE_NAME (type
);
5676 if (TREE_CODE (name
) == TYPE_DECL
)
5677 name
= DECL_NAME (name
);
5679 if (TREE_CODE (orig_name
) == TYPE_DECL
)
5680 orig_name
= DECL_NAME (orig_name
);
5682 TYPE_NAME (marker
) = concat_id_with_name (name
, "XVS");
5683 finish_record_type (marker
,
5684 create_field_decl (orig_name
, integer_type_node
,
5685 marker
, 0, NULL_TREE
, NULL_TREE
,
5689 if (size
&& TREE_CODE (size
) != INTEGER_CST
&& definition
)
5690 create_var_decl (concat_id_with_name (name
, "XVZ"), NULL_TREE
,
5691 bitsizetype
, TYPE_SIZE (record
), false, false, false,
5692 false, NULL
, gnat_entity
);
5695 rest_of_record_type_compilation (record
);
5697 /* If the size was widened explicitly, maybe give a warning. Take the
5698 original size as the maximum size of the input if there was an
5699 unconstrained record involved and round it up to the specified alignment,
5700 if one was specified. */
5701 if (CONTAINS_PLACEHOLDER_P (orig_size
))
5702 orig_size
= max_size (orig_size
, true);
5705 orig_size
= round_up (orig_size
, align
);
5707 if (size
&& Present (gnat_entity
)
5708 && !operand_equal_p (size
, orig_size
, 0)
5709 && !(TREE_CODE (size
) == INTEGER_CST
5710 && TREE_CODE (orig_size
) == INTEGER_CST
5711 && tree_int_cst_lt (size
, orig_size
)))
5713 Node_Id gnat_error_node
= Empty
;
5715 if (Is_Packed_Array_Type (gnat_entity
))
5716 gnat_entity
= Original_Array_Type (gnat_entity
);
5718 if ((Ekind (gnat_entity
) == E_Component
5719 || Ekind (gnat_entity
) == E_Discriminant
)
5720 && Present (Component_Clause (gnat_entity
)))
5721 gnat_error_node
= Last_Bit (Component_Clause (gnat_entity
));
5722 else if (Present (Size_Clause (gnat_entity
)))
5723 gnat_error_node
= Expression (Size_Clause (gnat_entity
));
5725 /* Generate message only for entities that come from source, since
5726 if we have an entity created by expansion, the message will be
5727 generated for some other corresponding source entity. */
5728 if (Comes_From_Source (gnat_entity
) && Present (gnat_error_node
))
5729 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node
,
5731 size_diffop (size
, orig_size
));
5733 else if (*name_trailer
== 'C' && !Is_Internal (gnat_entity
))
5734 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5735 gnat_entity
, gnat_entity
,
5736 size_diffop (size
, orig_size
));
5742 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5743 the value passed against the list of choices. */
5746 choices_to_gnu (tree operand
, Node_Id choices
)
5750 tree result
= integer_zero_node
;
5751 tree this_test
, low
= 0, high
= 0, single
= 0;
5753 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
5755 switch (Nkind (choice
))
5758 low
= gnat_to_gnu (Low_Bound (choice
));
5759 high
= gnat_to_gnu (High_Bound (choice
));
5761 /* There's no good type to use here, so we might as well use
5762 integer_type_node. */
5764 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5765 build_binary_op (GE_EXPR
, integer_type_node
,
5767 build_binary_op (LE_EXPR
, integer_type_node
,
5772 case N_Subtype_Indication
:
5773 gnat_temp
= Range_Expression (Constraint (choice
));
5774 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
5775 high
= gnat_to_gnu (High_Bound (gnat_temp
));
5778 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5779 build_binary_op (GE_EXPR
, integer_type_node
,
5781 build_binary_op (LE_EXPR
, integer_type_node
,
5786 case N_Expanded_Name
:
5787 /* This represents either a subtype range, an enumeration
5788 literal, or a constant Ekind says which. If an enumeration
5789 literal or constant, fall through to the next case. */
5790 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
5791 && Ekind (Entity (choice
)) != E_Constant
)
5793 tree type
= gnat_to_gnu_type (Entity (choice
));
5795 low
= TYPE_MIN_VALUE (type
);
5796 high
= TYPE_MAX_VALUE (type
);
5799 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5800 build_binary_op (GE_EXPR
, integer_type_node
,
5802 build_binary_op (LE_EXPR
, integer_type_node
,
5806 /* ... fall through ... */
5807 case N_Character_Literal
:
5808 case N_Integer_Literal
:
5809 single
= gnat_to_gnu (choice
);
5810 this_test
= build_binary_op (EQ_EXPR
, integer_type_node
, operand
,
5814 case N_Others_Choice
:
5815 this_test
= integer_one_node
;
5822 result
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5829 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5830 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
5833 adjust_packed (tree field_type
, tree record_type
, int packed
)
5835 /* If the field contains an item of variable size, we cannot pack it
5836 because we cannot create temporaries of non-fixed size in case
5837 we need to take the address of the field. See addressable_p and
5838 the notes on the addressability issues for further details. */
5839 if (is_variable_size (field_type
))
5842 /* If the alignment of the record is specified and the field type
5843 is over-aligned, request Storage_Unit alignment for the field. */
5846 if (TYPE_ALIGN (field_type
) > TYPE_ALIGN (record_type
))
5855 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5856 placed in GNU_RECORD_TYPE.
5858 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
5859 record has Component_Alignment of Storage_Unit, -2 if the enclosing
5860 record has a specified alignment.
5862 DEFINITION is true if this field is for a record being defined. */
5865 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
5868 tree gnu_field_id
= get_entity_name (gnat_field
);
5869 tree gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
5870 tree gnu_field
, gnu_size
, gnu_pos
;
5871 bool needs_strict_alignment
5872 = (Is_Aliased (gnat_field
) || Strict_Alignment (Etype (gnat_field
))
5873 || Treat_As_Volatile (gnat_field
));
5875 /* If this field requires strict alignment, we cannot pack it because
5876 it would very likely be under-aligned in the record. */
5877 if (needs_strict_alignment
)
5880 packed
= adjust_packed (gnu_field_type
, gnu_record_type
, packed
);
5882 /* If a size is specified, use it. Otherwise, if the record type is packed,
5883 use the official RM size. See "Handling of Type'Size Values" in Einfo
5884 for further details. */
5885 if (Known_Static_Esize (gnat_field
))
5886 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5887 gnat_field
, FIELD_DECL
, false, true);
5888 else if (packed
== 1)
5889 gnu_size
= validate_size (RM_Size (Etype (gnat_field
)), gnu_field_type
,
5890 gnat_field
, FIELD_DECL
, false, true);
5892 gnu_size
= NULL_TREE
;
5894 /* If we have a specified size that's smaller than that of the field type,
5895 or a position is specified, and the field type is also a record that's
5896 BLKmode, see if we can get either an integral mode form of the type or
5897 a smaller BLKmode form. If we can, show a size was specified for the
5898 field if there wasn't one already, so we know to make this a bitfield
5899 and avoid making things wider.
5901 Doing this is first useful if the record is packed because we may then
5902 place the field at a non-byte-aligned position and so achieve tighter
5905 This is in addition *required* if the field shares a byte with another
5906 field and the front-end lets the back-end handle the references, because
5907 GCC does not handle BLKmode bitfields properly.
5909 We avoid the transformation if it is not required or potentially useful,
5910 as it might entail an increase of the field's alignment and have ripple
5911 effects on the outer record type. A typical case is a field known to be
5912 byte aligned and not to share a byte with another field.
5914 Besides, we don't even look the possibility of a transformation in cases
5915 known to be in error already, for instance when an invalid size results
5916 from a component clause. */
5918 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
5919 && TYPE_MODE (gnu_field_type
) == BLKmode
5920 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
5923 && (tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
))
5924 || Present (Component_Clause (gnat_field
))))))
5926 /* See what the alternate type and size would be. */
5927 tree gnu_packable_type
= make_packable_type (gnu_field_type
, true);
5929 bool has_byte_aligned_clause
5930 = Present (Component_Clause (gnat_field
))
5931 && (UI_To_Int (Component_Bit_Offset (gnat_field
))
5932 % BITS_PER_UNIT
== 0);
5934 /* Compute whether we should avoid the substitution. */
5936 /* There is no point substituting if there is no change... */
5937 = (gnu_packable_type
== gnu_field_type
)
5938 /* ... nor when the field is known to be byte aligned and not to
5939 share a byte with another field. */
5940 || (has_byte_aligned_clause
5941 && value_factor_p (gnu_size
, BITS_PER_UNIT
))
5942 /* The size of an aliased field must be an exact multiple of the
5943 type's alignment, which the substitution might increase. Reject
5944 substitutions that would so invalidate a component clause when the
5945 specified position is byte aligned, as the change would have no
5946 real benefit from the packing standpoint anyway. */
5947 || (Is_Aliased (gnat_field
)
5948 && has_byte_aligned_clause
5949 && !value_factor_p (gnu_size
, TYPE_ALIGN (gnu_packable_type
)));
5951 /* Substitute unless told otherwise. */
5954 gnu_field_type
= gnu_packable_type
;
5957 gnu_size
= rm_size (gnu_field_type
);
5961 /* If we are packing the record and the field is BLKmode, round the
5962 size up to a byte boundary. */
5963 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
5964 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
5966 if (Present (Component_Clause (gnat_field
)))
5968 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
5969 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5970 gnat_field
, FIELD_DECL
, false, true);
5972 /* Ensure the position does not overlap with the parent subtype,
5974 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field
)))))
5977 = gnat_to_gnu_type (Parent_Subtype
5978 (Underlying_Type (Scope (gnat_field
))));
5980 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
5981 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
5984 ("offset of& must be beyond parent{, minimum allowed is ^}",
5985 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5986 TYPE_SIZE_UNIT (gnu_parent
));
5990 /* If this field needs strict alignment, ensure the record is
5991 sufficiently aligned and that that position and size are
5992 consistent with the alignment. */
5993 if (needs_strict_alignment
)
5995 TYPE_ALIGN (gnu_record_type
)
5996 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
5999 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
6001 if (Is_Atomic (gnat_field
) || Is_Atomic (Etype (gnat_field
)))
6003 ("atomic field& must be natural size of type{ (^)}",
6004 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6005 TYPE_SIZE (gnu_field_type
));
6007 else if (Is_Aliased (gnat_field
))
6009 ("size of aliased field& must be ^ bits",
6010 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6011 TYPE_SIZE (gnu_field_type
));
6013 else if (Strict_Alignment (Etype (gnat_field
)))
6015 ("size of & with aliased or tagged components not ^ bits",
6016 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
6017 TYPE_SIZE (gnu_field_type
));
6019 gnu_size
= NULL_TREE
;
6022 if (!integer_zerop (size_binop
6023 (TRUNC_MOD_EXPR
, gnu_pos
,
6024 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
6026 if (Is_Aliased (gnat_field
))
6028 ("position of aliased field& must be multiple of ^ bits",
6029 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6030 TYPE_ALIGN (gnu_field_type
));
6032 else if (Treat_As_Volatile (gnat_field
))
6034 ("position of volatile field& must be multiple of ^ bits",
6035 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6036 TYPE_ALIGN (gnu_field_type
));
6038 else if (Strict_Alignment (Etype (gnat_field
)))
6040 ("position of & with aliased or tagged components not multiple of ^ bits",
6041 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
6042 TYPE_ALIGN (gnu_field_type
));
6047 gnu_pos
= NULL_TREE
;
6051 if (Is_Atomic (gnat_field
))
6052 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
6055 /* If the record has rep clauses and this is the tag field, make a rep
6056 clause for it as well. */
6057 else if (Has_Specified_Layout (Scope (gnat_field
))
6058 && Chars (gnat_field
) == Name_uTag
)
6060 gnu_pos
= bitsize_zero_node
;
6061 gnu_size
= TYPE_SIZE (gnu_field_type
);
6065 gnu_pos
= NULL_TREE
;
6067 /* We need to make the size the maximum for the type if it is
6068 self-referential and an unconstrained type. In that case, we can't
6069 pack the field since we can't make a copy to align it. */
6070 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
6072 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
6073 && !Is_Constrained (Underlying_Type (Etype (gnat_field
))))
6075 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
6079 /* If a size is specified, adjust the field's type to it. */
6082 /* If the field's type is justified modular, we would need to remove
6083 the wrapper to (better) meet the layout requirements. However we
6084 can do so only if the field is not aliased to preserve the unique
6085 layout and if the prescribed size is not greater than that of the
6086 packed array to preserve the justification. */
6087 if (!needs_strict_alignment
6088 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
6089 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
6090 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
6092 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
6095 = make_type_from_size (gnu_field_type
, gnu_size
,
6096 Has_Biased_Representation (gnat_field
));
6097 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
6098 "PAD", false, definition
, true);
6101 /* Otherwise (or if there was an error), don't specify a position. */
6103 gnu_pos
= NULL_TREE
;
6105 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
6106 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
6108 /* Now create the decl for the field. */
6109 gnu_field
= create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
6110 packed
, gnu_size
, gnu_pos
,
6111 Is_Aliased (gnat_field
));
6112 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
6113 TREE_THIS_VOLATILE (gnu_field
) = Treat_As_Volatile (gnat_field
);
6115 if (Ekind (gnat_field
) == E_Discriminant
)
6116 DECL_DISCRIMINANT_NUMBER (gnu_field
)
6117 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
6122 /* Return true if TYPE is a type with variable size, a padding type with a
6123 field of variable size or is a record that has a field such a field. */
6126 is_variable_size (tree type
)
6130 if (!TREE_CONSTANT (TYPE_SIZE (type
)))
6133 if (TREE_CODE (type
) == RECORD_TYPE
6134 && TYPE_IS_PADDING_P (type
)
6135 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
6138 if (TREE_CODE (type
) != RECORD_TYPE
6139 && TREE_CODE (type
) != UNION_TYPE
6140 && TREE_CODE (type
) != QUAL_UNION_TYPE
)
6143 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
6144 if (is_variable_size (TREE_TYPE (field
)))
6150 /* qsort comparer for the bit positions of two record components. */
6153 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
6155 const_tree
const field1
= * (const_tree
const *) rt1
;
6156 const_tree
const field2
= * (const_tree
const *) rt2
;
6158 = tree_int_cst_compare (bit_position (field1
), bit_position (field2
));
6160 return ret
? ret
: (int) (DECL_UID (field1
) - DECL_UID (field2
));
6163 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6164 of GCC trees for fields that are in the record and have already been
6165 processed. When called from gnat_to_gnu_entity during the processing of a
6166 record type definition, the GCC nodes for the discriminants will be on
6167 the chain. The other calls to this function are recursive calls from
6168 itself for the Component_List of a variant and the chain is empty.
6170 PACKED is 1 if this is for a packed record, -1 if this is for a record
6171 with Component_Alignment of Storage_Unit, -2 if this is for a record
6172 with a specified alignment.
6174 DEFINITION is true if we are defining this record.
6176 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6177 with a rep clause is to be added. If it is nonzero, that is all that
6178 should be done with such fields.
6180 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6181 laying out the record. This means the alignment only serves to force fields
6182 to be bitfields, but not require the record to be that aligned. This is
6185 ALL_REP, if true, means a rep clause was found for all the fields. This
6186 simplifies the logic since we know we're not in the mixed case.
6188 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6189 modified afterwards so it will not be sent to the back-end for finalization.
6191 UNCHECKED_UNION, if true, means that we are building a type for a record
6192 with a Pragma Unchecked_Union.
6194 The processing of the component list fills in the chain with all of the
6195 fields of the record and then the record type is finished. */
6198 components_to_record (tree gnu_record_type
, Node_Id component_list
,
6199 tree gnu_field_list
, int packed
, bool definition
,
6200 tree
*p_gnu_rep_list
, bool cancel_alignment
,
6201 bool all_rep
, bool do_not_finalize
, bool unchecked_union
)
6203 Node_Id component_decl
;
6204 Entity_Id gnat_field
;
6205 Node_Id variant_part
;
6206 tree gnu_our_rep_list
= NULL_TREE
;
6207 tree gnu_field
, gnu_last
;
6208 bool layout_with_rep
= false;
6209 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
6211 /* For each variable within each component declaration create a GCC field
6212 and add it to the list, skipping any pragmas in the list. */
6213 if (Present (Component_Items (component_list
)))
6214 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
6215 Present (component_decl
);
6216 component_decl
= Next_Non_Pragma (component_decl
))
6218 gnat_field
= Defining_Entity (component_decl
);
6220 if (Chars (gnat_field
) == Name_uParent
)
6221 gnu_field
= tree_last (TYPE_FIELDS (gnu_record_type
));
6224 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
,
6225 packed
, definition
);
6227 /* If this is the _Tag field, put it before any discriminants,
6228 instead of after them as is the case for all other fields.
6229 Ignore field of void type if only annotating. */
6230 if (Chars (gnat_field
) == Name_uTag
)
6231 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6234 TREE_CHAIN (gnu_field
) = gnu_field_list
;
6235 gnu_field_list
= gnu_field
;
6239 save_gnu_tree (gnat_field
, gnu_field
, false);
6242 /* At the end of the component list there may be a variant part. */
6243 variant_part
= Variant_Part (component_list
);
6245 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6246 mutually exclusive and should go in the same memory. To do this we need
6247 to treat each variant as a record whose elements are created from the
6248 component list for the variant. So here we create the records from the
6249 lists for the variants and put them all into the QUAL_UNION_TYPE.
6250 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6251 use GNU_RECORD_TYPE if there are no fields so far. */
6252 if (Present (variant_part
))
6254 tree gnu_discriminant
= gnat_to_gnu (Name (variant_part
));
6256 tree gnu_name
= TYPE_NAME (gnu_record_type
);
6258 = concat_id_with_name (get_identifier (Get_Name_String
6259 (Chars (Name (variant_part
)))),
6261 tree gnu_union_type
;
6262 tree gnu_union_name
;
6263 tree gnu_union_field
;
6264 tree gnu_variant_list
= NULL_TREE
;
6266 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
6267 gnu_name
= DECL_NAME (gnu_name
);
6269 gnu_union_name
= concat_id_with_name (gnu_name
,
6270 IDENTIFIER_POINTER (gnu_var_name
));
6272 /* Reuse an enclosing union if all fields are in the variant part
6273 and there is no representation clause on the record, to match
6274 the layout of C unions. There is an associated check below. */
6276 && TREE_CODE (gnu_record_type
) == UNION_TYPE
6277 && !TYPE_PACKED (gnu_record_type
))
6278 gnu_union_type
= gnu_record_type
;
6282 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
6284 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
6285 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
6288 for (variant
= First_Non_Pragma (Variants (variant_part
));
6290 variant
= Next_Non_Pragma (variant
))
6292 tree gnu_variant_type
= make_node (RECORD_TYPE
);
6293 tree gnu_inner_name
;
6296 Get_Variant_Encoding (variant
);
6297 gnu_inner_name
= get_identifier (Name_Buffer
);
6298 TYPE_NAME (gnu_variant_type
)
6299 = concat_id_with_name (gnu_union_name
,
6300 IDENTIFIER_POINTER (gnu_inner_name
));
6302 /* Set the alignment of the inner type in case we need to make
6303 inner objects into bitfields, but then clear it out
6304 so the record actually gets only the alignment required. */
6305 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
6306 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
6308 /* Similarly, if the outer record has a size specified and all fields
6309 have record rep clauses, we can propagate the size into the
6311 if (all_rep_and_size
)
6313 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
6314 TYPE_SIZE_UNIT (gnu_variant_type
)
6315 = TYPE_SIZE_UNIT (gnu_record_type
);
6318 /* Create the record type for the variant. Note that we defer
6319 finalizing it until after we are sure to actually use it. */
6320 components_to_record (gnu_variant_type
, Component_List (variant
),
6321 NULL_TREE
, packed
, definition
,
6322 &gnu_our_rep_list
, !all_rep_and_size
, all_rep
,
6323 true, unchecked_union
);
6325 gnu_qual
= choices_to_gnu (gnu_discriminant
,
6326 Discrete_Choices (variant
));
6328 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
6330 /* If this is an Unchecked_Union and we have exactly one field,
6331 use this field directly to match the layout of C unions. */
6333 && TYPE_FIELDS (gnu_variant_type
)
6334 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type
)))
6335 gnu_field
= TYPE_FIELDS (gnu_variant_type
);
6338 /* Deal with packedness like in gnat_to_gnu_field. */
6340 = adjust_packed (gnu_variant_type
, gnu_record_type
, packed
);
6342 /* Finalize the record type now. We used to throw away
6343 empty records but we no longer do that because we need
6344 them to generate complete debug info for the variant;
6345 otherwise, the union type definition will be lacking
6346 the fields associated with these empty variants. */
6347 rest_of_record_type_compilation (gnu_variant_type
);
6349 gnu_field
= create_field_decl (gnu_inner_name
, gnu_variant_type
,
6350 gnu_union_type
, field_packed
,
6352 ? TYPE_SIZE (gnu_variant_type
)
6355 ? bitsize_zero_node
: 0),
6358 DECL_INTERNAL_P (gnu_field
) = 1;
6360 if (!unchecked_union
)
6361 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
6364 TREE_CHAIN (gnu_field
) = gnu_variant_list
;
6365 gnu_variant_list
= gnu_field
;
6368 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6369 if (gnu_variant_list
)
6371 if (all_rep_and_size
)
6373 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
6374 TYPE_SIZE_UNIT (gnu_union_type
)
6375 = TYPE_SIZE_UNIT (gnu_record_type
);
6378 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
6379 all_rep_and_size
? 1 : 0, false);
6381 /* If GNU_UNION_TYPE is our record type, it means we must have an
6382 Unchecked_Union with no fields. Verify that and, if so, just
6384 if (gnu_union_type
== gnu_record_type
)
6386 gcc_assert (unchecked_union
6388 && !gnu_our_rep_list
);
6393 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
6395 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
6396 all_rep
? bitsize_zero_node
: 0, 0);
6398 DECL_INTERNAL_P (gnu_union_field
) = 1;
6399 TREE_CHAIN (gnu_union_field
) = gnu_field_list
;
6400 gnu_field_list
= gnu_union_field
;
6404 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6405 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6406 in a separate pass since we want to handle the discriminants but can't
6407 play with them until we've used them in debugging data above.
6409 ??? Note: if we then reorder them, debugging information will be wrong,
6410 but there's nothing that can be done about this at the moment. */
6411 for (gnu_field
= gnu_field_list
, gnu_last
= NULL_TREE
; gnu_field
; )
6413 if (DECL_FIELD_OFFSET (gnu_field
))
6415 tree gnu_next
= TREE_CHAIN (gnu_field
);
6418 gnu_field_list
= gnu_next
;
6420 TREE_CHAIN (gnu_last
) = gnu_next
;
6422 TREE_CHAIN (gnu_field
) = gnu_our_rep_list
;
6423 gnu_our_rep_list
= gnu_field
;
6424 gnu_field
= gnu_next
;
6428 gnu_last
= gnu_field
;
6429 gnu_field
= TREE_CHAIN (gnu_field
);
6433 /* If we have any items in our rep'ed field list, it is not the case that all
6434 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6435 set it and ignore the items. */
6436 if (gnu_our_rep_list
&& p_gnu_rep_list
&& !all_rep
)
6437 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_our_rep_list
);
6438 else if (gnu_our_rep_list
)
6440 /* Otherwise, sort the fields by bit position and put them into their
6441 own record if we have any fields without rep clauses. */
6443 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
6444 int len
= list_length (gnu_our_rep_list
);
6445 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * len
);
6448 for (i
= 0, gnu_field
= gnu_our_rep_list
; gnu_field
;
6449 gnu_field
= TREE_CHAIN (gnu_field
), i
++)
6450 gnu_arr
[i
] = gnu_field
;
6452 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
6454 /* Put the fields in the list in order of increasing position, which
6455 means we start from the end. */
6456 gnu_our_rep_list
= NULL_TREE
;
6457 for (i
= len
- 1; i
>= 0; i
--)
6459 TREE_CHAIN (gnu_arr
[i
]) = gnu_our_rep_list
;
6460 gnu_our_rep_list
= gnu_arr
[i
];
6461 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
6466 finish_record_type (gnu_rep_type
, gnu_our_rep_list
, 1, false);
6467 gnu_field
= create_field_decl (get_identifier ("REP"), gnu_rep_type
,
6468 gnu_record_type
, 0, 0, 0, 1);
6469 DECL_INTERNAL_P (gnu_field
) = 1;
6470 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
6474 layout_with_rep
= true;
6475 gnu_field_list
= nreverse (gnu_our_rep_list
);
6479 if (cancel_alignment
)
6480 TYPE_ALIGN (gnu_record_type
) = 0;
6482 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
6483 layout_with_rep
? 1 : 0, do_not_finalize
);
6486 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6487 placed into an Esize, Component_Bit_Offset, or Component_Size value
6488 in the GNAT tree. */
6491 annotate_value (tree gnu_size
)
6493 int len
= TREE_CODE_LENGTH (TREE_CODE (gnu_size
));
6495 Node_Ref_Or_Val ops
[3], ret
;
6498 struct tree_int_map
**h
= NULL
;
6500 /* See if we've already saved the value for this node. */
6501 if (EXPR_P (gnu_size
))
6503 struct tree_int_map in
;
6504 if (!annotate_value_cache
)
6505 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
6506 tree_int_map_eq
, 0);
6507 in
.base
.from
= gnu_size
;
6508 h
= (struct tree_int_map
**)
6509 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
6512 return (Node_Ref_Or_Val
) (*h
)->to
;
6515 /* If we do not return inside this switch, TCODE will be set to the
6516 code to use for a Create_Node operand and LEN (set above) will be
6517 the number of recursive calls for us to make. */
6519 switch (TREE_CODE (gnu_size
))
6522 if (TREE_OVERFLOW (gnu_size
))
6525 /* This may have come from a conversion from some smaller type,
6526 so ensure this is in bitsizetype. */
6527 gnu_size
= convert (bitsizetype
, gnu_size
);
6529 /* For negative values, use NEGATE_EXPR of the supplied value. */
6530 if (tree_int_cst_sgn (gnu_size
) < 0)
6532 /* The ridiculous code below is to handle the case of the largest
6533 negative integer. */
6534 tree negative_size
= size_diffop (bitsize_zero_node
, gnu_size
);
6535 bool adjust
= false;
6538 if (TREE_OVERFLOW (negative_size
))
6541 = size_binop (MINUS_EXPR
, bitsize_zero_node
,
6542 size_binop (PLUS_EXPR
, gnu_size
,
6547 temp
= build1 (NEGATE_EXPR
, bitsizetype
, negative_size
);
6549 temp
= build2 (MINUS_EXPR
, bitsizetype
, temp
, bitsize_one_node
);
6551 return annotate_value (temp
);
6554 if (!host_integerp (gnu_size
, 1))
6557 size
= tree_low_cst (gnu_size
, 1);
6559 /* This peculiar test is to make sure that the size fits in an int
6560 on machines where HOST_WIDE_INT is not "int". */
6561 if (tree_low_cst (gnu_size
, 1) == size
)
6562 return UI_From_Int (size
);
6567 /* The only case we handle here is a simple discriminant reference. */
6568 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
6569 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
6570 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
6571 return Create_Node (Discrim_Val
,
6572 annotate_value (DECL_DISCRIMINANT_NUMBER
6573 (TREE_OPERAND (gnu_size
, 1))),
6578 case NOP_EXPR
: case CONVERT_EXPR
: case NON_LVALUE_EXPR
:
6579 return annotate_value (TREE_OPERAND (gnu_size
, 0));
6581 /* Now just list the operations we handle. */
6582 case COND_EXPR
: tcode
= Cond_Expr
; break;
6583 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
6584 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
6585 case MULT_EXPR
: tcode
= Mult_Expr
; break;
6586 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
6587 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
6588 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
6589 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
6590 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
6591 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
6592 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
6593 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
6594 case MIN_EXPR
: tcode
= Min_Expr
; break;
6595 case MAX_EXPR
: tcode
= Max_Expr
; break;
6596 case ABS_EXPR
: tcode
= Abs_Expr
; break;
6597 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
6598 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
6599 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
6600 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
6601 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
6602 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
6603 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
6604 case LT_EXPR
: tcode
= Lt_Expr
; break;
6605 case LE_EXPR
: tcode
= Le_Expr
; break;
6606 case GT_EXPR
: tcode
= Gt_Expr
; break;
6607 case GE_EXPR
: tcode
= Ge_Expr
; break;
6608 case EQ_EXPR
: tcode
= Eq_Expr
; break;
6609 case NE_EXPR
: tcode
= Ne_Expr
; break;
6615 /* Now get each of the operands that's relevant for this code. If any
6616 cannot be expressed as a repinfo node, say we can't. */
6617 for (i
= 0; i
< 3; i
++)
6620 for (i
= 0; i
< len
; i
++)
6622 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
6623 if (ops
[i
] == No_Uint
)
6627 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
6629 /* Save the result in the cache. */
6632 *h
= ggc_alloc (sizeof (struct tree_int_map
));
6633 (*h
)->base
.from
= gnu_size
;
6640 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6641 GCC type, set Component_Bit_Offset and Esize to the position and size
6645 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
6649 Entity_Id gnat_field
;
6651 /* We operate by first making a list of all fields and their positions
6652 (we can get the sizes easily at any time) by a recursive call
6653 and then update all the sizes into the tree. */
6654 gnu_list
= compute_field_positions (gnu_type
, NULL_TREE
,
6655 size_zero_node
, bitsize_zero_node
,
6658 for (gnat_field
= First_Entity (gnat_entity
); Present (gnat_field
);
6659 gnat_field
= Next_Entity (gnat_field
))
6660 if ((Ekind (gnat_field
) == E_Component
6661 || (Ekind (gnat_field
) == E_Discriminant
6662 && !Is_Unchecked_Union (Scope (gnat_field
)))))
6664 tree parent_offset
= bitsize_zero_node
;
6666 gnu_entry
= purpose_member (gnat_to_gnu_field_decl (gnat_field
),
6671 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
6673 /* In this mode the tag and parent components have not been
6674 generated, so we add the appropriate offset to each
6675 component. For a component appearing in the current
6676 extension, the offset is the size of the parent. */
6677 if (Is_Derived_Type (gnat_entity
)
6678 && Original_Record_Component (gnat_field
) == gnat_field
)
6680 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
6683 parent_offset
= bitsize_int (POINTER_SIZE
);
6686 Set_Component_Bit_Offset
6689 (size_binop (PLUS_EXPR
,
6690 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry
)),
6691 TREE_VALUE (TREE_VALUE
6692 (TREE_VALUE (gnu_entry
)))),
6695 Set_Esize (gnat_field
,
6696 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry
))));
6698 else if (Is_Tagged_Type (gnat_entity
)
6699 && Is_Derived_Type (gnat_entity
))
6701 /* If there is no gnu_entry, this is an inherited component whose
6702 position is the same as in the parent type. */
6703 Set_Component_Bit_Offset
6705 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
6706 Set_Esize (gnat_field
,
6707 Esize (Original_Record_Component (gnat_field
)));
6712 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6713 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6714 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6715 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6716 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6717 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6721 compute_field_positions (tree gnu_type
, tree gnu_list
, tree gnu_pos
,
6722 tree gnu_bitpos
, unsigned int offset_align
)
6725 tree gnu_result
= gnu_list
;
6727 for (gnu_field
= TYPE_FIELDS (gnu_type
); gnu_field
;
6728 gnu_field
= TREE_CHAIN (gnu_field
))
6730 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
6731 DECL_FIELD_BIT_OFFSET (gnu_field
));
6732 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
6733 DECL_FIELD_OFFSET (gnu_field
));
6734 unsigned int our_offset_align
6735 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
6738 = tree_cons (gnu_field
,
6739 tree_cons (gnu_our_offset
,
6740 tree_cons (size_int (our_offset_align
),
6741 gnu_our_bitpos
, NULL_TREE
),
6745 if (DECL_INTERNAL_P (gnu_field
))
6747 = compute_field_positions (TREE_TYPE (gnu_field
), gnu_result
,
6748 gnu_our_offset
, gnu_our_bitpos
,
6755 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6756 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6757 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6758 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6759 for the size of a field. COMPONENT_P is true if we are being called
6760 to process the Component_Size of GNAT_OBJECT. This is used for error
6761 message handling and to indicate to use the object size of GNU_TYPE.
6762 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6763 it means that a size of zero should be treated as an unspecified size. */
6766 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
6767 enum tree_code kind
, bool component_p
, bool zero_ok
)
6769 Node_Id gnat_error_node
;
6770 tree type_size
, size
;
6772 if (kind
== VAR_DECL
6773 /* If a type needs strict alignment, a component of this type in
6774 a packed record cannot be packed and thus uses the type size. */
6775 || (kind
== TYPE_DECL
&& Strict_Alignment (gnat_object
)))
6776 type_size
= TYPE_SIZE (gnu_type
);
6778 type_size
= rm_size (gnu_type
);
6780 /* Find the node to use for errors. */
6781 if ((Ekind (gnat_object
) == E_Component
6782 || Ekind (gnat_object
) == E_Discriminant
)
6783 && Present (Component_Clause (gnat_object
)))
6784 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
6785 else if (Present (Size_Clause (gnat_object
)))
6786 gnat_error_node
= Expression (Size_Clause (gnat_object
));
6788 gnat_error_node
= gnat_object
;
6790 /* Return 0 if no size was specified, either because Esize was not Present or
6791 the specified size was zero. */
6792 if (No (uint_size
) || uint_size
== No_Uint
)
6795 /* Get the size as a tree. Give an error if a size was specified, but cannot
6796 be represented as in sizetype. */
6797 size
= UI_To_gnu (uint_size
, bitsizetype
);
6798 if (TREE_OVERFLOW (size
))
6800 post_error_ne (component_p
? "component size of & is too large"
6801 : "size of & is too large",
6802 gnat_error_node
, gnat_object
);
6806 /* Ignore a negative size since that corresponds to our back-annotation.
6807 Also ignore a zero size unless a size clause exists. */
6808 else if (tree_int_cst_sgn (size
) < 0 || (integer_zerop (size
) && !zero_ok
))
6811 /* The size of objects is always a multiple of a byte. */
6812 if (kind
== VAR_DECL
6813 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
6816 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6817 gnat_error_node
, gnat_object
);
6819 post_error_ne ("size for& is not a multiple of Storage_Unit",
6820 gnat_error_node
, gnat_object
);
6824 /* If this is an integral type or a packed array type, the front-end has
6825 verified the size, so we need not do it here (which would entail
6826 checking against the bounds). However, if this is an aliased object, it
6827 may not be smaller than the type of the object. */
6828 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
6829 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
6832 /* If the object is a record that contains a template, add the size of
6833 the template to the specified size. */
6834 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6835 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
6836 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
6838 /* Modify the size of the type to be that of the maximum size if it has a
6839 discriminant or the size of a thin pointer if this is a fat pointer. */
6840 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
6841 type_size
= max_size (type_size
, true);
6842 else if (TYPE_FAT_POINTER_P (gnu_type
))
6843 type_size
= bitsize_int (POINTER_SIZE
);
6845 /* If this is an access type, the minimum size is that given by the smallest
6846 integral mode that's valid for pointers. */
6847 if (TREE_CODE (gnu_type
) == POINTER_TYPE
)
6849 enum machine_mode p_mode
;
6851 for (p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
6852 !targetm
.valid_pointer_mode (p_mode
);
6853 p_mode
= GET_MODE_WIDER_MODE (p_mode
))
6856 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
6859 /* If the size of the object is a constant, the new size must not be
6861 if (TREE_CODE (type_size
) != INTEGER_CST
6862 || TREE_OVERFLOW (type_size
)
6863 || tree_int_cst_lt (size
, type_size
))
6867 ("component size for& too small{, minimum allowed is ^}",
6868 gnat_error_node
, gnat_object
, type_size
);
6870 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
6871 gnat_error_node
, gnat_object
, type_size
);
6873 if (kind
== VAR_DECL
&& !component_p
6874 && TREE_CODE (rm_size (gnu_type
)) == INTEGER_CST
6875 && !tree_int_cst_lt (size
, rm_size (gnu_type
)))
6876 post_error_ne_tree_2
6877 ("\\size of ^ is not a multiple of alignment (^ bits)",
6878 gnat_error_node
, gnat_object
, rm_size (gnu_type
),
6879 TYPE_ALIGN (gnu_type
));
6881 else if (INTEGRAL_TYPE_P (gnu_type
))
6882 post_error_ne ("\\size would be legal if & were not aliased!",
6883 gnat_error_node
, gnat_object
);
6891 /* Similarly, but both validate and process a value of RM_Size. This
6892 routine is only called for types. */
6895 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
6897 /* Only give an error if a Value_Size clause was explicitly given.
6898 Otherwise, we'd be duplicating an error on the Size clause. */
6899 Node_Id gnat_attr_node
6900 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
6901 tree old_size
= rm_size (gnu_type
);
6904 /* Get the size as a tree. Do nothing if none was specified, either
6905 because RM_Size was not Present or if the specified size was zero.
6906 Give an error if a size was specified, but cannot be represented as
6908 if (No (uint_size
) || uint_size
== No_Uint
)
6911 size
= UI_To_gnu (uint_size
, bitsizetype
);
6912 if (TREE_OVERFLOW (size
))
6914 if (Present (gnat_attr_node
))
6915 post_error_ne ("Value_Size of & is too large", gnat_attr_node
,
6921 /* Ignore a negative size since that corresponds to our back-annotation.
6922 Also ignore a zero size unless a size clause exists, a Value_Size
6923 clause exists, or this is an integer type, in which case the
6924 front end will have always set it. */
6925 else if (tree_int_cst_sgn (size
) < 0
6926 || (integer_zerop (size
) && No (gnat_attr_node
)
6927 && !Has_Size_Clause (gnat_entity
)
6928 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
)))
6931 /* If the old size is self-referential, get the maximum size. */
6932 if (CONTAINS_PLACEHOLDER_P (old_size
))
6933 old_size
= max_size (old_size
, true);
6935 /* If the size of the object is a constant, the new size must not be
6936 smaller (the front end checks this for scalar types). */
6937 if (TREE_CODE (old_size
) != INTEGER_CST
6938 || TREE_OVERFLOW (old_size
)
6939 || (AGGREGATE_TYPE_P (gnu_type
)
6940 && tree_int_cst_lt (size
, old_size
)))
6942 if (Present (gnat_attr_node
))
6944 ("Value_Size for& too small{, minimum allowed is ^}",
6945 gnat_attr_node
, gnat_entity
, old_size
);
6950 /* Otherwise, set the RM_Size. */
6951 if (TREE_CODE (gnu_type
) == INTEGER_TYPE
6952 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
6953 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6954 else if (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
)
6955 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6956 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
6957 || TREE_CODE (gnu_type
) == UNION_TYPE
6958 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
6959 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
6960 SET_TYPE_ADA_SIZE (gnu_type
, size
);
6963 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
6964 If TYPE is the best type, return it. Otherwise, make a new type. We
6965 only support new integral and pointer types. BIASED_P is nonzero if
6966 we are making a biased type. */
6969 make_type_from_size (tree type
, tree size_tree
, bool biased_p
)
6972 unsigned HOST_WIDE_INT size
;
6975 /* If size indicates an error, just return TYPE to avoid propagating the
6976 error. Likewise if it's too large to represent. */
6977 if (!size_tree
|| !host_integerp (size_tree
, 1))
6980 size
= tree_low_cst (size_tree
, 1);
6981 switch (TREE_CODE (type
))
6985 /* Only do something if the type is not already the proper size and is
6986 not a packed array type. */
6987 if (TYPE_PACKED_ARRAY_TYPE_P (type
)
6988 || (TYPE_PRECISION (type
) == size
6989 && biased_p
== (TREE_CODE (type
) == INTEGER_CST
6990 && TYPE_BIASED_REPRESENTATION_P (type
))))
6993 biased_p
|= (TREE_CODE (type
) == INTEGER_TYPE
6994 && TYPE_BIASED_REPRESENTATION_P (type
));
6995 unsigned_p
= TYPE_UNSIGNED (type
) || biased_p
;
6997 size
= MIN (size
, LONG_LONG_TYPE_SIZE
);
6999 = unsigned_p
? make_unsigned_type (size
) : make_signed_type (size
);
7000 TREE_TYPE (new_type
) = TREE_TYPE (type
) ? TREE_TYPE (type
) : type
;
7001 TYPE_MIN_VALUE (new_type
)
7002 = convert (TREE_TYPE (new_type
), TYPE_MIN_VALUE (type
));
7003 TYPE_MAX_VALUE (new_type
)
7004 = convert (TREE_TYPE (new_type
), TYPE_MAX_VALUE (type
));
7005 TYPE_BIASED_REPRESENTATION_P (new_type
) = biased_p
;
7006 TYPE_RM_SIZE_NUM (new_type
) = bitsize_int (size
);
7010 /* Do something if this is a fat pointer, in which case we
7011 may need to return the thin pointer. */
7012 if (TYPE_IS_FAT_POINTER_P (type
) && size
< POINTER_SIZE
* 2)
7015 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type
)));
7019 /* Only do something if this is a thin pointer, in which case we
7020 may need to return the fat pointer. */
7021 if (TYPE_THIN_POINTER_P (type
) && size
>= POINTER_SIZE
* 2)
7023 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)));
7034 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7035 a type or object whose present alignment is ALIGN. If this alignment is
7036 valid, return it. Otherwise, give an error and return ALIGN. */
7039 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
7041 unsigned int max_allowed_alignment
= get_target_maximum_allowed_alignment ();
7042 unsigned int new_align
;
7043 Node_Id gnat_error_node
;
7045 /* Don't worry about checking alignment if alignment was not specified
7046 by the source program and we already posted an error for this entity. */
7047 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
7050 /* Post the error on the alignment clause if any. */
7051 if (Present (Alignment_Clause (gnat_entity
)))
7052 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
7054 gnat_error_node
= gnat_entity
;
7056 /* Within GCC, an alignment is an integer, so we must make sure a value is
7057 specified that fits in that range. Also, there is an upper bound to
7058 alignments we can support/allow. */
7059 if (!UI_Is_In_Int_Range (alignment
)
7060 || ((new_align
= UI_To_Int (alignment
)) > max_allowed_alignment
))
7061 post_error_ne_num ("largest supported alignment for& is ^",
7062 gnat_error_node
, gnat_entity
, max_allowed_alignment
);
7063 else if (!(Present (Alignment_Clause (gnat_entity
))
7064 && From_At_Mod (Alignment_Clause (gnat_entity
)))
7065 && new_align
* BITS_PER_UNIT
< align
)
7066 post_error_ne_num ("alignment for& must be at least ^",
7067 gnat_error_node
, gnat_entity
,
7068 align
/ BITS_PER_UNIT
);
7071 new_align
= (new_align
> 0 ? new_align
* BITS_PER_UNIT
: 1);
7072 if (new_align
> align
)
7079 /* Return the smallest alignment not less than SIZE. */
7082 ceil_alignment (unsigned HOST_WIDE_INT size
)
7084 return (unsigned int) 1 << (floor_log2 (size
- 1) + 1);
7087 /* Verify that OBJECT, a type or decl, is something we can implement
7088 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7089 if we require atomic components. */
7092 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
7094 Node_Id gnat_error_point
= gnat_entity
;
7096 enum machine_mode mode
;
7100 /* There are three case of what OBJECT can be. It can be a type, in which
7101 case we take the size, alignment and mode from the type. It can be a
7102 declaration that was indirect, in which case the relevant values are
7103 that of the type being pointed to, or it can be a normal declaration,
7104 in which case the values are of the decl. The code below assumes that
7105 OBJECT is either a type or a decl. */
7106 if (TYPE_P (object
))
7108 mode
= TYPE_MODE (object
);
7109 align
= TYPE_ALIGN (object
);
7110 size
= TYPE_SIZE (object
);
7112 else if (DECL_BY_REF_P (object
))
7114 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
7115 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
7116 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
7120 mode
= DECL_MODE (object
);
7121 align
= DECL_ALIGN (object
);
7122 size
= DECL_SIZE (object
);
7125 /* Consider all floating-point types atomic and any types that that are
7126 represented by integers no wider than a machine word. */
7127 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
7128 || ((GET_MODE_CLASS (mode
) == MODE_INT
7129 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
7130 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
7133 /* For the moment, also allow anything that has an alignment equal
7134 to its size and which is smaller than a word. */
7135 if (size
&& TREE_CODE (size
) == INTEGER_CST
7136 && compare_tree_int (size
, align
) == 0
7137 && align
<= BITS_PER_WORD
)
7140 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
7141 gnat_node
= Next_Rep_Item (gnat_node
))
7143 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
7144 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7146 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7147 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
7148 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node
)))
7149 == Pragma_Atomic_Components
))
7150 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
7154 post_error_ne ("atomic access to component of & cannot be guaranteed",
7155 gnat_error_point
, gnat_entity
);
7157 post_error_ne ("atomic access to & cannot be guaranteed",
7158 gnat_error_point
, gnat_entity
);
7161 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7162 have compatible signatures so that a call using one type may be safely
7163 issued if the actual target function type is the other. Return 1 if it is
7164 the case, 0 otherwise, and post errors on the incompatibilities.
7166 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7167 that calls to the subprogram will have arguments suitable for the later
7168 underlying builtin expansion. */
7171 compatible_signatures_p (tree ftype1
, tree ftype2
)
7173 /* As of now, we only perform very trivial tests and consider it's the
7174 programmer's responsibility to ensure the type correctness in the Ada
7175 declaration, as in the regular Import cases.
7177 Mismatches typically result in either error messages from the builtin
7178 expander, internal compiler errors, or in a real call sequence. This
7179 should be refined to issue diagnostics helping error detection and
7182 /* Almost fake test, ensuring a use of each argument. */
7183 if (ftype1
== ftype2
)
7189 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7190 type with all size expressions that contain F updated by replacing F
7191 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
7192 nothing has changed. */
7195 substitute_in_type (tree t
, tree f
, tree r
)
7200 switch (TREE_CODE (t
))
7205 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
7206 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
7208 tree low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
7209 tree high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
7211 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
7214 new = build_range_type (TREE_TYPE (t
), low
, high
);
7215 if (TYPE_INDEX_TYPE (t
))
7217 (new, substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
7224 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
7225 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
7227 tree low
= NULL_TREE
, high
= NULL_TREE
;
7229 if (TYPE_MIN_VALUE (t
))
7230 low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
7231 if (TYPE_MAX_VALUE (t
))
7232 high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
7234 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
7238 TYPE_MIN_VALUE (t
) = low
;
7239 TYPE_MAX_VALUE (t
) = high
;
7244 tem
= substitute_in_type (TREE_TYPE (t
), f
, r
);
7245 if (tem
== TREE_TYPE (t
))
7248 return build_complex_type (tem
);
7254 /* Don't know how to do these yet. */
7259 tree component
= substitute_in_type (TREE_TYPE (t
), f
, r
);
7260 tree domain
= substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
7262 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
7265 new = build_array_type (component
, domain
);
7266 TYPE_SIZE (new) = 0;
7267 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t
);
7268 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t
);
7270 TYPE_ALIGN (new) = TYPE_ALIGN (t
);
7271 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t
);
7273 /* If we had bounded the sizes of T by a constant, bound the sizes of
7274 NEW by the same constant. */
7275 if (TREE_CODE (TYPE_SIZE (t
)) == MIN_EXPR
)
7277 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE (t
), 1),
7279 if (TREE_CODE (TYPE_SIZE_UNIT (t
)) == MIN_EXPR
)
7280 TYPE_SIZE_UNIT (new)
7281 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE_UNIT (t
), 1),
7282 TYPE_SIZE_UNIT (new));
7288 case QUAL_UNION_TYPE
:
7292 = (f
== NULL_TREE
&& !TREE_CONSTANT (TYPE_SIZE (t
)));
7293 bool field_has_rep
= false;
7294 tree last_field
= NULL_TREE
;
7296 tree
new = copy_type (t
);
7298 /* Start out with no fields, make new fields, and chain them
7299 in. If we haven't actually changed the type of any field,
7300 discard everything we've done and return the old type. */
7302 TYPE_FIELDS (new) = NULL_TREE
;
7303 TYPE_SIZE (new) = NULL_TREE
;
7305 for (field
= TYPE_FIELDS (t
); field
; field
= TREE_CHAIN (field
))
7307 tree new_field
= copy_node (field
);
7309 TREE_TYPE (new_field
)
7310 = substitute_in_type (TREE_TYPE (new_field
), f
, r
);
7312 if (DECL_HAS_REP_P (field
) && !DECL_INTERNAL_P (field
))
7313 field_has_rep
= true;
7314 else if (TREE_TYPE (new_field
) != TREE_TYPE (field
))
7315 changed_field
= true;
7317 /* If this is an internal field and the type of this field is
7318 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7319 the type just has one element, treat that as the field.
7320 But don't do this if we are processing a QUAL_UNION_TYPE. */
7321 if (TREE_CODE (t
) != QUAL_UNION_TYPE
7322 && DECL_INTERNAL_P (new_field
)
7323 && (TREE_CODE (TREE_TYPE (new_field
)) == UNION_TYPE
7324 || TREE_CODE (TREE_TYPE (new_field
)) == RECORD_TYPE
))
7326 if (!TYPE_FIELDS (TREE_TYPE (new_field
)))
7329 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field
))))
7332 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field
)));
7334 /* Make sure omitting the union doesn't change
7336 DECL_ALIGN (next_new_field
) = DECL_ALIGN (new_field
);
7337 new_field
= next_new_field
;
7341 DECL_CONTEXT (new_field
) = new;
7342 SET_DECL_ORIGINAL_FIELD (new_field
,
7343 (DECL_ORIGINAL_FIELD (field
)
7344 ? DECL_ORIGINAL_FIELD (field
) : field
));
7346 /* If the size of the old field was set at a constant,
7347 propagate the size in case the type's size was variable.
7348 (This occurs in the case of a variant or discriminated
7349 record with a default size used as a field of another
7351 DECL_SIZE (new_field
)
7352 = TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
7353 ? DECL_SIZE (field
) : NULL_TREE
;
7354 DECL_SIZE_UNIT (new_field
)
7355 = TREE_CODE (DECL_SIZE_UNIT (field
)) == INTEGER_CST
7356 ? DECL_SIZE_UNIT (field
) : NULL_TREE
;
7358 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
7360 tree new_q
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
7362 if (new_q
!= DECL_QUALIFIER (new_field
))
7363 changed_field
= true;
7365 /* Do the substitution inside the qualifier and if we find
7366 that this field will not be present, omit it. */
7367 DECL_QUALIFIER (new_field
) = new_q
;
7369 if (integer_zerop (DECL_QUALIFIER (new_field
)))
7374 TYPE_FIELDS (new) = new_field
;
7376 TREE_CHAIN (last_field
) = new_field
;
7378 last_field
= new_field
;
7380 /* If this is a qualified type and this field will always be
7381 present, we are done. */
7382 if (TREE_CODE (t
) == QUAL_UNION_TYPE
7383 && integer_onep (DECL_QUALIFIER (new_field
)))
7387 /* If this used to be a qualified union type, but we now know what
7388 field will be present, make this a normal union. */
7389 if (changed_field
&& TREE_CODE (new) == QUAL_UNION_TYPE
7390 && (!TYPE_FIELDS (new)
7391 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7392 TREE_SET_CODE (new, UNION_TYPE
);
7393 else if (!changed_field
)
7396 gcc_assert (!field_has_rep
);
7399 /* If the size was originally a constant use it. */
7400 if (TYPE_SIZE (t
) && TREE_CODE (TYPE_SIZE (t
)) == INTEGER_CST
7401 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST
)
7403 TYPE_SIZE (new) = TYPE_SIZE (t
);
7404 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t
);
7405 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t
));
7416 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7417 needed to represent the object. */
7420 rm_size (tree gnu_type
)
7422 /* For integer types, this is the precision. For record types, we store
7423 the size explicitly. For other types, this is just the size. */
7425 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
7426 return TYPE_RM_SIZE (gnu_type
);
7427 else if (TREE_CODE (gnu_type
) == RECORD_TYPE
7428 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
7429 /* Return the rm_size of the actual data plus the size of the template. */
7431 size_binop (PLUS_EXPR
,
7432 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)))),
7433 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
7434 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
7435 || TREE_CODE (gnu_type
) == UNION_TYPE
7436 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
7437 && !TYPE_IS_FAT_POINTER_P (gnu_type
)
7438 && TYPE_ADA_SIZE (gnu_type
))
7439 return TYPE_ADA_SIZE (gnu_type
);
7441 return TYPE_SIZE (gnu_type
);
7444 /* Return an identifier representing the external name to be used for
7445 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7446 and the specified suffix. */
7449 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
7451 Entity_Kind kind
= Ekind (gnat_entity
);
7453 const char *str
= (!suffix
? "" : suffix
);
7454 String_Template temp
= {1, strlen (str
)};
7455 Fat_Pointer fp
= {str
, &temp
};
7457 Get_External_Name_With_Suffix (gnat_entity
, fp
);
7459 /* A variable using the Stdcall convention (meaning we are running
7460 on a Windows box) live in a DLL. Here we adjust its name to use
7461 the jump-table, the _imp__NAME contains the address for the NAME
7463 if ((kind
== E_Variable
|| kind
== E_Constant
)
7464 && Has_Stdcall_Convention (gnat_entity
))
7466 const char *prefix
= "_imp__";
7467 int k
, plen
= strlen (prefix
);
7469 for (k
= 0; k
<= Name_Len
; k
++)
7470 Name_Buffer
[Name_Len
- k
+ plen
] = Name_Buffer
[Name_Len
- k
];
7471 strncpy (Name_Buffer
, prefix
, plen
);
7474 return get_identifier (Name_Buffer
);
7477 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7478 fully-qualified name, possibly with type information encoding.
7479 Otherwise, return the name. */
7482 get_entity_name (Entity_Id gnat_entity
)
7484 Get_Encoded_Name (gnat_entity
);
7485 return get_identifier (Name_Buffer
);
7488 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7489 string, return a new IDENTIFIER_NODE that is the concatenation of
7490 the name in GNU_ID and SUFFIX. */
7493 concat_id_with_name (tree gnu_id
, const char *suffix
)
7495 int len
= IDENTIFIER_LENGTH (gnu_id
);
7497 strncpy (Name_Buffer
, IDENTIFIER_POINTER (gnu_id
), len
);
7498 strncpy (Name_Buffer
+ len
, "___", 3);
7500 strcpy (Name_Buffer
+ len
, suffix
);
7501 return get_identifier (Name_Buffer
);
7504 #include "gt-ada-decl.h"