1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2007, 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 2, 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 distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
57 /* Convention_Stdcall should be processed in a specific way on Windows targets
58 only. The macro below is a helper to avoid having to check for a Windows
59 specific attribute throughout this unit. */
61 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
62 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
64 #define Has_Stdcall_Convention(E) (0)
67 /* These two variables are used to defer recursively expanding incomplete
68 types while we are processing a record or subprogram type. */
70 static int defer_incomplete_level
= 0;
71 static struct incomplete
73 struct incomplete
*next
;
76 } *defer_incomplete_list
= 0;
78 /* These two variables are used to defer emission of debug information for
79 nested incomplete record types */
81 static int defer_debug_level
= 0;
82 static tree defer_debug_incomplete_list
;
84 /* A hash table used as to cache the result of annotate_value. */
85 static GTY ((if_marked ("tree_int_map_marked_p"), param_is (struct tree_int_map
)))
86 htab_t annotate_value_cache
;
88 static void copy_alias_set (tree
, tree
);
89 static tree
substitution_list (Entity_Id
, Entity_Id
, tree
, bool);
90 static bool allocatable_size_p (tree
, bool);
91 static void prepend_attributes (Entity_Id
, struct attrib
**);
92 static tree
elaborate_expression (Node_Id
, Entity_Id
, tree
, bool, bool, bool);
93 static bool is_variable_size (tree
);
94 static tree
elaborate_expression_1 (Node_Id
, Entity_Id
, tree
, tree
,
96 static tree
make_packable_type (tree
);
97 static tree
gnat_to_gnu_field (Entity_Id
, tree
, int, bool);
98 static bool same_discriminant_p (Entity_Id
, Entity_Id
);
99 static void components_to_record (tree
, Node_Id
, tree
, int, bool, tree
*,
100 bool, bool, bool, bool);
101 static int compare_field_bitpos (const PTR
, const PTR
);
102 static Uint
annotate_value (tree
);
103 static void annotate_rep (Entity_Id
, tree
);
104 static tree
compute_field_positions (tree
, tree
, tree
, tree
, unsigned int);
105 static tree
validate_size (Uint
, tree
, Entity_Id
, enum tree_code
, bool, bool);
106 static void set_rm_size (Uint
, tree
, Entity_Id
);
107 static tree
make_type_from_size (tree
, tree
, bool);
108 static unsigned int validate_alignment (Uint
, Entity_Id
, unsigned int);
109 static void check_ok_for_atomic (tree
, Entity_Id
, bool);
110 static int compatible_signatures_p (tree ftype1
, tree ftype2
);
112 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
113 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
114 refer to an Ada type. */
117 gnat_to_gnu_type (Entity_Id gnat_entity
)
121 /* The back end never attempts to annotate generic types */
122 if (Is_Generic_Type (gnat_entity
) && type_annotate_only
)
123 return void_type_node
;
125 /* Convert the ada entity type into a GCC TYPE_DECL node. */
126 gnu_decl
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
127 gcc_assert (TREE_CODE (gnu_decl
) == TYPE_DECL
);
128 return TREE_TYPE (gnu_decl
);
131 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
132 entity, this routine returns the equivalent GCC tree for that entity
133 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
136 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
137 initial value (in GCC tree form). This is optional for variables.
138 For renamed entities, GNU_EXPR gives the object being renamed.
140 DEFINITION is nonzero if this call is intended for a definition. This is
141 used for separate compilation where it necessary to know whether an
142 external declaration or a definition should be created if the GCC equivalent
143 was not created previously. The value of 1 is normally used for a nonzero
144 DEFINITION, but a value of 2 is used in special circumstances, defined in
148 gnat_to_gnu_entity (Entity_Id gnat_entity
, tree gnu_expr
, int definition
)
151 tree gnu_type
= NULL_TREE
;
152 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
153 GNAT tree. This node will be associated with the GNAT node by calling
154 the save_gnu_tree routine at the end of the `switch' statement. */
155 tree gnu_decl
= NULL_TREE
;
156 /* true if we have already saved gnu_decl as a gnat association. */
158 /* Nonzero if we incremented defer_incomplete_level. */
159 bool this_deferred
= false;
160 /* Nonzero if we incremented defer_debug_level. */
161 bool debug_deferred
= false;
162 /* Nonzero if we incremented force_global. */
163 bool this_global
= false;
164 /* Nonzero if we should check to see if elaborated during processing. */
165 bool maybe_present
= false;
166 /* Nonzero if we made GNU_DECL and its type here. */
167 bool this_made_decl
= false;
168 struct attrib
*attr_list
= NULL
;
169 bool debug_info_p
= (Needs_Debug_Info (gnat_entity
)
170 || debug_info_level
== DINFO_LEVEL_VERBOSE
);
171 Entity_Kind kind
= Ekind (gnat_entity
);
174 = ((Known_Esize (gnat_entity
)
175 && UI_Is_In_Int_Range (Esize (gnat_entity
)))
176 ? MIN (UI_To_Int (Esize (gnat_entity
)),
177 IN (kind
, Float_Kind
)
178 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE
)
179 : IN (kind
, Access_Kind
) ? POINTER_SIZE
* 2
180 : LONG_LONG_TYPE_SIZE
)
181 : LONG_LONG_TYPE_SIZE
);
184 = (Is_Imported (gnat_entity
) && No (Address_Clause (gnat_entity
)));
185 unsigned int align
= 0;
187 /* Since a use of an Itype is a definition, process it as such if it
188 is not in a with'ed unit. */
190 if (!definition
&& Is_Itype (gnat_entity
)
191 && !present_gnu_tree (gnat_entity
)
192 && In_Extended_Main_Code_Unit (gnat_entity
))
194 /* Ensure that we are in a subprogram mentioned in the Scope
195 chain of this entity, our current scope is global,
196 or that we encountered a task or entry (where we can't currently
197 accurately check scoping). */
198 if (!current_function_decl
199 || DECL_ELABORATION_PROC_P (current_function_decl
))
201 process_type (gnat_entity
);
202 return get_gnu_tree (gnat_entity
);
205 for (gnat_temp
= Scope (gnat_entity
);
206 Present (gnat_temp
); gnat_temp
= Scope (gnat_temp
))
208 if (Is_Type (gnat_temp
))
209 gnat_temp
= Underlying_Type (gnat_temp
);
211 if (Ekind (gnat_temp
) == E_Subprogram_Body
)
213 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp
)));
215 if (IN (Ekind (gnat_temp
), Subprogram_Kind
)
216 && Present (Protected_Body_Subprogram (gnat_temp
)))
217 gnat_temp
= Protected_Body_Subprogram (gnat_temp
);
219 if (Ekind (gnat_temp
) == E_Entry
220 || Ekind (gnat_temp
) == E_Entry_Family
221 || Ekind (gnat_temp
) == E_Task_Type
222 || (IN (Ekind (gnat_temp
), Subprogram_Kind
)
223 && present_gnu_tree (gnat_temp
)
224 && (current_function_decl
225 == gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0))))
227 process_type (gnat_entity
);
228 return get_gnu_tree (gnat_entity
);
232 /* This abort means the entity "gnat_entity" has an incorrect scope,
233 i.e. that its scope does not correspond to the subprogram in which
238 /* If this is entity 0, something went badly wrong. */
239 gcc_assert (Present (gnat_entity
));
241 /* If we've already processed this entity, return what we got last time.
242 If we are defining the node, we should not have already processed it.
243 In that case, we will abort below when we try to save a new GCC tree for
244 this object. We also need to handle the case of getting a dummy type
245 when a Full_View exists. */
247 if (present_gnu_tree (gnat_entity
)
248 && (!definition
|| (Is_Type (gnat_entity
) && imported_p
)))
250 gnu_decl
= get_gnu_tree (gnat_entity
);
252 if (TREE_CODE (gnu_decl
) == TYPE_DECL
253 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
))
254 && IN (kind
, Incomplete_Or_Private_Kind
)
255 && Present (Full_View (gnat_entity
)))
257 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
260 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
261 save_gnu_tree (gnat_entity
, gnu_decl
, false);
267 /* If this is a numeric or enumeral type, or an access type, a nonzero
268 Esize must be specified unless it was specified by the programmer. */
269 gcc_assert (!Unknown_Esize (gnat_entity
)
270 || Has_Size_Clause (gnat_entity
)
271 || (!IN (kind
, Numeric_Kind
) && !IN (kind
, Enumeration_Kind
)
272 && (!IN (kind
, Access_Kind
)
273 || kind
== E_Access_Protected_Subprogram_Type
274 || kind
== E_Anonymous_Access_Protected_Subprogram_Type
275 || kind
== E_Access_Subtype
)));
277 /* Likewise, RM_Size must be specified for all discrete and fixed-point
279 gcc_assert (!IN (kind
, Discrete_Or_Fixed_Point_Kind
)
280 || !Unknown_RM_Size (gnat_entity
));
282 /* Get the name of the entity and set up the line number and filename of
283 the original definition for use in any decl we make. */
284 gnu_entity_id
= get_entity_name (gnat_entity
);
285 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
287 /* If we get here, it means we have not yet done anything with this
288 entity. If we are not defining it here, it must be external,
289 otherwise we should have defined it already. */
290 gcc_assert (definition
|| Is_Public (gnat_entity
) || type_annotate_only
291 || kind
== E_Discriminant
|| kind
== E_Component
293 || (kind
== E_Constant
&& Present (Full_View (gnat_entity
)))
294 || IN (kind
, Type_Kind
));
296 /* For cases when we are not defining (i.e., we are referencing from
297 another compilation unit) Public entities, show we are at global level
298 for the purpose of computing scopes. Don't do this for components or
299 discriminants since the relevant test is whether or not the record is
300 being defined. But do this for Imported functions or procedures in
302 if ((!definition
&& Is_Public (gnat_entity
)
303 && !Is_Statically_Allocated (gnat_entity
)
304 && kind
!= E_Discriminant
&& kind
!= E_Component
)
305 || (Is_Imported (gnat_entity
)
306 && (kind
== E_Function
|| kind
== E_Procedure
)))
307 force_global
++, this_global
= true;
309 /* Handle any attributes directly attached to the entity. */
310 if (Has_Gigi_Rep_Item (gnat_entity
))
311 prepend_attributes (gnat_entity
, &attr_list
);
313 /* Machine_Attributes on types are expected to be propagated to subtypes.
314 The corresponding Gigi_Rep_Items are only attached to the first subtype
315 though, so we handle the propagation here. */
316 if (Is_Type (gnat_entity
) && Base_Type (gnat_entity
) != gnat_entity
317 && !Is_First_Subtype (gnat_entity
)
318 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity
))))
319 prepend_attributes (First_Subtype (Base_Type (gnat_entity
)), &attr_list
);
324 /* If this is a use of a deferred constant, get its full
326 if (!definition
&& Present (Full_View (gnat_entity
)))
328 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
334 /* If we have an external constant that we are not defining,
335 get the expression that is was defined to represent. We
336 may throw that expression away later if it is not a
338 Do not retrieve the expression if it is an aggregate, because
339 in complex instantiation contexts it may not be expanded */
342 && Present (Expression (Declaration_Node (gnat_entity
)))
343 && !No_Initialization (Declaration_Node (gnat_entity
))
344 && (Nkind (Expression (Declaration_Node (gnat_entity
)))
346 gnu_expr
= gnat_to_gnu (Expression (Declaration_Node (gnat_entity
)));
348 /* Ignore deferred constant definitions; they are processed fully in the
349 front-end. For deferred constant references, get the full
350 definition. On the other hand, constants that are renamings are
351 handled like variable renamings. If No_Initialization is set, this is
352 not a deferred constant but a constant whose value is built
355 if (definition
&& !gnu_expr
356 && !No_Initialization (Declaration_Node (gnat_entity
))
357 && No (Renamed_Object (gnat_entity
)))
359 gnu_decl
= error_mark_node
;
363 else if (!definition
&& IN (kind
, Incomplete_Or_Private_Kind
)
364 && Present (Full_View (gnat_entity
)))
366 gnu_decl
= gnat_to_gnu_entity (Full_View (gnat_entity
),
375 /* We used to special case VMS exceptions here to directly map them to
376 their associated condition code. Since this code had to be masked
377 dynamically to strip off the severity bits, this caused trouble in
378 the GCC/ZCX case because the "type" pointers we store in the tables
379 have to be static. We now don't special case here anymore, and let
380 the regular processing take place, which leaves us with a regular
381 exception data object for VMS exceptions too. The condition code
382 mapping is taken care of by the front end and the bitmasking by the
389 /* The GNAT record where the component was defined. */
390 Entity_Id gnat_record
= Underlying_Type (Scope (gnat_entity
));
392 /* If the variable is an inherited record component (in the case of
393 extended record types), just return the inherited entity, which
394 must be a FIELD_DECL. Likewise for discriminants.
395 For discriminants of untagged records which have explicit
396 stored discriminants, return the entity for the corresponding
397 stored discriminant. Also use Original_Record_Component
398 if the record has a private extension. */
400 if (Present (Original_Record_Component (gnat_entity
))
401 && Original_Record_Component (gnat_entity
) != gnat_entity
)
404 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity
),
405 gnu_expr
, definition
);
410 /* If the enclosing record has explicit stored discriminants,
411 then it is an untagged record. If the Corresponding_Discriminant
412 is not empty then this must be a renamed discriminant and its
413 Original_Record_Component must point to the corresponding explicit
414 stored discriminant (i.e., we should have taken the previous
417 else if (Present (Corresponding_Discriminant (gnat_entity
))
418 && Is_Tagged_Type (gnat_record
))
420 /* A tagged record has no explicit stored discriminants. */
422 gcc_assert (First_Discriminant (gnat_record
)
423 == First_Stored_Discriminant (gnat_record
));
425 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity
),
426 gnu_expr
, definition
);
431 else if (Present (CR_Discriminant (gnat_entity
))
432 && type_annotate_only
)
434 gnu_decl
= gnat_to_gnu_entity (CR_Discriminant (gnat_entity
),
435 gnu_expr
, definition
);
440 /* If the enclosing record has explicit stored discriminants,
441 then it is an untagged record. If the Corresponding_Discriminant
442 is not empty then this must be a renamed discriminant and its
443 Original_Record_Component must point to the corresponding explicit
444 stored discriminant (i.e., we should have taken the first
447 else if (Present (Corresponding_Discriminant (gnat_entity
))
448 && (First_Discriminant (gnat_record
)
449 != First_Stored_Discriminant (gnat_record
)))
452 /* Otherwise, if we are not defining this and we have no GCC type
453 for the containing record, make one for it. Then we should
454 have made our own equivalent. */
455 else if (!definition
&& !present_gnu_tree (gnat_record
))
457 /* ??? If this is in a record whose scope is a protected
458 type and we have an Original_Record_Component, use it.
459 This is a workaround for major problems in protected type
462 Entity_Id Scop
= Scope (Scope (gnat_entity
));
463 if ((Is_Protected_Type (Scop
)
464 || (Is_Private_Type (Scop
)
465 && Present (Full_View (Scop
))
466 && Is_Protected_Type (Full_View (Scop
))))
467 && Present (Original_Record_Component (gnat_entity
)))
470 = gnat_to_gnu_entity (Original_Record_Component
477 gnat_to_gnu_entity (Scope (gnat_entity
), NULL_TREE
, 0);
478 gnu_decl
= get_gnu_tree (gnat_entity
);
484 /* Here we have no GCC type and this is a reference rather than a
485 definition. This should never happen. Most likely the cause is a
486 reference before declaration in the gnat tree for gnat_entity. */
490 case E_Loop_Parameter
:
491 case E_Out_Parameter
:
494 /* Simple variables, loop variables, OUT parameters, and exceptions. */
497 bool used_by_ref
= false;
499 = ((kind
== E_Constant
|| kind
== E_Variable
)
500 && !Is_Statically_Allocated (gnat_entity
)
501 && Is_True_Constant (gnat_entity
)
502 && (((Nkind (Declaration_Node (gnat_entity
))
503 == N_Object_Declaration
)
504 && Present (Expression (Declaration_Node (gnat_entity
))))
505 || Present (Renamed_Object (gnat_entity
))));
506 bool inner_const_flag
= const_flag
;
507 bool static_p
= Is_Statically_Allocated (gnat_entity
);
508 bool mutable_p
= false;
509 tree gnu_ext_name
= NULL_TREE
;
510 tree renamed_obj
= NULL_TREE
;
512 if (Present (Renamed_Object (gnat_entity
)) && !definition
)
514 if (kind
== E_Exception
)
515 gnu_expr
= gnat_to_gnu_entity (Renamed_Entity (gnat_entity
),
518 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_entity
));
521 /* Get the type after elaborating the renamed object. */
522 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
524 /* If this is a loop variable, its type should be the base type.
525 This is because the code for processing a loop determines whether
526 a normal loop end test can be done by comparing the bounds of the
527 loop against those of the base type, which is presumed to be the
528 size used for computation. But this is not correct when the size
529 of the subtype is smaller than the type. */
530 if (kind
== E_Loop_Parameter
)
531 gnu_type
= get_base_type (gnu_type
);
533 /* Reject non-renamed objects whose types are unconstrained arrays or
534 any object whose type is a dummy type or VOID_TYPE. */
536 if ((TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
537 && No (Renamed_Object (gnat_entity
)))
538 || TYPE_IS_DUMMY_P (gnu_type
)
539 || TREE_CODE (gnu_type
) == VOID_TYPE
)
541 gcc_assert (type_annotate_only
);
544 return error_mark_node
;
547 /* If an alignment is specified, use it if valid. Note that
548 exceptions are objects but don't have alignments. We must do this
549 before we validate the size, since the alignment can affect the
551 if (kind
!= E_Exception
&& Known_Alignment (gnat_entity
))
553 gcc_assert (Present (Alignment (gnat_entity
)));
554 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
555 TYPE_ALIGN (gnu_type
));
556 gnu_type
= maybe_pad_type (gnu_type
, NULL_TREE
, align
,
557 gnat_entity
, "PAD", 0, definition
, 1);
560 /* If we are defining the object, see if it has a Size value and
561 validate it if so. If we are not defining the object and a Size
562 clause applies, simply retrieve the value. We don't want to ignore
563 the clause and it is expected to have been validated already. Then
564 get the new type, if any. */
566 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
,
567 gnat_entity
, VAR_DECL
, false,
568 Has_Size_Clause (gnat_entity
));
569 else if (Has_Size_Clause (gnat_entity
))
570 gnu_size
= UI_To_gnu (Esize (gnat_entity
), bitsizetype
);
575 = make_type_from_size (gnu_type
, gnu_size
,
576 Has_Biased_Representation (gnat_entity
));
578 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0))
579 gnu_size
= NULL_TREE
;
582 /* If this object has self-referential size, it must be a record with
583 a default value. We are supposed to allocate an object of the
584 maximum size in this case unless it is a constant with an
585 initializing expression, in which case we can get the size from
586 that. Note that the resulting size may still be a variable, so
587 this may end up with an indirect allocation. */
589 if (No (Renamed_Object (gnat_entity
))
590 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
592 if (gnu_expr
&& kind
== E_Constant
)
594 = SUBSTITUTE_PLACEHOLDER_IN_EXPR
595 (TYPE_SIZE (TREE_TYPE (gnu_expr
)), gnu_expr
);
597 /* We may have no GNU_EXPR because No_Initialization is
598 set even though there's an Expression. */
599 else if (kind
== E_Constant
600 && (Nkind (Declaration_Node (gnat_entity
))
601 == N_Object_Declaration
)
602 && Present (Expression (Declaration_Node (gnat_entity
))))
604 = TYPE_SIZE (gnat_to_gnu_type
606 (Expression (Declaration_Node (gnat_entity
)))));
609 gnu_size
= max_size (TYPE_SIZE (gnu_type
), true);
614 /* If the size is zero bytes, make it one byte since some linkers have
615 trouble with zero-sized objects. If the object will have a
616 template, that will make it nonzero so don't bother. Also avoid
617 doing that for an object renaming or an object with an address
618 clause, as we would lose useful information on the view size
619 (e.g. for null array slices) and we are not allocating the object
621 if (((gnu_size
&& integer_zerop (gnu_size
))
622 || (TYPE_SIZE (gnu_type
) && integer_zerop (TYPE_SIZE (gnu_type
))))
623 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
624 || !Is_Array_Type (Etype (gnat_entity
)))
625 && !Present (Renamed_Object (gnat_entity
))
626 && !Present (Address_Clause (gnat_entity
)))
627 gnu_size
= bitsize_unit_node
;
629 /* If this is an atomic object with no specified size and alignment,
630 but where the size of the type is a constant, set the alignment to
631 the lowest power of two greater than the size, or to the
632 biggest meaningful alignment, whichever is smaller. */
634 if (Is_Atomic (gnat_entity
) && !gnu_size
&& align
== 0
635 && TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
)
637 if (!host_integerp (TYPE_SIZE (gnu_type
), 1)
638 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type
),
640 align
= BIGGEST_ALIGNMENT
;
642 align
= ((unsigned int) 1
643 << (floor_log2 (tree_low_cst
644 (TYPE_SIZE (gnu_type
), 1) - 1)
648 /* If the object is set to have atomic components, find the component
649 type and validate it.
651 ??? Note that we ignore Has_Volatile_Components on objects; it's
652 not at all clear what to do in that case. */
654 if (Has_Atomic_Components (gnat_entity
))
656 tree gnu_inner
= (TREE_CODE (gnu_type
) == ARRAY_TYPE
657 ? TREE_TYPE (gnu_type
) : gnu_type
);
659 while (TREE_CODE (gnu_inner
) == ARRAY_TYPE
660 && TYPE_MULTI_ARRAY_P (gnu_inner
))
661 gnu_inner
= TREE_TYPE (gnu_inner
);
663 check_ok_for_atomic (gnu_inner
, gnat_entity
, true);
666 /* Now check if the type of the object allows atomic access. Note
667 that we must test the type, even if this object has size and
668 alignment to allow such access, because we will be going
669 inside the padded record to assign to the object. We could fix
670 this by always copying via an intermediate value, but it's not
671 clear it's worth the effort. */
672 if (Is_Atomic (gnat_entity
))
673 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
675 /* If this is an aliased object with an unconstrained nominal subtype,
676 make a type that includes the template. */
677 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity
))
678 && Is_Array_Type (Etype (gnat_entity
))
679 && !type_annotate_only
)
682 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity
))));
685 = build_unc_object_type_from_ptr (gnu_fat
, gnu_type
,
686 concat_id_with_name (gnu_entity_id
,
690 #ifdef MINIMUM_ATOMIC_ALIGNMENT
691 /* If the size is a constant and no alignment is specified, force
692 the alignment to be the minimum valid atomic alignment. The
693 restriction on constant size avoids problems with variable-size
694 temporaries; if the size is variable, there's no issue with
695 atomic access. Also don't do this for a constant, since it isn't
696 necessary and can interfere with constant replacement. Finally,
697 do not do it for Out parameters since that creates an
698 size inconsistency with In parameters. */
699 if (align
== 0 && MINIMUM_ATOMIC_ALIGNMENT
> TYPE_ALIGN (gnu_type
)
700 && !FLOAT_TYPE_P (gnu_type
)
701 && !const_flag
&& No (Renamed_Object (gnat_entity
))
702 && !imported_p
&& No (Address_Clause (gnat_entity
))
703 && kind
!= E_Out_Parameter
704 && (gnu_size
? TREE_CODE (gnu_size
) == INTEGER_CST
705 : TREE_CODE (TYPE_SIZE (gnu_type
)) == INTEGER_CST
))
706 align
= MINIMUM_ATOMIC_ALIGNMENT
;
709 /* Make a new type with the desired size and alignment, if needed. */
710 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
,
711 "PAD", false, definition
, true);
713 /* Make a volatile version of this object's type if we are to
714 make the object volatile. Note that 13.3(19) says that we
715 should treat other types of objects as volatile as well. */
716 if ((Treat_As_Volatile (gnat_entity
)
717 || Is_Exported (gnat_entity
)
718 || Is_Imported (gnat_entity
))
719 && !TYPE_VOLATILE (gnu_type
))
720 gnu_type
= build_qualified_type (gnu_type
,
721 (TYPE_QUALS (gnu_type
)
722 | TYPE_QUAL_VOLATILE
));
724 /* Convert the expression to the type of the object except in the
725 case where the object's type is unconstrained or the object's type
726 is a padded record whose field is of self-referential size. In
727 the former case, converting will generate unnecessary evaluations
728 of the CONSTRUCTOR to compute the size and in the latter case, we
729 want to only copy the actual data. */
731 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
732 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
733 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
734 && TYPE_IS_PADDING_P (gnu_type
)
735 && (CONTAINS_PLACEHOLDER_P
736 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
737 gnu_expr
= convert (gnu_type
, gnu_expr
);
739 /* See if this is a renaming, and handle appropriately depending on
740 what is renamed and in which context. There are three major
743 1/ This is a constant renaming and we can just make an object
744 with what is renamed as its initial value,
746 2/ We can reuse a stabilized version of what is renamed in place
749 3/ If neither 1 or 2 applies, we make the renaming entity a constant
750 pointer to what is being renamed. */
752 if (Present (Renamed_Object (gnat_entity
)))
754 /* If the renamed object had padding, strip off the reference
755 to the inner object and reset our type. */
756 if (TREE_CODE (gnu_expr
) == COMPONENT_REF
757 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))
759 && (TYPE_IS_PADDING_P
760 (TREE_TYPE (TREE_OPERAND (gnu_expr
, 0)))))
762 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
763 gnu_type
= TREE_TYPE (gnu_expr
);
766 /* Case 1: If this is a constant renaming, treat it as a normal
767 object whose initial value is what is being renamed. We cannot
768 do this if the type is unconstrained or class-wide. */
770 && !TREE_SIDE_EFFECTS (gnu_expr
)
771 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
772 && TYPE_MODE (gnu_type
) != BLKmode
773 && Ekind (Etype (gnat_entity
)) != E_Class_Wide_Type
774 && !Is_Array_Type (Etype (gnat_entity
)))
777 /* Otherwise, see if we can proceed with a stabilized version of
778 the renamed entity or if we need to make a pointer. */
781 bool stabilized
= false;
782 tree maybe_stable_expr
= NULL_TREE
;
784 /* Case 2: If the renaming entity need not be materialized and
785 the renamed expression is something we can stabilize, use
786 that for the renaming. At the global level, we can only do
787 this if we know no SAVE_EXPRs need be made, because the
788 expression we return might be used in arbitrary conditional
789 branches so we must force the SAVE_EXPRs evaluation
790 immediately and this requires a function context. */
791 if (!Materialize_Entity (gnat_entity
)
792 && (!global_bindings_p ()
793 || (staticp (gnu_expr
)
794 && !TREE_SIDE_EFFECTS (gnu_expr
))))
797 = maybe_stabilize_reference (gnu_expr
, true, false,
802 gnu_decl
= maybe_stable_expr
;
803 save_gnu_tree (gnat_entity
, gnu_decl
, true);
808 /* The stabilization failed. Keep maybe_stable_expr
809 untouched here to let the pointer case below know
810 about that failure. */
813 /* Case 3: Make this into a constant pointer to the object we
814 are to rename and attach the object to the pointer if it is
815 an lvalue that can be stabilized.
817 From the proper scope, attached objects will be referenced
818 directly instead of indirectly via the pointer to avoid
819 subtle aliasing problems with non addressable entities.
820 They have to be stable because we must not evaluate the
821 variables in the expression every time the renaming is used.
822 They also have to be lvalues because the context in which
823 they are reused sometimes requires so. We call pointers
824 with an attached object "renaming" pointers.
826 In the rare cases where we cannot stabilize the renamed
827 object, we just make a "bare" pointer, and the renamed
828 entity is always accessed indirectly through it. */
830 inner_const_flag
= TREE_READONLY (gnu_expr
);
832 gnu_type
= build_reference_type (gnu_type
);
834 /* If a previous attempt at unrestricted stabilization
835 failed, there is no point trying again and we can reuse
836 the result without attaching it to the pointer. In this
837 case it will only be used as the initializing expression
838 of the pointer and thus needs no special treatment with
839 regard to multiple evaluations. */
840 if (maybe_stable_expr
)
843 /* Otherwise, try to stabilize now, restricting to lvalues
844 only, and attach the expression to the pointer if the
845 stabilization succeeds.
847 Note that this might introduce SAVE_EXPRs and we don't
848 check whether we're at the global level or not. This is
849 fine since we are building a pointer initializer and
850 neither the pointer nor the initializing expression can
851 be accessed before the pointer elaboration has taken
852 place in a correct program.
854 SAVE_EXPRs will be evaluated at the right spots by either
855 create_var_decl->expand_decl_init for the non-global case
856 or build_unit_elab for the global case, and will be
857 attached to the elaboration procedure by the RTL expander
858 in the latter case. We have no need to force an early
863 = maybe_stabilize_reference (gnu_expr
, true, true,
867 renamed_obj
= maybe_stable_expr
;
869 /* Attaching is actually performed downstream, as soon
870 as we have a VAR_DECL for the pointer we make. */
874 = build_unary_op (ADDR_EXPR
, gnu_type
, maybe_stable_expr
);
876 gnu_size
= NULL_TREE
;
882 /* If this is an aliased object whose nominal subtype is unconstrained,
883 the object is a record that contains both the template and
884 the object. If there is an initializer, it will have already
885 been converted to the right type, but we need to create the
886 template if there is no initializer. */
887 else if (definition
&& TREE_CODE (gnu_type
) == RECORD_TYPE
888 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type
)
889 /* Beware that padding might have been introduced
890 via maybe_pad_type above. */
891 || (TYPE_IS_PADDING_P (gnu_type
)
892 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
894 && TYPE_CONTAINS_TEMPLATE_P
895 (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))
899 = TYPE_IS_PADDING_P (gnu_type
)
900 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type
)))
901 : TYPE_FIELDS (gnu_type
);
904 = gnat_build_constructor
908 build_template (TREE_TYPE (template_field
),
909 TREE_TYPE (TREE_CHAIN (template_field
)),
914 /* If this is a pointer and it does not have an initializing
915 expression, initialize it to NULL, unless the object is
918 && (POINTER_TYPE_P (gnu_type
) || TYPE_FAT_POINTER_P (gnu_type
))
919 && !Is_Imported (gnat_entity
) && !gnu_expr
)
920 gnu_expr
= integer_zero_node
;
922 /* If we are defining the object and it has an Address clause we must
923 get the address expression from the saved GCC tree for the
924 object if the object has a Freeze_Node. Otherwise, we elaborate
925 the address expression here since the front-end has guaranteed
926 in that case that the elaboration has no effects. Note that
927 only the latter mechanism is currently in use. */
928 if (definition
&& Present (Address_Clause (gnat_entity
)))
931 = (present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
)
932 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
934 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
936 /* Ignore the size. It's either meaningless or was handled
938 gnu_size
= NULL_TREE
;
939 /* Convert the type of the object to a reference type that can
940 alias everything as per 13.3(19). */
942 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
943 gnu_address
= convert (gnu_type
, gnu_address
);
945 const_flag
= !Is_Public (gnat_entity
);
947 /* If we don't have an initializing expression for the underlying
948 variable, the initializing expression for the pointer is the
949 specified address. Otherwise, we have to make a COMPOUND_EXPR
950 to assign both the address and the initial value. */
952 gnu_expr
= gnu_address
;
955 = build2 (COMPOUND_EXPR
, gnu_type
,
957 (MODIFY_EXPR
, NULL_TREE
,
958 build_unary_op (INDIRECT_REF
, NULL_TREE
,
964 /* If it has an address clause and we are not defining it, mark it
965 as an indirect object. Likewise for Stdcall objects that are
967 if ((!definition
&& Present (Address_Clause (gnat_entity
)))
968 || (Is_Imported (gnat_entity
)
969 && Has_Stdcall_Convention (gnat_entity
)))
971 /* Convert the type of the object to a reference type that can
972 alias everything as per 13.3(19). */
974 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
975 gnu_size
= NULL_TREE
;
977 gnu_expr
= NULL_TREE
;
978 /* No point in taking the address of an initializing expression
979 that isn't going to be used. */
984 /* If we are at top level and this object is of variable size,
985 make the actual type a hidden pointer to the real type and
986 make the initializer be a memory allocation and initialization.
987 Likewise for objects we aren't defining (presumed to be
988 external references from other packages), but there we do
989 not set up an initialization.
991 If the object's size overflows, make an allocator too, so that
992 Storage_Error gets raised. Note that we will never free
993 such memory, so we presume it never will get allocated. */
995 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type
),
996 global_bindings_p () || !definition
999 && ! allocatable_size_p (gnu_size
,
1000 global_bindings_p () || !definition
1003 gnu_type
= build_reference_type (gnu_type
);
1004 gnu_size
= NULL_TREE
;
1008 /* In case this was a aliased object whose nominal subtype is
1009 unconstrained, the pointer above will be a thin pointer and
1010 build_allocator will automatically make the template.
1012 If we have a template initializer only (that we made above),
1013 pretend there is none and rely on what build_allocator creates
1014 again anyway. Otherwise (if we have a full initializer), get
1015 the data part and feed that to build_allocator.
1017 If we are elaborating a mutable object, tell build_allocator to
1018 ignore a possibly simpler size from the initializer, if any, as
1019 we must allocate the maximum possible size in this case. */
1023 tree gnu_alloc_type
= TREE_TYPE (gnu_type
);
1025 if (TREE_CODE (gnu_alloc_type
) == RECORD_TYPE
1026 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type
))
1029 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type
)));
1031 if (TREE_CODE (gnu_expr
) == CONSTRUCTOR
1032 && 1 == VEC_length (constructor_elt
,
1033 CONSTRUCTOR_ELTS (gnu_expr
)))
1037 = build_component_ref
1038 (gnu_expr
, NULL_TREE
,
1039 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr
))),
1043 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type
)) == INTEGER_CST
1044 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type
))
1045 && !Is_Imported (gnat_entity
))
1046 post_error ("Storage_Error will be raised at run-time?",
1049 gnu_expr
= build_allocator (gnu_alloc_type
, gnu_expr
, gnu_type
,
1050 0, 0, gnat_entity
, mutable_p
);
1054 gnu_expr
= NULL_TREE
;
1059 /* If this object would go into the stack and has an alignment
1060 larger than the default largest alignment, make a variable
1061 to hold the "aligning type" with a modified initial value,
1062 if any, then point to it and make that the value of this
1063 variable, which is now indirect. */
1064 if (!global_bindings_p () && !static_p
&& definition
1065 && !imported_p
&& TYPE_ALIGN (gnu_type
) > BIGGEST_ALIGNMENT
)
1068 = make_aligning_type (gnu_type
, TYPE_ALIGN (gnu_type
),
1069 TYPE_SIZE_UNIT (gnu_type
));
1073 = create_var_decl (create_concat_name (gnat_entity
, "ALIGN"),
1074 NULL_TREE
, gnu_new_type
, NULL_TREE
, false,
1075 false, false, false, NULL
, gnat_entity
);
1079 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
1081 (gnu_new_var
, NULL_TREE
,
1082 TYPE_FIELDS (gnu_new_type
), false),
1086 gnu_type
= build_reference_type (gnu_type
);
1089 (ADDR_EXPR
, gnu_type
,
1090 build_component_ref (gnu_new_var
, NULL_TREE
,
1091 TYPE_FIELDS (gnu_new_type
), false));
1093 gnu_size
= NULL_TREE
;
1099 gnu_type
= build_qualified_type (gnu_type
, (TYPE_QUALS (gnu_type
)
1100 | TYPE_QUAL_CONST
));
1102 /* Convert the expression to the type of the object except in the
1103 case where the object's type is unconstrained or the object's type
1104 is a padded record whose field is of self-referential size. In
1105 the former case, converting will generate unnecessary evaluations
1106 of the CONSTRUCTOR to compute the size and in the latter case, we
1107 want to only copy the actual data. */
1109 && TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
1110 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
1111 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1112 && TYPE_IS_PADDING_P (gnu_type
)
1113 && (CONTAINS_PLACEHOLDER_P
1114 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type
)))))))
1115 gnu_expr
= convert (gnu_type
, gnu_expr
);
1117 /* If this name is external or there was a name specified, use it,
1118 unless this is a VMS exception object since this would conflict
1119 with the symbol we need to export in addition. Don't use the
1120 Interface_Name if there is an address clause (see CD30005). */
1121 if (!Is_VMS_Exception (gnat_entity
)
1122 && ((Present (Interface_Name (gnat_entity
))
1123 && No (Address_Clause (gnat_entity
)))
1124 || (Is_Public (gnat_entity
)
1125 && (!Is_Imported (gnat_entity
)
1126 || Is_Exported (gnat_entity
)))))
1127 gnu_ext_name
= create_concat_name (gnat_entity
, 0);
1129 /* If this is constant initialized to a static constant and the
1130 object has an aggregate type, force it to be statically
1132 if (const_flag
&& gnu_expr
&& TREE_CONSTANT (gnu_expr
)
1133 && host_integerp (TYPE_SIZE_UNIT (gnu_type
), 1)
1134 && (AGGREGATE_TYPE_P (gnu_type
)
1135 && !(TREE_CODE (gnu_type
) == RECORD_TYPE
1136 && TYPE_IS_PADDING_P (gnu_type
))))
1139 gnu_decl
= create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1140 gnu_expr
, const_flag
,
1141 Is_Public (gnat_entity
),
1142 imported_p
|| !definition
,
1143 static_p
, attr_list
, gnat_entity
);
1144 DECL_BY_REF_P (gnu_decl
) = used_by_ref
;
1145 DECL_POINTS_TO_READONLY_P (gnu_decl
) = used_by_ref
&& inner_const_flag
;
1146 if (TREE_CODE (gnu_decl
) == VAR_DECL
&& renamed_obj
)
1148 SET_DECL_RENAMED_OBJECT (gnu_decl
, renamed_obj
);
1149 if (global_bindings_p ())
1151 DECL_RENAMING_GLOBAL_P (gnu_decl
) = 1;
1152 record_global_renaming_pointer (gnu_decl
);
1156 if (definition
&& DECL_SIZE (gnu_decl
)
1157 && get_block_jmpbuf_decl ()
1158 && (TREE_CODE (DECL_SIZE (gnu_decl
)) != INTEGER_CST
1159 || (flag_stack_check
&& !STACK_CHECK_BUILTIN
1160 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl
),
1161 STACK_CHECK_MAX_VAR_SIZE
))))
1162 add_stmt_with_node (build_call_1_expr
1163 (update_setjmp_buf_decl
,
1164 build_unary_op (ADDR_EXPR
, NULL_TREE
,
1165 get_block_jmpbuf_decl ())),
1168 /* If this is a public constant or we're not optimizing and we're not
1169 making a VAR_DECL for it, make one just for export or debugger use.
1170 Likewise if the address is taken or if either the object or type is
1171 aliased. Make an external declaration for a reference, unless this
1172 is a Standard entity since there no real symbol at the object level
1174 if (TREE_CODE (gnu_decl
) == CONST_DECL
1175 && (definition
|| Sloc (gnat_entity
) > Standard_Location
)
1176 && (Is_Public (gnat_entity
)
1178 || Address_Taken (gnat_entity
)
1179 || Is_Aliased (gnat_entity
)
1180 || Is_Aliased (Etype (gnat_entity
))))
1183 = create_true_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
1184 gnu_expr
, true, Is_Public (gnat_entity
),
1185 !definition
, static_p
, NULL
,
1188 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl
, gnu_corr_var
);
1191 /* If this is declared in a block that contains a block with an
1192 exception handler, we must force this variable in memory to
1193 suppress an invalid optimization. */
1194 if (Has_Nested_Block_With_Handler (Scope (gnat_entity
))
1195 && Exception_Mechanism
!= Back_End_Exceptions
)
1196 TREE_ADDRESSABLE (gnu_decl
) = 1;
1198 /* Back-annotate the Alignment of the object if not already in the
1199 tree. Likewise for Esize if the object is of a constant size.
1200 But if the "object" is actually a pointer to an object, the
1201 alignment and size are the same as the type, so don't back-annotate
1202 the values for the pointer. */
1203 if (!used_by_ref
&& Unknown_Alignment (gnat_entity
))
1204 Set_Alignment (gnat_entity
,
1205 UI_From_Int (DECL_ALIGN (gnu_decl
) / BITS_PER_UNIT
));
1207 if (!used_by_ref
&& Unknown_Esize (gnat_entity
)
1208 && DECL_SIZE (gnu_decl
))
1210 tree gnu_back_size
= DECL_SIZE (gnu_decl
);
1212 if (TREE_CODE (TREE_TYPE (gnu_decl
)) == RECORD_TYPE
1213 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl
)))
1215 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN
1216 (TYPE_FIELDS (TREE_TYPE (gnu_decl
)))));
1218 Set_Esize (gnat_entity
, annotate_value (gnu_back_size
));
1224 /* Return a TYPE_DECL for "void" that we previously made. */
1225 gnu_decl
= void_type_decl_node
;
1228 case E_Enumeration_Type
:
1229 /* A special case, for the types Character and Wide_Character in
1230 Standard, we do not list all the literals. So if the literals
1231 are not specified, make this an unsigned type. */
1232 if (No (First_Literal (gnat_entity
)))
1234 gnu_type
= make_unsigned_type (esize
);
1235 TYPE_NAME (gnu_type
) = gnu_entity_id
;
1237 /* Set the TYPE_STRING_FLAG for Ada Character and
1238 Wide_Character types. This is needed by the dwarf-2 debug writer to
1239 distinguish between unsigned integer types and character types. */
1240 TYPE_STRING_FLAG (gnu_type
) = 1;
1244 /* Normal case of non-character type, or non-Standard character type */
1246 /* Here we have a list of enumeral constants in First_Literal.
1247 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1248 the list to be places into TYPE_FIELDS. Each node in the list
1249 is a TREE_LIST node whose TREE_VALUE is the literal name
1250 and whose TREE_PURPOSE is the value of the literal.
1252 Esize contains the number of bits needed to represent the enumeral
1253 type, Type_Low_Bound also points to the first literal and
1254 Type_High_Bound points to the last literal. */
1256 Entity_Id gnat_literal
;
1257 tree gnu_literal_list
= NULL_TREE
;
1259 if (Is_Unsigned_Type (gnat_entity
))
1260 gnu_type
= make_unsigned_type (esize
);
1262 gnu_type
= make_signed_type (esize
);
1264 TREE_SET_CODE (gnu_type
, ENUMERAL_TYPE
);
1266 for (gnat_literal
= First_Literal (gnat_entity
);
1267 Present (gnat_literal
);
1268 gnat_literal
= Next_Literal (gnat_literal
))
1270 tree gnu_value
= UI_To_gnu (Enumeration_Rep (gnat_literal
),
1273 = create_var_decl (get_entity_name (gnat_literal
), NULL_TREE
,
1274 gnu_type
, gnu_value
, true, false, false,
1275 false, NULL
, gnat_literal
);
1277 save_gnu_tree (gnat_literal
, gnu_literal
, false);
1278 gnu_literal_list
= tree_cons (DECL_NAME (gnu_literal
),
1279 gnu_value
, gnu_literal_list
);
1282 TYPE_VALUES (gnu_type
) = nreverse (gnu_literal_list
);
1284 /* Note that the bounds are updated at the end of this function
1285 because to avoid an infinite recursion when we get the bounds of
1286 this type, since those bounds are objects of this type. */
1290 case E_Signed_Integer_Type
:
1291 case E_Ordinary_Fixed_Point_Type
:
1292 case E_Decimal_Fixed_Point_Type
:
1293 /* For integer types, just make a signed type the appropriate number
1295 gnu_type
= make_signed_type (esize
);
1298 case E_Modular_Integer_Type
:
1299 /* For modular types, make the unsigned type of the proper number of
1300 bits and then set up the modulus, if required. */
1302 enum machine_mode mode
;
1306 if (Is_Packed_Array_Type (gnat_entity
))
1307 esize
= UI_To_Int (RM_Size (gnat_entity
));
1309 /* Find the smallest mode at least ESIZE bits wide and make a class
1312 for (mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
1313 GET_MODE_BITSIZE (mode
) < esize
;
1314 mode
= GET_MODE_WIDER_MODE (mode
))
1317 gnu_type
= make_unsigned_type (GET_MODE_BITSIZE (mode
));
1318 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
1319 = Is_Packed_Array_Type (gnat_entity
);
1321 /* Get the modulus in this type. If it overflows, assume it is because
1322 it is equal to 2**Esize. Note that there is no overflow checking
1323 done on unsigned type, so we detect the overflow by looking for
1324 a modulus of zero, which is otherwise invalid. */
1325 gnu_modulus
= UI_To_gnu (Modulus (gnat_entity
), gnu_type
);
1327 if (!integer_zerop (gnu_modulus
))
1329 TYPE_MODULAR_P (gnu_type
) = 1;
1330 SET_TYPE_MODULUS (gnu_type
, gnu_modulus
);
1331 gnu_high
= fold_build2 (MINUS_EXPR
, gnu_type
, gnu_modulus
,
1332 convert (gnu_type
, integer_one_node
));
1335 /* If we have to set TYPE_PRECISION different from its natural value,
1336 make a subtype to do do. Likewise if there is a modulus and
1337 it is not one greater than TYPE_MAX_VALUE. */
1338 if (TYPE_PRECISION (gnu_type
) != esize
1339 || (TYPE_MODULAR_P (gnu_type
)
1340 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type
), gnu_high
)))
1342 tree gnu_subtype
= make_node (INTEGER_TYPE
);
1344 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "UMT");
1345 TREE_TYPE (gnu_subtype
) = gnu_type
;
1346 TYPE_MIN_VALUE (gnu_subtype
) = TYPE_MIN_VALUE (gnu_type
);
1347 TYPE_MAX_VALUE (gnu_subtype
)
1348 = TYPE_MODULAR_P (gnu_type
)
1349 ? gnu_high
: TYPE_MAX_VALUE (gnu_type
);
1350 TYPE_PRECISION (gnu_subtype
) = esize
;
1351 TYPE_UNSIGNED (gnu_subtype
) = 1;
1352 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
1353 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype
)
1354 = Is_Packed_Array_Type (gnat_entity
);
1355 layout_type (gnu_subtype
);
1357 gnu_type
= gnu_subtype
;
1362 case E_Signed_Integer_Subtype
:
1363 case E_Enumeration_Subtype
:
1364 case E_Modular_Integer_Subtype
:
1365 case E_Ordinary_Fixed_Point_Subtype
:
1366 case E_Decimal_Fixed_Point_Subtype
:
1368 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1369 that we do not want to call build_range_type since we would
1370 like each subtype node to be distinct. This will be important
1371 when memory aliasing is implemented.
1373 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1374 parent type; this fact is used by the arithmetic conversion
1377 We elaborate the Ancestor_Subtype if it is not in the current
1378 unit and one of our bounds is non-static. We do this to ensure
1379 consistent naming in the case where several subtypes share the same
1380 bounds by always elaborating the first such subtype first, thus
1384 && Present (Ancestor_Subtype (gnat_entity
))
1385 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1386 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1387 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1388 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1391 gnu_type
= make_node (INTEGER_TYPE
);
1392 if (Is_Packed_Array_Type (gnat_entity
))
1394 esize
= UI_To_Int (RM_Size (gnat_entity
));
1395 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
) = 1;
1398 TYPE_PRECISION (gnu_type
) = esize
;
1399 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1401 TYPE_MIN_VALUE (gnu_type
)
1402 = convert (TREE_TYPE (gnu_type
),
1403 elaborate_expression (Type_Low_Bound (gnat_entity
),
1405 get_identifier ("L"), definition
, 1,
1406 Needs_Debug_Info (gnat_entity
)));
1408 TYPE_MAX_VALUE (gnu_type
)
1409 = convert (TREE_TYPE (gnu_type
),
1410 elaborate_expression (Type_High_Bound (gnat_entity
),
1412 get_identifier ("U"), definition
, 1,
1413 Needs_Debug_Info (gnat_entity
)));
1415 /* One of the above calls might have caused us to be elaborated,
1416 so don't blow up if so. */
1417 if (present_gnu_tree (gnat_entity
))
1419 maybe_present
= true;
1423 TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1424 = Has_Biased_Representation (gnat_entity
);
1426 /* This should be an unsigned type if the lower bound is constant
1427 and non-negative or if the base type is unsigned; a signed type
1429 TYPE_UNSIGNED (gnu_type
)
1430 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type
))
1431 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type
)) == INTEGER_CST
1432 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type
)) >= 0)
1433 || TYPE_BIASED_REPRESENTATION_P (gnu_type
)
1434 || Is_Unsigned_Type (gnat_entity
));
1436 layout_type (gnu_type
);
1438 /* Inherit our alias set from what we're a subtype of. Subtypes
1439 are not different types and a pointer can designate any instance
1440 within a subtype hierarchy. */
1441 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1443 /* If the type we are dealing with is to represent a packed array,
1444 we need to have the bits left justified on big-endian targets
1445 and right justified on little-endian targets. We also need to
1446 ensure that when the value is read (e.g. for comparison of two
1447 such values), we only get the good bits, since the unused bits
1448 are uninitialized. Both goals are accomplished by wrapping the
1449 modular value in an enclosing struct. */
1450 if (Is_Packed_Array_Type (gnat_entity
))
1452 tree gnu_field_type
= gnu_type
;
1455 TYPE_RM_SIZE_NUM (gnu_field_type
)
1456 = UI_To_gnu (RM_Size (gnat_entity
), bitsizetype
);
1457 gnu_type
= make_node (RECORD_TYPE
);
1458 TYPE_NAME (gnu_type
) = create_concat_name (gnat_entity
, "JM");
1459 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_field_type
);
1460 TYPE_PACKED (gnu_type
) = 1;
1462 /* Create a stripped-down declaration of the original type, mainly
1464 create_type_decl (get_entity_name (gnat_entity
), gnu_field_type
,
1465 NULL
, true, debug_info_p
, gnat_entity
);
1467 /* Don't notify the field as "addressable", since we won't be taking
1468 it's address and it would prevent create_field_decl from making a
1470 gnu_field
= create_field_decl (get_identifier ("OBJECT"),
1471 gnu_field_type
, gnu_type
, 1, 0, 0, 0);
1473 finish_record_type (gnu_type
, gnu_field
, false, false);
1474 TYPE_JUSTIFIED_MODULAR_P (gnu_type
) = 1;
1475 SET_TYPE_ADA_SIZE (gnu_type
, bitsize_int (esize
));
1477 copy_alias_set (gnu_type
, gnu_field_type
);
1482 case E_Floating_Point_Type
:
1483 /* If this is a VAX floating-point type, use an integer of the proper
1484 size. All the operations will be handled with ASM statements. */
1485 if (Vax_Float (gnat_entity
))
1487 gnu_type
= make_signed_type (esize
);
1488 TYPE_VAX_FLOATING_POINT_P (gnu_type
) = 1;
1489 SET_TYPE_DIGITS_VALUE (gnu_type
,
1490 UI_To_gnu (Digits_Value (gnat_entity
),
1495 /* The type of the Low and High bounds can be our type if this is
1496 a type from Standard, so set them at the end of the function. */
1497 gnu_type
= make_node (REAL_TYPE
);
1498 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1499 layout_type (gnu_type
);
1502 case E_Floating_Point_Subtype
:
1503 if (Vax_Float (gnat_entity
))
1505 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1511 && Present (Ancestor_Subtype (gnat_entity
))
1512 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity
))
1513 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity
))
1514 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity
))))
1515 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity
),
1518 gnu_type
= make_node (REAL_TYPE
);
1519 TREE_TYPE (gnu_type
) = get_unpadded_type (Etype (gnat_entity
));
1520 TYPE_PRECISION (gnu_type
) = fp_size_to_prec (esize
);
1522 TYPE_MIN_VALUE (gnu_type
)
1523 = convert (TREE_TYPE (gnu_type
),
1524 elaborate_expression (Type_Low_Bound (gnat_entity
),
1525 gnat_entity
, get_identifier ("L"),
1527 Needs_Debug_Info (gnat_entity
)));
1529 TYPE_MAX_VALUE (gnu_type
)
1530 = convert (TREE_TYPE (gnu_type
),
1531 elaborate_expression (Type_High_Bound (gnat_entity
),
1532 gnat_entity
, get_identifier ("U"),
1534 Needs_Debug_Info (gnat_entity
)));
1536 /* One of the above calls might have caused us to be elaborated,
1537 so don't blow up if so. */
1538 if (present_gnu_tree (gnat_entity
))
1540 maybe_present
= true;
1544 layout_type (gnu_type
);
1546 /* Inherit our alias set from what we're a subtype of, as for
1547 integer subtypes. */
1548 copy_alias_set (gnu_type
, TREE_TYPE (gnu_type
));
1552 /* Array and String Types and Subtypes
1554 Unconstrained array types are represented by E_Array_Type and
1555 constrained array types are represented by E_Array_Subtype. There
1556 are no actual objects of an unconstrained array type; all we have
1557 are pointers to that type.
1559 The following fields are defined on array types and subtypes:
1561 Component_Type Component type of the array.
1562 Number_Dimensions Number of dimensions (an int).
1563 First_Index Type of first index. */
1568 tree gnu_template_fields
= NULL_TREE
;
1569 tree gnu_template_type
= make_node (RECORD_TYPE
);
1570 tree gnu_ptr_template
= build_pointer_type (gnu_template_type
);
1571 tree gnu_fat_type
= make_node (RECORD_TYPE
);
1572 int ndim
= Number_Dimensions (gnat_entity
);
1574 = (Convention (gnat_entity
) == Convention_Fortran
) ? ndim
- 1 : 0;
1576 = (Convention (gnat_entity
) == Convention_Fortran
) ? - 1 : 1;
1577 tree
*gnu_index_types
= (tree
*) alloca (ndim
* sizeof (tree
*));
1578 tree
*gnu_temp_fields
= (tree
*) alloca (ndim
* sizeof (tree
*));
1579 tree gnu_comp_size
= 0;
1580 tree gnu_max_size
= size_one_node
;
1581 tree gnu_max_size_unit
;
1583 Entity_Id gnat_ind_subtype
;
1584 Entity_Id gnat_ind_base_subtype
;
1585 tree gnu_template_reference
;
1588 TYPE_NAME (gnu_template_type
)
1589 = create_concat_name (gnat_entity
, "XUB");
1590 TYPE_NAME (gnu_fat_type
) = create_concat_name (gnat_entity
, "XUP");
1591 TYPE_IS_FAT_POINTER_P (gnu_fat_type
) = 1;
1592 TYPE_READONLY (gnu_template_type
) = 1;
1594 /* Make a node for the array. If we are not defining the array
1595 suppress expanding incomplete types. */
1596 gnu_type
= make_node (UNCONSTRAINED_ARRAY_TYPE
);
1599 defer_incomplete_level
++, this_deferred
= true;
1601 /* Build the fat pointer type. Use a "void *" object instead of
1602 a pointer to the array type since we don't have the array type
1603 yet (it will reference the fat pointer via the bounds). */
1604 tem
= chainon (chainon (NULL_TREE
,
1605 create_field_decl (get_identifier ("P_ARRAY"),
1607 gnu_fat_type
, 0, 0, 0, 0)),
1608 create_field_decl (get_identifier ("P_BOUNDS"),
1610 gnu_fat_type
, 0, 0, 0, 0));
1612 /* Make sure we can put this into a register. */
1613 TYPE_ALIGN (gnu_fat_type
) = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
1614 finish_record_type (gnu_fat_type
, tem
, false, true);
1616 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1617 is the fat pointer. This will be used to access the individual
1618 fields once we build them. */
1619 tem
= build3 (COMPONENT_REF
, gnu_ptr_template
,
1620 build0 (PLACEHOLDER_EXPR
, gnu_fat_type
),
1621 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type
)), NULL_TREE
);
1622 gnu_template_reference
1623 = build_unary_op (INDIRECT_REF
, gnu_template_type
, tem
);
1624 TREE_READONLY (gnu_template_reference
) = 1;
1626 /* Now create the GCC type for each index and add the fields for
1627 that index to the template. */
1628 for (index
= firstdim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1629 gnat_ind_base_subtype
1630 = First_Index (Implementation_Base_Type (gnat_entity
));
1631 index
< ndim
&& index
>= 0;
1633 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1634 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1636 char field_name
[10];
1637 tree gnu_ind_subtype
1638 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype
)));
1639 tree gnu_base_subtype
1640 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1642 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1644 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1645 tree gnu_min_field
, gnu_max_field
, gnu_min
, gnu_max
;
1647 /* Make the FIELD_DECLs for the minimum and maximum of this
1648 type and then make extractions of that field from the
1650 sprintf (field_name
, "LB%d", index
);
1651 gnu_min_field
= create_field_decl (get_identifier (field_name
),
1653 gnu_template_type
, 0, 0, 0, 0);
1654 field_name
[0] = 'U';
1655 gnu_max_field
= create_field_decl (get_identifier (field_name
),
1657 gnu_template_type
, 0, 0, 0, 0);
1659 Sloc_to_locus (Sloc (gnat_entity
),
1660 &DECL_SOURCE_LOCATION (gnu_min_field
));
1661 Sloc_to_locus (Sloc (gnat_entity
),
1662 &DECL_SOURCE_LOCATION (gnu_max_field
));
1663 gnu_temp_fields
[index
] = chainon (gnu_min_field
, gnu_max_field
);
1665 /* We can't use build_component_ref here since the template
1666 type isn't complete yet. */
1667 gnu_min
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1668 gnu_template_reference
, gnu_min_field
,
1670 gnu_max
= build3 (COMPONENT_REF
, gnu_ind_subtype
,
1671 gnu_template_reference
, gnu_max_field
,
1673 TREE_READONLY (gnu_min
) = TREE_READONLY (gnu_max
) = 1;
1675 /* Make a range type with the new ranges, but using
1676 the Ada subtype. Then we convert to sizetype. */
1677 gnu_index_types
[index
]
1678 = create_index_type (convert (sizetype
, gnu_min
),
1679 convert (sizetype
, gnu_max
),
1680 build_range_type (gnu_ind_subtype
,
1682 /* Update the maximum size of the array, in elements. */
1684 = size_binop (MULT_EXPR
, gnu_max_size
,
1685 size_binop (PLUS_EXPR
, size_one_node
,
1686 size_binop (MINUS_EXPR
, gnu_base_max
,
1689 TYPE_NAME (gnu_index_types
[index
])
1690 = create_concat_name (gnat_entity
, field_name
);
1693 for (index
= 0; index
< ndim
; index
++)
1695 = chainon (gnu_template_fields
, gnu_temp_fields
[index
]);
1697 /* Install all the fields into the template. */
1698 finish_record_type (gnu_template_type
, gnu_template_fields
,
1700 TYPE_READONLY (gnu_template_type
) = 1;
1702 /* Now make the array of arrays and update the pointer to the array
1703 in the fat pointer. Note that it is the first field. */
1705 tem
= gnat_to_gnu_type (Component_Type (gnat_entity
));
1707 /* Get and validate any specified Component_Size, but if Packed,
1708 ignore it since the front end will have taken care of it. */
1710 = validate_size (Component_Size (gnat_entity
), tem
,
1712 (Is_Bit_Packed_Array (gnat_entity
)
1713 ? TYPE_DECL
: VAR_DECL
),
1714 true, Has_Component_Size_Clause (gnat_entity
));
1716 if (Has_Atomic_Components (gnat_entity
))
1717 check_ok_for_atomic (tem
, gnat_entity
, true);
1719 /* If the component type is a RECORD_TYPE that has a self-referential
1720 size, use the maxium size. */
1721 if (!gnu_comp_size
&& TREE_CODE (tem
) == RECORD_TYPE
1722 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem
)))
1723 gnu_comp_size
= max_size (TYPE_SIZE (tem
), true);
1725 if (!Is_Bit_Packed_Array (gnat_entity
) && gnu_comp_size
)
1727 tem
= make_type_from_size (tem
, gnu_comp_size
, false);
1728 tem
= maybe_pad_type (tem
, gnu_comp_size
, 0, gnat_entity
,
1729 "C_PAD", false, definition
, true);
1732 if (Has_Volatile_Components (gnat_entity
))
1733 tem
= build_qualified_type (tem
,
1734 TYPE_QUALS (tem
) | TYPE_QUAL_VOLATILE
);
1736 /* If Component_Size is not already specified, annotate it with the
1737 size of the component. */
1738 if (Unknown_Component_Size (gnat_entity
))
1739 Set_Component_Size (gnat_entity
, annotate_value (TYPE_SIZE (tem
)));
1741 gnu_max_size_unit
= size_binop (MAX_EXPR
, size_zero_node
,
1742 size_binop (MULT_EXPR
, gnu_max_size
,
1743 TYPE_SIZE_UNIT (tem
)));
1744 gnu_max_size
= size_binop (MAX_EXPR
, bitsize_zero_node
,
1745 size_binop (MULT_EXPR
,
1746 convert (bitsizetype
,
1750 for (index
= ndim
- 1; index
>= 0; index
--)
1752 tem
= build_array_type (tem
, gnu_index_types
[index
]);
1753 TYPE_MULTI_ARRAY_P (tem
) = (index
> 0);
1755 /* If the type below this is a multi-array type, then this
1756 does not have aliased components. But we have to make
1757 them addressable if it must be passed by reference or
1758 if that is the default. */
1759 if ((TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
1760 && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem
)))
1761 || (!Has_Aliased_Components (gnat_entity
)
1762 && !must_pass_by_ref (TREE_TYPE (tem
))
1763 && !default_pass_by_ref (TREE_TYPE (tem
))))
1764 TYPE_NONALIASED_COMPONENT (tem
) = 1;
1767 /* If an alignment is specified, use it if valid. But ignore it for
1768 types that represent the unpacked base type for packed arrays. */
1769 if (No (Packed_Array_Type (gnat_entity
))
1770 && Known_Alignment (gnat_entity
))
1772 gcc_assert (Present (Alignment (gnat_entity
)));
1774 = validate_alignment (Alignment (gnat_entity
), gnat_entity
,
1778 TYPE_CONVENTION_FORTRAN_P (tem
)
1779 = (Convention (gnat_entity
) == Convention_Fortran
);
1780 TREE_TYPE (TYPE_FIELDS (gnu_fat_type
)) = build_pointer_type (tem
);
1782 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1783 corresponding fat pointer. */
1784 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
)
1785 = TYPE_REFERENCE_TO (gnu_type
) = gnu_fat_type
;
1786 TYPE_MODE (gnu_type
) = BLKmode
;
1787 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (tem
);
1788 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type
, gnu_type
);
1790 /* If the maximum size doesn't overflow, use it. */
1791 if (TREE_CODE (gnu_max_size
) == INTEGER_CST
1792 && !TREE_OVERFLOW (gnu_max_size
))
1794 = size_binop (MIN_EXPR
, gnu_max_size
, TYPE_SIZE (tem
));
1795 if (TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
1796 && !TREE_OVERFLOW (gnu_max_size_unit
))
1797 TYPE_SIZE_UNIT (tem
)
1798 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
1799 TYPE_SIZE_UNIT (tem
));
1801 create_type_decl (create_concat_name (gnat_entity
, "XUA"),
1802 tem
, NULL
, !Comes_From_Source (gnat_entity
),
1803 debug_info_p
, gnat_entity
);
1805 /* Create a record type for the object and its template and
1806 set the template at a negative offset. */
1807 tem
= build_unc_object_type (gnu_template_type
, tem
,
1808 create_concat_name (gnat_entity
, "XUT"));
1809 DECL_FIELD_OFFSET (TYPE_FIELDS (tem
))
1810 = size_binop (MINUS_EXPR
, size_zero_node
,
1811 byte_position (TREE_CHAIN (TYPE_FIELDS (tem
))));
1812 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem
))) = size_zero_node
;
1813 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem
)))
1814 = bitsize_zero_node
;
1815 SET_TYPE_UNCONSTRAINED_ARRAY (tem
, gnu_type
);
1816 TYPE_OBJECT_RECORD_TYPE (gnu_type
) = tem
;
1818 /* Give the thin pointer type a name. */
1819 create_type_decl (create_concat_name (gnat_entity
, "XUX"),
1820 build_pointer_type (tem
), NULL
,
1821 !Comes_From_Source (gnat_entity
), debug_info_p
,
1826 case E_String_Subtype
:
1827 case E_Array_Subtype
:
1829 /* This is the actual data type for array variables. Multidimensional
1830 arrays are implemented in the gnu tree as arrays of arrays. Note
1831 that for the moment arrays which have sparse enumeration subtypes as
1832 index components create sparse arrays, which is obviously space
1833 inefficient but so much easier to code for now.
1835 Also note that the subtype never refers to the unconstrained
1836 array type, which is somewhat at variance with Ada semantics.
1838 First check to see if this is simply a renaming of the array
1839 type. If so, the result is the array type. */
1841 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
1842 if (!Is_Constrained (gnat_entity
))
1847 int array_dim
= Number_Dimensions (gnat_entity
);
1849 = ((Convention (gnat_entity
) == Convention_Fortran
)
1850 ? array_dim
- 1 : 0);
1852 = (Convention (gnat_entity
) == Convention_Fortran
) ? -1 : 1;
1853 Entity_Id gnat_ind_subtype
;
1854 Entity_Id gnat_ind_base_subtype
;
1855 tree gnu_base_type
= gnu_type
;
1856 tree
*gnu_index_type
= (tree
*) alloca (array_dim
* sizeof (tree
*));
1857 tree gnu_comp_size
= NULL_TREE
;
1858 tree gnu_max_size
= size_one_node
;
1859 tree gnu_max_size_unit
;
1860 bool need_index_type_struct
= false;
1861 bool max_overflow
= false;
1863 /* First create the gnu types for each index. Create types for
1864 debugging information to point to the index types if the
1865 are not integer types, have variable bounds, or are
1866 wider than sizetype. */
1868 for (index
= first_dim
, gnat_ind_subtype
= First_Index (gnat_entity
),
1869 gnat_ind_base_subtype
1870 = First_Index (Implementation_Base_Type (gnat_entity
));
1871 index
< array_dim
&& index
>= 0;
1873 gnat_ind_subtype
= Next_Index (gnat_ind_subtype
),
1874 gnat_ind_base_subtype
= Next_Index (gnat_ind_base_subtype
))
1876 tree gnu_index_subtype
1877 = get_unpadded_type (Etype (gnat_ind_subtype
));
1879 = convert (sizetype
, TYPE_MIN_VALUE (gnu_index_subtype
));
1881 = convert (sizetype
, TYPE_MAX_VALUE (gnu_index_subtype
));
1882 tree gnu_base_subtype
1883 = get_unpadded_type (Etype (gnat_ind_base_subtype
));
1885 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_subtype
));
1887 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_subtype
));
1888 tree gnu_base_type
= get_base_type (gnu_base_subtype
);
1889 tree gnu_base_base_min
1890 = convert (sizetype
, TYPE_MIN_VALUE (gnu_base_type
));
1891 tree gnu_base_base_max
1892 = convert (sizetype
, TYPE_MAX_VALUE (gnu_base_type
));
1896 /* If the minimum and maximum values both overflow in
1897 SIZETYPE, but the difference in the original type
1898 does not overflow in SIZETYPE, ignore the overflow
1900 if ((TYPE_PRECISION (gnu_index_subtype
)
1901 > TYPE_PRECISION (sizetype
)
1902 || TYPE_UNSIGNED (gnu_index_subtype
)
1903 != TYPE_UNSIGNED (sizetype
))
1904 && TREE_CODE (gnu_min
) == INTEGER_CST
1905 && TREE_CODE (gnu_max
) == INTEGER_CST
1906 && TREE_OVERFLOW (gnu_min
) && TREE_OVERFLOW (gnu_max
)
1908 (fold_build2 (MINUS_EXPR
, gnu_index_subtype
,
1909 TYPE_MAX_VALUE (gnu_index_subtype
),
1910 TYPE_MIN_VALUE (gnu_index_subtype
)))))
1912 TREE_OVERFLOW (gnu_min
) = 0;
1913 TREE_OVERFLOW (gnu_max
) = 0;
1916 /* Similarly, if the range is null, use bounds of 1..0 for
1917 the sizetype bounds. */
1918 else if ((TYPE_PRECISION (gnu_index_subtype
)
1919 > TYPE_PRECISION (sizetype
)
1920 || TYPE_UNSIGNED (gnu_index_subtype
)
1921 != TYPE_UNSIGNED (sizetype
))
1922 && TREE_CODE (gnu_min
) == INTEGER_CST
1923 && TREE_CODE (gnu_max
) == INTEGER_CST
1924 && (TREE_OVERFLOW (gnu_min
) || TREE_OVERFLOW (gnu_max
))
1925 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype
),
1926 TYPE_MIN_VALUE (gnu_index_subtype
)))
1927 gnu_min
= size_one_node
, gnu_max
= size_zero_node
;
1929 /* Now compute the size of this bound. We need to provide
1930 GCC with an upper bound to use but have to deal with the
1931 "superflat" case. There are three ways to do this. If we
1932 can prove that the array can never be superflat, we can
1933 just use the high bound of the index subtype. If we can
1934 prove that the low bound minus one can't overflow, we
1935 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1936 the expression hb >= lb ? hb : lb - 1. */
1937 gnu_high
= size_binop (MINUS_EXPR
, gnu_min
, size_one_node
);
1939 /* See if the base array type is already flat. If it is, we
1940 are probably compiling an ACVC test, but it will cause the
1941 code below to malfunction if we don't handle it specially. */
1942 if (TREE_CODE (gnu_base_min
) == INTEGER_CST
1943 && TREE_CODE (gnu_base_max
) == INTEGER_CST
1944 && !TREE_OVERFLOW (gnu_base_min
)
1945 && !TREE_OVERFLOW (gnu_base_max
)
1946 && tree_int_cst_lt (gnu_base_max
, gnu_base_min
))
1947 gnu_high
= size_zero_node
, gnu_min
= size_one_node
;
1949 /* If gnu_high is now an integer which overflowed, the array
1950 cannot be superflat. */
1951 else if (TREE_CODE (gnu_high
) == INTEGER_CST
1952 && TREE_OVERFLOW (gnu_high
))
1954 else if (TYPE_UNSIGNED (gnu_base_subtype
)
1955 || TREE_CODE (gnu_high
) == INTEGER_CST
)
1956 gnu_high
= size_binop (MAX_EXPR
, gnu_max
, gnu_high
);
1960 (sizetype
, build_binary_op (GE_EXPR
, integer_type_node
,
1964 gnu_index_type
[index
]
1965 = create_index_type (gnu_min
, gnu_high
, gnu_index_subtype
);
1967 /* Also compute the maximum size of the array. Here we
1968 see if any constraint on the index type of the base type
1969 can be used in the case of self-referential bound on
1970 the index type of the subtype. We look for a non-"infinite"
1971 and non-self-referential bound from any type involved and
1972 handle each bound separately. */
1974 if ((TREE_CODE (gnu_min
) == INTEGER_CST
1975 && !TREE_OVERFLOW (gnu_min
)
1976 && !operand_equal_p (gnu_min
, gnu_base_base_min
, 0))
1977 || !CONTAINS_PLACEHOLDER_P (gnu_min
)
1978 || !(TREE_CODE (gnu_base_min
) == INTEGER_CST
1979 && !TREE_OVERFLOW (gnu_base_min
)))
1980 gnu_base_min
= gnu_min
;
1982 if ((TREE_CODE (gnu_max
) == INTEGER_CST
1983 && !TREE_OVERFLOW (gnu_max
)
1984 && !operand_equal_p (gnu_max
, gnu_base_base_max
, 0))
1985 || !CONTAINS_PLACEHOLDER_P (gnu_max
)
1986 || !(TREE_CODE (gnu_base_max
) == INTEGER_CST
1987 && !TREE_OVERFLOW (gnu_base_max
)))
1988 gnu_base_max
= gnu_max
;
1990 if ((TREE_CODE (gnu_base_min
) == INTEGER_CST
1991 && TREE_OVERFLOW (gnu_base_min
))
1992 || operand_equal_p (gnu_base_min
, gnu_base_base_min
, 0)
1993 || (TREE_CODE (gnu_base_max
) == INTEGER_CST
1994 && TREE_OVERFLOW (gnu_base_max
))
1995 || operand_equal_p (gnu_base_max
, gnu_base_base_max
, 0))
1996 max_overflow
= true;
1998 gnu_base_min
= size_binop (MAX_EXPR
, gnu_base_min
, gnu_min
);
1999 gnu_base_max
= size_binop (MIN_EXPR
, gnu_base_max
, gnu_max
);
2002 = size_binop (MAX_EXPR
,
2003 size_binop (PLUS_EXPR
, size_one_node
,
2004 size_binop (MINUS_EXPR
, gnu_base_max
,
2008 if (TREE_CODE (gnu_this_max
) == INTEGER_CST
2009 && TREE_OVERFLOW (gnu_this_max
))
2010 max_overflow
= true;
2013 = size_binop (MULT_EXPR
, gnu_max_size
, gnu_this_max
);
2015 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype
))
2016 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype
))
2018 || TREE_CODE (gnu_index_subtype
) != INTEGER_TYPE
2019 || (TREE_TYPE (gnu_index_subtype
)
2020 && (TREE_CODE (TREE_TYPE (gnu_index_subtype
))
2022 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype
)
2023 || (TYPE_PRECISION (gnu_index_subtype
)
2024 > TYPE_PRECISION (sizetype
)))
2025 need_index_type_struct
= true;
2028 /* Then flatten: create the array of arrays. */
2030 gnu_type
= gnat_to_gnu_type (Component_Type (gnat_entity
));
2032 /* One of the above calls might have caused us to be elaborated,
2033 so don't blow up if so. */
2034 if (present_gnu_tree (gnat_entity
))
2036 maybe_present
= true;
2040 /* Get and validate any specified Component_Size, but if Packed,
2041 ignore it since the front end will have taken care of it. */
2043 = validate_size (Component_Size (gnat_entity
), gnu_type
,
2045 (Is_Bit_Packed_Array (gnat_entity
)
2046 ? TYPE_DECL
: VAR_DECL
),
2047 true, Has_Component_Size_Clause (gnat_entity
));
2049 /* If the component type is a RECORD_TYPE that has a self-referential
2050 size, use the maxium size. */
2051 if (!gnu_comp_size
&& TREE_CODE (gnu_type
) == RECORD_TYPE
2052 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2053 gnu_comp_size
= max_size (TYPE_SIZE (gnu_type
), true);
2055 if (!Is_Bit_Packed_Array (gnat_entity
) && gnu_comp_size
)
2057 gnu_type
= make_type_from_size (gnu_type
, gnu_comp_size
, false);
2058 gnu_type
= maybe_pad_type (gnu_type
, gnu_comp_size
, 0,
2059 gnat_entity
, "C_PAD", false,
2063 if (Has_Volatile_Components (Base_Type (gnat_entity
)))
2064 gnu_type
= build_qualified_type (gnu_type
,
2065 (TYPE_QUALS (gnu_type
)
2066 | TYPE_QUAL_VOLATILE
));
2068 gnu_max_size_unit
= size_binop (MULT_EXPR
, gnu_max_size
,
2069 TYPE_SIZE_UNIT (gnu_type
));
2070 gnu_max_size
= size_binop (MULT_EXPR
,
2071 convert (bitsizetype
, gnu_max_size
),
2072 TYPE_SIZE (gnu_type
));
2074 for (index
= array_dim
- 1; index
>= 0; index
--)
2076 gnu_type
= build_array_type (gnu_type
, gnu_index_type
[index
]);
2077 TYPE_MULTI_ARRAY_P (gnu_type
) = (index
> 0);
2079 /* If the type below this is a multi-array type, then this
2080 does not have aliased components. But we have to make
2081 them addressable if it must be passed by reference or
2082 if that is the default. */
2083 if ((TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
2084 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
2085 || (!Has_Aliased_Components (gnat_entity
)
2086 && !must_pass_by_ref (TREE_TYPE (gnu_type
))
2087 && !default_pass_by_ref (TREE_TYPE (gnu_type
))))
2088 TYPE_NONALIASED_COMPONENT (gnu_type
) = 1;
2091 /* If we are at file level and this is a multi-dimensional array, we
2092 need to make a variable corresponding to the stride of the
2093 inner dimensions. */
2094 if (global_bindings_p () && array_dim
> 1)
2096 tree gnu_str_name
= get_identifier ("ST");
2099 for (gnu_arr_type
= TREE_TYPE (gnu_type
);
2100 TREE_CODE (gnu_arr_type
) == ARRAY_TYPE
;
2101 gnu_arr_type
= TREE_TYPE (gnu_arr_type
),
2102 gnu_str_name
= concat_id_with_name (gnu_str_name
, "ST"))
2104 tree eltype
= TREE_TYPE (gnu_arr_type
);
2106 TYPE_SIZE (gnu_arr_type
)
2107 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
2108 TYPE_SIZE (gnu_arr_type
),
2109 gnu_str_name
, definition
, 0);
2111 /* ??? For now, store the size as a multiple of the
2112 alignment of the element type in bytes so that we
2113 can see the alignment from the tree. */
2114 TYPE_SIZE_UNIT (gnu_arr_type
)
2116 (MULT_EXPR
, sizetype
,
2117 elaborate_expression_1
2118 (gnat_entity
, gnat_entity
,
2119 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
2120 TYPE_SIZE_UNIT (gnu_arr_type
),
2121 size_int (TYPE_ALIGN (eltype
)
2123 concat_id_with_name (gnu_str_name
, "A_U"),
2125 size_int (TYPE_ALIGN (eltype
) / BITS_PER_UNIT
));
2129 /* If we need to write out a record type giving the names of
2130 the bounds, do it now. */
2131 if (need_index_type_struct
&& debug_info_p
)
2133 tree gnu_bound_rec_type
= make_node (RECORD_TYPE
);
2134 tree gnu_field_list
= NULL_TREE
;
2137 TYPE_NAME (gnu_bound_rec_type
)
2138 = create_concat_name (gnat_entity
, "XA");
2140 for (index
= array_dim
- 1; index
>= 0; index
--)
2143 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type
[index
]));
2145 if (TREE_CODE (gnu_type_name
) == TYPE_DECL
)
2146 gnu_type_name
= DECL_NAME (gnu_type_name
);
2148 gnu_field
= create_field_decl (gnu_type_name
,
2151 0, NULL_TREE
, NULL_TREE
, 0);
2152 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2153 gnu_field_list
= gnu_field
;
2156 finish_record_type (gnu_bound_rec_type
, gnu_field_list
,
2160 TYPE_CONVENTION_FORTRAN_P (gnu_type
)
2161 = (Convention (gnat_entity
) == Convention_Fortran
);
2162 TYPE_PACKED_ARRAY_TYPE_P (gnu_type
)
2163 = Is_Packed_Array_Type (gnat_entity
);
2165 /* If our size depends on a placeholder and the maximum size doesn't
2166 overflow, use it. */
2167 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
))
2168 && !(TREE_CODE (gnu_max_size
) == INTEGER_CST
2169 && TREE_OVERFLOW (gnu_max_size
))
2170 && !(TREE_CODE (gnu_max_size_unit
) == INTEGER_CST
2171 && TREE_OVERFLOW (gnu_max_size_unit
))
2174 TYPE_SIZE (gnu_type
) = size_binop (MIN_EXPR
, gnu_max_size
,
2175 TYPE_SIZE (gnu_type
));
2176 TYPE_SIZE_UNIT (gnu_type
)
2177 = size_binop (MIN_EXPR
, gnu_max_size_unit
,
2178 TYPE_SIZE_UNIT (gnu_type
));
2181 /* Set our alias set to that of our base type. This gives all
2182 array subtypes the same alias set. */
2183 copy_alias_set (gnu_type
, gnu_base_type
);
2186 /* If this is a packed type, make this type the same as the packed
2187 array type, but do some adjusting in the type first. */
2189 if (Present (Packed_Array_Type (gnat_entity
)))
2191 Entity_Id gnat_index
;
2192 tree gnu_inner_type
;
2194 /* First finish the type we had been making so that we output
2195 debugging information for it */
2197 = build_qualified_type (gnu_type
,
2198 (TYPE_QUALS (gnu_type
)
2199 | (TYPE_QUAL_VOLATILE
2200 * Treat_As_Volatile (gnat_entity
))));
2201 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2202 !Comes_From_Source (gnat_entity
),
2203 debug_info_p
, gnat_entity
);
2204 if (!Comes_From_Source (gnat_entity
))
2205 DECL_ARTIFICIAL (gnu_decl
) = 1;
2207 /* Save it as our equivalent in case the call below elaborates
2209 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2211 gnu_decl
= gnat_to_gnu_entity (Packed_Array_Type (gnat_entity
),
2213 this_made_decl
= true;
2214 gnu_inner_type
= gnu_type
= TREE_TYPE (gnu_decl
);
2215 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
2217 while (TREE_CODE (gnu_inner_type
) == RECORD_TYPE
2218 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type
)
2219 || TYPE_IS_PADDING_P (gnu_inner_type
)))
2220 gnu_inner_type
= TREE_TYPE (TYPE_FIELDS (gnu_inner_type
));
2222 /* We need to point the type we just made to our index type so
2223 the actual bounds can be put into a template. */
2225 if ((TREE_CODE (gnu_inner_type
) == ARRAY_TYPE
2226 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type
))
2227 || (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
2228 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
)))
2230 if (TREE_CODE (gnu_inner_type
) == INTEGER_TYPE
)
2232 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2233 If it is, we need to make another type. */
2234 if (TYPE_MODULAR_P (gnu_inner_type
))
2238 gnu_subtype
= make_node (INTEGER_TYPE
);
2240 TREE_TYPE (gnu_subtype
) = gnu_inner_type
;
2241 TYPE_MIN_VALUE (gnu_subtype
)
2242 = TYPE_MIN_VALUE (gnu_inner_type
);
2243 TYPE_MAX_VALUE (gnu_subtype
)
2244 = TYPE_MAX_VALUE (gnu_inner_type
);
2245 TYPE_PRECISION (gnu_subtype
)
2246 = TYPE_PRECISION (gnu_inner_type
);
2247 TYPE_UNSIGNED (gnu_subtype
)
2248 = TYPE_UNSIGNED (gnu_inner_type
);
2249 TYPE_EXTRA_SUBTYPE_P (gnu_subtype
) = 1;
2250 layout_type (gnu_subtype
);
2252 gnu_inner_type
= gnu_subtype
;
2255 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type
) = 1;
2258 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type
, NULL_TREE
);
2260 for (gnat_index
= First_Index (gnat_entity
);
2261 Present (gnat_index
); gnat_index
= Next_Index (gnat_index
))
2262 SET_TYPE_ACTUAL_BOUNDS
2264 tree_cons (NULL_TREE
,
2265 get_unpadded_type (Etype (gnat_index
)),
2266 TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2268 if (Convention (gnat_entity
) != Convention_Fortran
)
2269 SET_TYPE_ACTUAL_BOUNDS
2271 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type
)));
2273 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2274 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
2275 TREE_TYPE (TYPE_FIELDS (gnu_type
)) = gnu_inner_type
;
2279 /* Abort if packed array with no packed array type field set. */
2281 gcc_assert (!Is_Packed (gnat_entity
));
2285 case E_String_Literal_Subtype
:
2286 /* Create the type for a string literal. */
2288 Entity_Id gnat_full_type
2289 = (IN (Ekind (Etype (gnat_entity
)), Private_Kind
)
2290 && Present (Full_View (Etype (gnat_entity
)))
2291 ? Full_View (Etype (gnat_entity
)) : Etype (gnat_entity
));
2292 tree gnu_string_type
= get_unpadded_type (gnat_full_type
);
2293 tree gnu_string_array_type
2294 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type
))));
2295 tree gnu_string_index_type
2296 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2297 (TYPE_DOMAIN (gnu_string_array_type
))));
2298 tree gnu_lower_bound
2299 = convert (gnu_string_index_type
,
2300 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity
)));
2301 int length
= UI_To_Int (String_Literal_Length (gnat_entity
));
2302 tree gnu_length
= ssize_int (length
- 1);
2303 tree gnu_upper_bound
2304 = build_binary_op (PLUS_EXPR
, gnu_string_index_type
,
2306 convert (gnu_string_index_type
, gnu_length
));
2308 = build_range_type (gnu_string_index_type
,
2309 gnu_lower_bound
, gnu_upper_bound
);
2311 = create_index_type (convert (sizetype
,
2312 TYPE_MIN_VALUE (gnu_range_type
)),
2314 TYPE_MAX_VALUE (gnu_range_type
)),
2318 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity
)),
2320 copy_alias_set (gnu_type
, gnu_string_type
);
2324 /* Record Types and Subtypes
2326 The following fields are defined on record types:
2328 Has_Discriminants True if the record has discriminants
2329 First_Discriminant Points to head of list of discriminants
2330 First_Entity Points to head of list of fields
2331 Is_Tagged_Type True if the record is tagged
2333 Implementation of Ada records and discriminated records:
2335 A record type definition is transformed into the equivalent of a C
2336 struct definition. The fields that are the discriminants which are
2337 found in the Full_Type_Declaration node and the elements of the
2338 Component_List found in the Record_Type_Definition node. The
2339 Component_List can be a recursive structure since each Variant of
2340 the Variant_Part of the Component_List has a Component_List.
2342 Processing of a record type definition comprises starting the list of
2343 field declarations here from the discriminants and the calling the
2344 function components_to_record to add the rest of the fields from the
2345 component list and return the gnu type node. The function
2346 components_to_record will call itself recursively as it traverses
2350 if (Has_Complex_Representation (gnat_entity
))
2353 = build_complex_type
2355 (Etype (Defining_Entity
2356 (First (Component_Items
2359 (Declaration_Node (gnat_entity
)))))))));
2365 Node_Id full_definition
= Declaration_Node (gnat_entity
);
2366 Node_Id record_definition
= Type_Definition (full_definition
);
2367 Entity_Id gnat_field
;
2369 tree gnu_field_list
= NULL_TREE
;
2370 tree gnu_get_parent
;
2371 int packed
= (Is_Packed (gnat_entity
) ? 1
2372 : (Component_Alignment (gnat_entity
)
2373 == Calign_Storage_Unit
) ? -1
2375 bool has_rep
= Has_Specified_Layout (gnat_entity
);
2376 bool all_rep
= has_rep
;
2378 = (Is_Tagged_Type (gnat_entity
)
2379 && Nkind (record_definition
) == N_Derived_Type_Definition
);
2381 /* See if all fields have a rep clause. Stop when we find one
2383 for (gnat_field
= First_Entity (gnat_entity
);
2384 Present (gnat_field
) && all_rep
;
2385 gnat_field
= Next_Entity (gnat_field
))
2386 if ((Ekind (gnat_field
) == E_Component
2387 || Ekind (gnat_field
) == E_Discriminant
)
2388 && No (Component_Clause (gnat_field
)))
2391 /* If this is a record extension, go a level further to find the
2392 record definition. Also, verify we have a Parent_Subtype. */
2395 if (!type_annotate_only
2396 || Present (Record_Extension_Part (record_definition
)))
2397 record_definition
= Record_Extension_Part (record_definition
);
2399 gcc_assert (type_annotate_only
2400 || Present (Parent_Subtype (gnat_entity
)));
2403 /* Make a node for the record. If we are not defining the record,
2404 suppress expanding incomplete types. */
2405 gnu_type
= make_node (tree_code_for_record_type (gnat_entity
));
2406 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2407 /* ??? We should have create_type_decl like in the E_Record_Subtype
2408 case below. Unfortunately this would cause GNU_TYPE to be marked
2409 as visited, thus precluding the subtrees of the type that will be
2410 built below from being marked as visited when the real TYPE_DECL
2411 is eventually created. A solution could be to devise a special
2412 version of the function under the name create_type_stub_decl. */
2413 TYPE_STUB_DECL (gnu_type
)
2414 = build_decl (TYPE_DECL
, NULL_TREE
, gnu_type
);
2415 TYPE_ALIGN (gnu_type
) = 0;
2416 TYPE_PACKED (gnu_type
) = packed
|| has_rep
;
2419 defer_incomplete_level
++, this_deferred
= true;
2421 /* If both a size and rep clause was specified, put the size in
2422 the record type now so that it can get the proper mode. */
2423 if (has_rep
&& Known_Esize (gnat_entity
))
2424 TYPE_SIZE (gnu_type
) = UI_To_gnu (Esize (gnat_entity
), sizetype
);
2426 /* Always set the alignment here so that it can be used to
2427 set the mode, if it is making the alignment stricter. If
2428 it is invalid, it will be checked again below. If this is to
2429 be Atomic, choose a default alignment of a word unless we know
2430 the size and it's smaller. */
2431 if (Known_Alignment (gnat_entity
))
2432 TYPE_ALIGN (gnu_type
)
2433 = validate_alignment (Alignment (gnat_entity
), gnat_entity
, 0);
2434 else if (Is_Atomic (gnat_entity
))
2435 TYPE_ALIGN (gnu_type
)
2436 = (esize
>= BITS_PER_WORD
? BITS_PER_WORD
2437 : 1 << (floor_log2 (esize
- 1) + 1));
2439 /* If we have a Parent_Subtype, make a field for the parent. If
2440 this record has rep clauses, force the position to zero. */
2441 if (Present (Parent_Subtype (gnat_entity
)))
2443 Entity_Id gnat_parent
= Parent_Subtype (gnat_entity
);
2446 /* A major complexity here is that the parent subtype will
2447 reference our discriminants in its Discriminant_Constraint
2448 list. But those must reference the parent component of this
2449 record which is of the parent subtype we have not built yet!
2450 To break the circle we first build a dummy COMPONENT_REF which
2451 represents the "get to the parent" operation and initialize
2452 each of those discriminants to a COMPONENT_REF of the above
2453 dummy parent referencing the corresponding discriminant of the
2454 base type of the parent subtype. */
2455 gnu_get_parent
= build3 (COMPONENT_REF
, void_type_node
,
2456 build0 (PLACEHOLDER_EXPR
, gnu_type
),
2457 build_decl (FIELD_DECL
, NULL_TREE
,
2461 if (Has_Discriminants (gnat_entity
))
2462 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2463 Present (gnat_field
);
2464 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2465 if (Present (Corresponding_Discriminant (gnat_field
)))
2468 build3 (COMPONENT_REF
,
2469 get_unpadded_type (Etype (gnat_field
)),
2471 gnat_to_gnu_field_decl (Corresponding_Discriminant
2476 /* Then we build the parent subtype. */
2477 gnu_parent
= gnat_to_gnu_type (gnat_parent
);
2479 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2480 initially built. The discriminants must reference the fields
2481 of the parent subtype and not those of its base type for the
2482 placeholder machinery to properly work. */
2483 if (Has_Discriminants (gnat_entity
))
2484 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2485 Present (gnat_field
);
2486 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2487 if (Present (Corresponding_Discriminant (gnat_field
)))
2489 Entity_Id field
= Empty
;
2490 for (field
= First_Stored_Discriminant (gnat_parent
);
2492 field
= Next_Stored_Discriminant (field
))
2493 if (same_discriminant_p (gnat_field
, field
))
2495 gcc_assert (Present (field
));
2496 TREE_OPERAND (get_gnu_tree (gnat_field
), 1)
2497 = gnat_to_gnu_field_decl (field
);
2500 /* The "get to the parent" COMPONENT_REF must be given its
2502 TREE_TYPE (gnu_get_parent
) = gnu_parent
;
2504 /* ...and reference the _parent field of this record. */
2506 = create_field_decl (get_identifier
2507 (Get_Name_String (Name_uParent
)),
2508 gnu_parent
, gnu_type
, 0,
2509 has_rep
? TYPE_SIZE (gnu_parent
) : 0,
2510 has_rep
? bitsize_zero_node
: 0, 1);
2511 DECL_INTERNAL_P (gnu_field_list
) = 1;
2512 TREE_OPERAND (gnu_get_parent
, 1) = gnu_field_list
;
2515 /* Make the fields for the discriminants and put them into the record
2516 unless it's an Unchecked_Union. */
2517 if (Has_Discriminants (gnat_entity
))
2518 for (gnat_field
= First_Stored_Discriminant (gnat_entity
);
2519 Present (gnat_field
);
2520 gnat_field
= Next_Stored_Discriminant (gnat_field
))
2522 /* If this is a record extension and this discriminant
2523 is the renaming of another discriminant, we've already
2524 handled the discriminant above. */
2525 if (Present (Parent_Subtype (gnat_entity
))
2526 && Present (Corresponding_Discriminant (gnat_field
)))
2530 = gnat_to_gnu_field (gnat_field
, gnu_type
, packed
, definition
);
2532 /* Make an expression using a PLACEHOLDER_EXPR from the
2533 FIELD_DECL node just created and link that with the
2534 corresponding GNAT defining identifier. Then add to the
2536 save_gnu_tree (gnat_field
,
2537 build3 (COMPONENT_REF
, TREE_TYPE (gnu_field
),
2538 build0 (PLACEHOLDER_EXPR
,
2539 DECL_CONTEXT (gnu_field
)),
2540 gnu_field
, NULL_TREE
),
2543 if (!Is_Unchecked_Union (gnat_entity
))
2545 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2546 gnu_field_list
= gnu_field
;
2550 /* Put the discriminants into the record (backwards), so we can
2551 know the appropriate discriminant to use for the names of the
2553 TYPE_FIELDS (gnu_type
) = gnu_field_list
;
2555 /* Add the listed fields into the record and finish up. */
2556 components_to_record (gnu_type
, Component_List (record_definition
),
2557 gnu_field_list
, packed
, definition
, NULL
,
2558 false, all_rep
, this_deferred
,
2559 Is_Unchecked_Union (gnat_entity
));
2563 debug_deferred
= true;
2564 defer_debug_level
++;
2566 defer_debug_incomplete_list
2567 = tree_cons (NULL_TREE
, gnu_type
,
2568 defer_debug_incomplete_list
);
2571 /* We used to remove the associations of the discriminants and
2572 _Parent for validity checking, but we may need them if there's
2573 Freeze_Node for a subtype used in this record. */
2575 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2576 TYPE_BY_REFERENCE_P (gnu_type
) = Is_By_Reference_Type (gnat_entity
);
2578 /* If it is a tagged record force the type to BLKmode to insure
2579 that these objects will always be placed in memory. Do the
2580 same thing for limited record types. */
2581 if (Is_Tagged_Type (gnat_entity
) || Is_Limited_Record (gnat_entity
))
2582 TYPE_MODE (gnu_type
) = BLKmode
;
2584 /* If this is a derived type, we must make the alias set of this type
2585 the same as that of the type we are derived from. We assume here
2586 that the other type is already frozen. */
2587 if (Etype (gnat_entity
) != gnat_entity
2588 && !(Is_Private_Type (Etype (gnat_entity
))
2589 && Full_View (Etype (gnat_entity
)) == gnat_entity
))
2590 copy_alias_set (gnu_type
, gnat_to_gnu_type (Etype (gnat_entity
)));
2592 /* Fill in locations of fields. */
2593 annotate_rep (gnat_entity
, gnu_type
);
2595 /* If there are any entities in the chain corresponding to
2596 components that we did not elaborate, ensure we elaborate their
2597 types if they are Itypes. */
2598 for (gnat_temp
= First_Entity (gnat_entity
);
2599 Present (gnat_temp
); gnat_temp
= Next_Entity (gnat_temp
))
2600 if ((Ekind (gnat_temp
) == E_Component
2601 || Ekind (gnat_temp
) == E_Discriminant
)
2602 && Is_Itype (Etype (gnat_temp
))
2603 && !present_gnu_tree (gnat_temp
))
2604 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2608 case E_Class_Wide_Subtype
:
2609 /* If an equivalent type is present, that is what we should use.
2610 Otherwise, fall through to handle this like a record subtype
2611 since it may have constraints. */
2612 if (Present (Equivalent_Type (gnat_entity
)))
2614 gnu_decl
= gnat_to_gnu_entity (Equivalent_Type (gnat_entity
),
2616 maybe_present
= true;
2620 /* ... fall through ... */
2622 case E_Record_Subtype
:
2624 /* If Cloned_Subtype is Present it means this record subtype has
2625 identical layout to that type or subtype and we should use
2626 that GCC type for this one. The front end guarantees that
2627 the component list is shared. */
2628 if (Present (Cloned_Subtype (gnat_entity
)))
2630 gnu_decl
= gnat_to_gnu_entity (Cloned_Subtype (gnat_entity
),
2632 maybe_present
= true;
2635 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2636 changing the type, make a new type with each field having the
2637 type of the field in the new subtype but having the position
2638 computed by transforming every discriminant reference according
2639 to the constraints. We don't see any difference between
2640 private and nonprivate type here since derivations from types should
2641 have been deferred until the completion of the private type. */
2644 Entity_Id gnat_base_type
= Implementation_Base_Type (gnat_entity
);
2649 defer_incomplete_level
++, this_deferred
= true;
2651 /* Get the base type initially for its alignment and sizes. But
2652 if it is a padded type, we do all the other work with the
2654 gnu_type
= gnu_orig_type
= gnu_base_type
2655 = gnat_to_gnu_type (gnat_base_type
);
2657 if (TREE_CODE (gnu_type
) == RECORD_TYPE
2658 && TYPE_IS_PADDING_P (gnu_type
))
2659 gnu_type
= gnu_orig_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
2661 if (present_gnu_tree (gnat_entity
))
2663 maybe_present
= true;
2667 /* When the type has discriminants, and these discriminants
2668 affect the shape of what it built, factor them in.
2670 If we are making a subtype of an Unchecked_Union (must be an
2671 Itype), just return the type.
2673 We can't just use Is_Constrained because private subtypes without
2674 discriminants of full types with discriminants with default
2675 expressions are Is_Constrained but aren't constrained! */
2677 if (IN (Ekind (gnat_base_type
), Record_Kind
)
2678 && !Is_For_Access_Subtype (gnat_entity
)
2679 && !Is_Unchecked_Union (gnat_base_type
)
2680 && Is_Constrained (gnat_entity
)
2681 && Stored_Constraint (gnat_entity
) != No_Elist
2682 && Present (Discriminant_Constraint (gnat_entity
)))
2684 Entity_Id gnat_field
;
2685 tree gnu_field_list
= 0;
2687 = compute_field_positions (gnu_orig_type
, NULL_TREE
,
2688 size_zero_node
, bitsize_zero_node
,
2691 = substitution_list (gnat_entity
, gnat_base_type
, NULL_TREE
,
2695 gnu_type
= make_node (RECORD_TYPE
);
2696 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2697 TYPE_STUB_DECL (gnu_type
)
2698 = create_type_decl (NULL_TREE
, gnu_type
, NULL
, false, false,
2700 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2702 for (gnat_field
= First_Entity (gnat_entity
);
2703 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2704 if ((Ekind (gnat_field
) == E_Component
2705 || Ekind (gnat_field
) == E_Discriminant
)
2706 && (Underlying_Type (Scope (Original_Record_Component
2709 && (No (Corresponding_Discriminant (gnat_field
))
2710 || !Is_Tagged_Type (gnat_base_type
)))
2713 = gnat_to_gnu_field_decl (Original_Record_Component
2716 = TREE_VALUE (purpose_member (gnu_old_field
,
2718 tree gnu_pos
= TREE_PURPOSE (gnu_offset
);
2719 tree gnu_bitpos
= TREE_VALUE (TREE_VALUE (gnu_offset
));
2721 = gnat_to_gnu_type (Etype (gnat_field
));
2722 tree gnu_size
= TYPE_SIZE (gnu_field_type
);
2723 tree gnu_new_pos
= 0;
2724 unsigned int offset_align
2725 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset
)),
2729 /* If there was a component clause, the field types must be
2730 the same for the type and subtype, so copy the data from
2731 the old field to avoid recomputation here. Also if the
2732 field is justified modular and the optimization in
2733 gnat_to_gnu_field was applied. */
2734 if (Present (Component_Clause
2735 (Original_Record_Component (gnat_field
)))
2736 || (TREE_CODE (gnu_field_type
) == RECORD_TYPE
2737 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
2738 && TREE_TYPE (TYPE_FIELDS (gnu_field_type
))
2739 == TREE_TYPE (gnu_old_field
)))
2741 gnu_size
= DECL_SIZE (gnu_old_field
);
2742 gnu_field_type
= TREE_TYPE (gnu_old_field
);
2745 /* If this was a bitfield, get the size from the old field.
2746 Also ensure the type can be placed into a bitfield. */
2747 else if (DECL_BIT_FIELD (gnu_old_field
))
2749 gnu_size
= DECL_SIZE (gnu_old_field
);
2750 if (TYPE_MODE (gnu_field_type
) == BLKmode
2751 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
2752 && host_integerp (TYPE_SIZE (gnu_field_type
), 1))
2753 gnu_field_type
= make_packable_type (gnu_field_type
);
2756 if (CONTAINS_PLACEHOLDER_P (gnu_pos
))
2757 for (gnu_temp
= gnu_subst_list
;
2758 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2759 gnu_pos
= substitute_in_expr (gnu_pos
,
2760 TREE_PURPOSE (gnu_temp
),
2761 TREE_VALUE (gnu_temp
));
2763 /* If the size is now a constant, we can set it as the
2764 size of the field when we make it. Otherwise, we need
2765 to deal with it specially. */
2766 if (TREE_CONSTANT (gnu_pos
))
2767 gnu_new_pos
= bit_from_pos (gnu_pos
, gnu_bitpos
);
2771 (DECL_NAME (gnu_old_field
), gnu_field_type
, gnu_type
,
2772 0, gnu_size
, gnu_new_pos
,
2773 !DECL_NONADDRESSABLE_P (gnu_old_field
));
2775 if (!TREE_CONSTANT (gnu_pos
))
2777 normalize_offset (&gnu_pos
, &gnu_bitpos
, offset_align
);
2778 DECL_FIELD_OFFSET (gnu_field
) = gnu_pos
;
2779 DECL_FIELD_BIT_OFFSET (gnu_field
) = gnu_bitpos
;
2780 SET_DECL_OFFSET_ALIGN (gnu_field
, offset_align
);
2781 DECL_SIZE (gnu_field
) = gnu_size
;
2782 DECL_SIZE_UNIT (gnu_field
)
2783 = convert (sizetype
,
2784 size_binop (CEIL_DIV_EXPR
, gnu_size
,
2785 bitsize_unit_node
));
2786 layout_decl (gnu_field
, DECL_OFFSET_ALIGN (gnu_field
));
2789 DECL_INTERNAL_P (gnu_field
)
2790 = DECL_INTERNAL_P (gnu_old_field
);
2791 SET_DECL_ORIGINAL_FIELD
2792 (gnu_field
, (DECL_ORIGINAL_FIELD (gnu_old_field
)
2793 ? DECL_ORIGINAL_FIELD (gnu_old_field
)
2795 DECL_DISCRIMINANT_NUMBER (gnu_field
)
2796 = DECL_DISCRIMINANT_NUMBER (gnu_old_field
);
2797 TREE_THIS_VOLATILE (gnu_field
)
2798 = TREE_THIS_VOLATILE (gnu_old_field
);
2799 TREE_CHAIN (gnu_field
) = gnu_field_list
;
2800 gnu_field_list
= gnu_field
;
2801 save_gnu_tree (gnat_field
, gnu_field
, false);
2804 /* Now go through the entities again looking for Itypes that
2805 we have not elaborated but should (e.g., Etypes of fields
2806 that have Original_Components). */
2807 for (gnat_field
= First_Entity (gnat_entity
);
2808 Present (gnat_field
); gnat_field
= Next_Entity (gnat_field
))
2809 if ((Ekind (gnat_field
) == E_Discriminant
2810 || Ekind (gnat_field
) == E_Component
)
2811 && !present_gnu_tree (Etype (gnat_field
)))
2812 gnat_to_gnu_entity (Etype (gnat_field
), NULL_TREE
, 0);
2814 finish_record_type (gnu_type
, nreverse (gnu_field_list
),
2817 /* Now set the size, alignment and alias set of the new type to
2818 match that of the old one, doing any substitutions, as
2820 TYPE_ALIGN (gnu_type
) = TYPE_ALIGN (gnu_base_type
);
2821 TYPE_SIZE (gnu_type
) = TYPE_SIZE (gnu_base_type
);
2822 TYPE_SIZE_UNIT (gnu_type
) = TYPE_SIZE_UNIT (gnu_base_type
);
2823 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_ADA_SIZE (gnu_base_type
));
2824 copy_alias_set (gnu_type
, gnu_base_type
);
2826 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
2827 for (gnu_temp
= gnu_subst_list
;
2828 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2829 TYPE_SIZE (gnu_type
)
2830 = substitute_in_expr (TYPE_SIZE (gnu_type
),
2831 TREE_PURPOSE (gnu_temp
),
2832 TREE_VALUE (gnu_temp
));
2834 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type
)))
2835 for (gnu_temp
= gnu_subst_list
;
2836 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2837 TYPE_SIZE_UNIT (gnu_type
)
2838 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type
),
2839 TREE_PURPOSE (gnu_temp
),
2840 TREE_VALUE (gnu_temp
));
2842 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type
)))
2843 for (gnu_temp
= gnu_subst_list
;
2844 gnu_temp
; gnu_temp
= TREE_CHAIN (gnu_temp
))
2846 (gnu_type
, substitute_in_expr (TYPE_ADA_SIZE (gnu_type
),
2847 TREE_PURPOSE (gnu_temp
),
2848 TREE_VALUE (gnu_temp
)));
2850 /* Recompute the mode of this record type now that we know its
2852 compute_record_mode (gnu_type
);
2854 /* Reapply variable_size since we have changed the sizes. */
2855 TYPE_SIZE (gnu_type
) = variable_size (TYPE_SIZE (gnu_type
));
2856 TYPE_SIZE_UNIT (gnu_type
)
2857 = variable_size (TYPE_SIZE_UNIT (gnu_type
));
2859 /* Fill in locations of fields. */
2860 annotate_rep (gnat_entity
, gnu_type
);
2863 /* If we've made a new type, record it and make an XVS type to show
2864 what this is a subtype of. Some debuggers require the XVS
2865 type to be output first, so do it in that order. */
2866 if (gnu_type
!= gnu_orig_type
)
2870 tree gnu_subtype_marker
= make_node (RECORD_TYPE
);
2871 tree gnu_orig_name
= TYPE_NAME (gnu_orig_type
);
2873 if (TREE_CODE (gnu_orig_name
) == TYPE_DECL
)
2874 gnu_orig_name
= DECL_NAME (gnu_orig_name
);
2876 TYPE_NAME (gnu_subtype_marker
)
2877 = create_concat_name (gnat_entity
, "XVS");
2878 finish_record_type (gnu_subtype_marker
,
2879 create_field_decl (gnu_orig_name
,
2887 TYPE_VOLATILE (gnu_type
) = Treat_As_Volatile (gnat_entity
);
2888 TYPE_NAME (gnu_type
) = gnu_entity_id
;
2889 TYPE_STUB_DECL (gnu_type
)
2890 = create_type_decl (TYPE_NAME (gnu_type
), gnu_type
,
2891 NULL
, true, debug_info_p
, gnat_entity
);
2894 /* Otherwise, go down all the components in the new type and
2895 make them equivalent to those in the base type. */
2897 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
2898 gnat_temp
= Next_Entity (gnat_temp
))
2899 if ((Ekind (gnat_temp
) == E_Discriminant
2900 && !Is_Unchecked_Union (gnat_base_type
))
2901 || Ekind (gnat_temp
) == E_Component
)
2902 save_gnu_tree (gnat_temp
,
2903 gnat_to_gnu_field_decl
2904 (Original_Record_Component (gnat_temp
)), false);
2908 case E_Access_Subprogram_Type
:
2909 case E_Anonymous_Access_Subprogram_Type
:
2910 /* If we are not defining this entity, and we have incomplete
2911 entities being processed above us, make a dummy type and
2912 fill it in later. */
2913 if (!definition
&& defer_incomplete_level
!= 0)
2915 struct incomplete
*p
2916 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
2919 = build_pointer_type
2920 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
2921 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
2922 !Comes_From_Source (gnat_entity
),
2923 debug_info_p
, gnat_entity
);
2924 save_gnu_tree (gnat_entity
, gnu_decl
, false);
2925 this_made_decl
= saved
= true;
2927 p
->old_type
= TREE_TYPE (gnu_type
);
2928 p
->full_type
= Directly_Designated_Type (gnat_entity
);
2929 p
->next
= defer_incomplete_list
;
2930 defer_incomplete_list
= p
;
2934 /* ... fall through ... */
2936 case E_Allocator_Type
:
2938 case E_Access_Attribute_Type
:
2939 case E_Anonymous_Access_Type
:
2940 case E_General_Access_Type
:
2942 Entity_Id gnat_desig_type
= Directly_Designated_Type (gnat_entity
);
2943 /* Get the "full view" of this entity. If this is an incomplete
2944 entity from a limited with, treat its non-limited view as the
2945 full view. Otherwise, if this is an incomplete or private
2946 type, use the full view. */
2947 Entity_Id gnat_desig_full
2948 = (IN (Ekind (gnat_desig_type
), Incomplete_Kind
)
2949 && From_With_Type (gnat_desig_type
))
2950 ? Non_Limited_View (gnat_desig_type
)
2951 : IN (Ekind (gnat_desig_type
), Incomplete_Or_Private_Kind
)
2952 ? Full_View (gnat_desig_type
)
2954 /* We want to know if we'll be seeing the freeze node for any
2955 incomplete type we may be pointing to. */
2957 = (Present (gnat_desig_full
)
2958 ? In_Extended_Main_Code_Unit (gnat_desig_full
)
2959 : In_Extended_Main_Code_Unit (gnat_desig_type
));
2960 bool got_fat_p
= false;
2961 bool made_dummy
= false;
2962 tree gnu_desig_type
= NULL_TREE
;
2963 enum machine_mode p_mode
= mode_for_size (esize
, MODE_INT
, 0);
2965 if (!targetm
.valid_pointer_mode (p_mode
))
2968 if (No (gnat_desig_full
)
2969 && (Ekind (gnat_desig_type
) == E_Class_Wide_Type
2970 || (Ekind (gnat_desig_type
) == E_Class_Wide_Subtype
2971 && Present (Equivalent_Type (gnat_desig_type
)))))
2973 if (Present (Equivalent_Type (gnat_desig_type
)))
2975 gnat_desig_full
= Equivalent_Type (gnat_desig_type
);
2976 if (IN (Ekind (gnat_desig_full
), Incomplete_Or_Private_Kind
))
2977 gnat_desig_full
= Full_View (gnat_desig_full
);
2979 else if (IN (Ekind (Root_Type (gnat_desig_type
)),
2980 Incomplete_Or_Private_Kind
))
2981 gnat_desig_full
= Full_View (Root_Type (gnat_desig_type
));
2984 if (Present (gnat_desig_full
) && Is_Concurrent_Type (gnat_desig_full
))
2985 gnat_desig_full
= Corresponding_Record_Type (gnat_desig_full
);
2987 /* If either the designated type or its full view is an
2988 unconstrained array subtype, replace it with the type it's a
2989 subtype of. This avoids problems with multiple copies of
2990 unconstrained array types. */
2991 if (Ekind (gnat_desig_type
) == E_Array_Subtype
2992 && !Is_Constrained (gnat_desig_type
))
2993 gnat_desig_type
= Etype (gnat_desig_type
);
2994 if (Present (gnat_desig_full
)
2995 && Ekind (gnat_desig_full
) == E_Array_Subtype
2996 && !Is_Constrained (gnat_desig_full
))
2997 gnat_desig_full
= Etype (gnat_desig_full
);
2999 /* If the designated type is a subtype of an incomplete record type,
3000 use the parent type to avoid order of elaboration issues. This
3001 can lose some code efficiency, but there is no alternative. */
3002 if (Present (gnat_desig_full
)
3003 && Ekind (gnat_desig_full
) == E_Record_Subtype
3004 && Ekind (Etype (gnat_desig_full
)) == E_Record_Type
)
3005 gnat_desig_full
= Etype (gnat_desig_full
);
3007 /* If we are pointing to an incomplete type whose completion is an
3008 unconstrained array, make a fat pointer type instead of a pointer
3009 to VOID. The two types in our fields will be pointers to VOID and
3010 will be replaced in update_pointer_to. Similarly, if the type
3011 itself is a dummy type or an unconstrained array. Also make
3012 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
3015 if ((Present (gnat_desig_full
)
3016 && Is_Array_Type (gnat_desig_full
)
3017 && !Is_Constrained (gnat_desig_full
))
3018 || (present_gnu_tree (gnat_desig_type
)
3019 && TYPE_IS_DUMMY_P (TREE_TYPE
3020 (get_gnu_tree (gnat_desig_type
)))
3021 && Is_Array_Type (gnat_desig_type
)
3022 && !Is_Constrained (gnat_desig_type
))
3023 || (present_gnu_tree (gnat_desig_type
)
3024 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type
)))
3025 == UNCONSTRAINED_ARRAY_TYPE
)
3026 && !(TYPE_POINTER_TO (TREE_TYPE
3027 (get_gnu_tree (gnat_desig_type
)))))
3028 || (No (gnat_desig_full
) && !in_main_unit
3029 && defer_incomplete_level
3030 && !present_gnu_tree (gnat_desig_type
)
3031 && Is_Array_Type (gnat_desig_type
)
3032 && ! Is_Constrained (gnat_desig_type
))
3033 || (in_main_unit
&& From_With_Type (gnat_entity
)
3034 && (Present (gnat_desig_full
)
3035 ? Present (Freeze_Node (gnat_desig_full
))
3036 : Present (Freeze_Node (gnat_desig_type
)))
3037 && Is_Array_Type (gnat_desig_type
)
3038 && !Is_Constrained (gnat_desig_type
)))
3041 = (present_gnu_tree (gnat_desig_type
)
3042 ? gnat_to_gnu_type (gnat_desig_type
)
3043 : make_dummy_type (gnat_desig_type
));
3046 /* Show the dummy we get will be a fat pointer. */
3047 got_fat_p
= made_dummy
= true;
3049 /* If the call above got something that has a pointer, that
3050 pointer is our type. This could have happened either
3051 because the type was elaborated or because somebody
3052 else executed the code below. */
3053 gnu_type
= TYPE_POINTER_TO (gnu_old
);
3056 gnu_type
= make_node (RECORD_TYPE
);
3057 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type
, gnu_old
);
3058 TYPE_POINTER_TO (gnu_old
) = gnu_type
;
3060 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3062 = chainon (chainon (NULL_TREE
,
3064 (get_identifier ("P_ARRAY"),
3065 ptr_void_type_node
, gnu_type
,
3067 create_field_decl (get_identifier ("P_BOUNDS"),
3069 gnu_type
, 0, 0, 0, 0));
3071 /* Make sure we can place this into a register. */
3072 TYPE_ALIGN (gnu_type
)
3073 = MIN (BIGGEST_ALIGNMENT
, 2 * POINTER_SIZE
);
3074 TYPE_IS_FAT_POINTER_P (gnu_type
) = 1;
3075 finish_record_type (gnu_type
, fields
, false, true);
3077 TYPE_OBJECT_RECORD_TYPE (gnu_old
) = make_node (RECORD_TYPE
);
3078 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old
))
3079 = concat_id_with_name (get_entity_name (gnat_desig_type
),
3081 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old
)) = 1;
3085 /* If we already know what the full type is, use it. */
3086 else if (Present (gnat_desig_full
)
3087 && present_gnu_tree (gnat_desig_full
))
3088 gnu_desig_type
= TREE_TYPE (get_gnu_tree (gnat_desig_full
));
3090 /* Get the type of the thing we are to point to and build a pointer
3091 to it. If it is a reference to an incomplete or private type with a
3092 full view that is a record, make a dummy type node and get the
3093 actual type later when we have verified it is safe. */
3094 else if (!in_main_unit
3095 && !present_gnu_tree (gnat_desig_type
)
3096 && Present (gnat_desig_full
)
3097 && !present_gnu_tree (gnat_desig_full
)
3098 && Is_Record_Type (gnat_desig_full
))
3100 gnu_desig_type
= make_dummy_type (gnat_desig_type
);
3104 /* Likewise if we are pointing to a record or array and we are to defer
3105 elaborating incomplete types. We do this since this access type
3106 may be the full view of some private type. Note that the
3107 unconstrained array case is handled above. */
3108 else if ((!in_main_unit
|| imported_p
) && defer_incomplete_level
!= 0
3109 && !present_gnu_tree (gnat_desig_type
)
3110 && ((Is_Record_Type (gnat_desig_type
)
3111 || Is_Array_Type (gnat_desig_type
))
3112 || (Present (gnat_desig_full
)
3113 && (Is_Record_Type (gnat_desig_full
)
3114 || Is_Array_Type (gnat_desig_full
)))))
3116 gnu_desig_type
= make_dummy_type (gnat_desig_type
);
3120 /* If this is a reference from a limited_with type back to our
3121 main unit and there's a Freeze_Node for it, either we have
3122 already processed the declaration and made the dummy type,
3123 in which case we just reuse the latter, or we have not yet,
3124 in which case we make the dummy type and it will be reused
3125 when the declaration is processed. In both cases, the pointer
3126 eventually created below will be automatically adjusted when
3127 the Freeze_Node is processed. Note that the unconstrained
3128 array case is handled above. */
3129 else if (in_main_unit
&& From_With_Type (gnat_entity
)
3130 && (Present (gnat_desig_full
)
3131 ? Present (Freeze_Node (gnat_desig_full
))
3132 : Present (Freeze_Node (gnat_desig_type
))))
3134 gnu_desig_type
= make_dummy_type (gnat_desig_type
);
3138 else if (gnat_desig_type
== gnat_entity
)
3141 = build_pointer_type_for_mode (make_node (VOID_TYPE
),
3143 No_Strict_Aliasing (gnat_entity
));
3144 TREE_TYPE (gnu_type
) = TYPE_POINTER_TO (gnu_type
) = gnu_type
;
3148 gnu_desig_type
= gnat_to_gnu_type (gnat_desig_type
);
3150 /* It is possible that the above call to gnat_to_gnu_type resolved our
3151 type. If so, just return it. */
3152 if (present_gnu_tree (gnat_entity
))
3154 maybe_present
= true;
3158 /* If we have a GCC type for the designated type, possibly modify it
3159 if we are pointing only to constant objects and then make a pointer
3160 to it. Don't do this for unconstrained arrays. */
3161 if (!gnu_type
&& gnu_desig_type
)
3163 if (Is_Access_Constant (gnat_entity
)
3164 && TREE_CODE (gnu_desig_type
) != UNCONSTRAINED_ARRAY_TYPE
)
3167 = build_qualified_type
3169 TYPE_QUALS (gnu_desig_type
) | TYPE_QUAL_CONST
);
3171 /* Some extra processing is required if we are building a
3172 pointer to an incomplete type (in the GCC sense). We might
3173 have such a type if we just made a dummy, or directly out
3174 of the call to gnat_to_gnu_type above if we are processing
3175 an access type for a record component designating the
3176 record type itself. */
3177 if (TYPE_MODE (gnu_desig_type
) == VOIDmode
)
3179 /* We must ensure that the pointer to variant we make will
3180 be processed by update_pointer_to when the initial type
3181 is completed. Pretend we made a dummy and let further
3182 processing act as usual. */
3185 /* We must ensure that update_pointer_to will not retrieve
3186 the dummy variant when building a properly qualified
3187 version of the complete type. We take advantage of the
3188 fact that get_qualified_type is requiring TYPE_NAMEs to
3189 match to influence build_qualified_type and then also
3190 update_pointer_to here. */
3191 TYPE_NAME (gnu_desig_type
)
3192 = create_concat_name (gnat_desig_type
, "INCOMPLETE_CST");
3197 = build_pointer_type_for_mode (gnu_desig_type
, p_mode
,
3198 No_Strict_Aliasing (gnat_entity
));
3201 /* If we are not defining this object and we made a dummy pointer,
3202 save our current definition, evaluate the actual type, and replace
3203 the tentative type we made with the actual one. If we are to defer
3204 actually looking up the actual type, make an entry in the
3207 if (!in_main_unit
&& made_dummy
)
3210 = TYPE_FAT_POINTER_P (gnu_type
)
3211 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type
) : TREE_TYPE (gnu_type
);
3213 if (esize
== POINTER_SIZE
3214 && (got_fat_p
|| TYPE_FAT_POINTER_P (gnu_type
)))
3216 = build_pointer_type
3217 (TYPE_OBJECT_RECORD_TYPE
3218 (TYPE_UNCONSTRAINED_ARRAY (gnu_type
)));
3220 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3221 !Comes_From_Source (gnat_entity
),
3222 debug_info_p
, gnat_entity
);
3223 save_gnu_tree (gnat_entity
, gnu_decl
, false);
3224 this_made_decl
= saved
= true;
3226 if (defer_incomplete_level
== 0)
3227 /* Note that the call to gnat_to_gnu_type here might have
3228 updated gnu_old_type directly, in which case it is not a
3229 dummy type any more when we get into update_pointer_to.
3231 This may happen for instance when the designated type is a
3232 record type, because their elaboration starts with an
3233 initial node from make_dummy_type, which may yield the same
3234 node as the one we got.
3236 Besides, variants of this non-dummy type might have been
3237 created along the way. update_pointer_to is expected to
3238 properly take care of those situations. */
3239 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type
),
3240 gnat_to_gnu_type (gnat_desig_type
));
3243 struct incomplete
*p
3244 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3246 p
->old_type
= gnu_old_type
;
3247 p
->full_type
= gnat_desig_type
;
3248 p
->next
= defer_incomplete_list
;
3249 defer_incomplete_list
= p
;
3255 case E_Access_Protected_Subprogram_Type
:
3256 case E_Anonymous_Access_Protected_Subprogram_Type
:
3257 if (type_annotate_only
&& No (Equivalent_Type (gnat_entity
)))
3258 gnu_type
= build_pointer_type (void_type_node
);
3261 /* The runtime representation is the equivalent type. */
3262 gnu_type
= gnat_to_gnu_type (Equivalent_Type (gnat_entity
));
3266 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3267 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3268 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
)))
3269 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity
))))
3270 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3275 case E_Access_Subtype
:
3277 /* We treat this as identical to its base type; any constraint is
3278 meaningful only to the front end.
3280 The designated type must be elaborated as well, if it does
3281 not have its own freeze node. Designated (sub)types created
3282 for constrained components of records with discriminants are
3283 not frozen by the front end and thus not elaborated by gigi,
3284 because their use may appear before the base type is frozen,
3285 and because it is not clear that they are needed anywhere in
3286 Gigi. With the current model, there is no correct place where
3287 they could be elaborated. */
3289 gnu_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3290 if (Is_Itype (Directly_Designated_Type (gnat_entity
))
3291 && !present_gnu_tree (Directly_Designated_Type (gnat_entity
))
3292 && Is_Frozen (Directly_Designated_Type (gnat_entity
))
3293 && No (Freeze_Node (Directly_Designated_Type (gnat_entity
))))
3295 /* If we are not defining this entity, and we have incomplete
3296 entities being processed above us, make a dummy type and
3297 elaborate it later. */
3298 if (!definition
&& defer_incomplete_level
!= 0)
3300 struct incomplete
*p
3301 = (struct incomplete
*) xmalloc (sizeof (struct incomplete
));
3303 = build_pointer_type
3304 (make_dummy_type (Directly_Designated_Type (gnat_entity
)));
3306 p
->old_type
= TREE_TYPE (gnu_ptr_type
);
3307 p
->full_type
= Directly_Designated_Type (gnat_entity
);
3308 p
->next
= defer_incomplete_list
;
3309 defer_incomplete_list
= p
;
3311 else if (IN (Ekind (Base_Type
3312 (Directly_Designated_Type (gnat_entity
))),
3313 Incomplete_Or_Private_Kind
))
3316 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity
),
3320 maybe_present
= true;
3323 /* Subprogram Entities
3325 The following access functions are defined for subprograms (functions
3328 First_Formal The first formal parameter.
3329 Is_Imported Indicates that the subprogram has appeared in
3330 an INTERFACE or IMPORT pragma. For now we
3331 assume that the external language is C.
3332 Is_Inlined True if the subprogram is to be inlined.
3334 In addition for function subprograms we have:
3336 Etype Return type of the function.
3338 Each parameter is first checked by calling must_pass_by_ref on its
3339 type to determine if it is passed by reference. For parameters which
3340 are copied in, if they are Ada IN OUT or OUT parameters, their return
3341 value becomes part of a record which becomes the return type of the
3342 function (C function - note that this applies only to Ada procedures
3343 so there is no Ada return type). Additional code to store back the
3344 parameters will be generated on the caller side. This transformation
3345 is done here, not in the front-end.
3347 The intended result of the transformation can be seen from the
3348 equivalent source rewritings that follow:
3350 struct temp {int a,b};
3351 procedure P (A,B: IN OUT ...) is temp P (int A,B) {
3353 end P; return {A,B};
3363 For subprogram types we need to perform mainly the same conversions to
3364 GCC form that are needed for procedures and function declarations. The
3365 only difference is that at the end, we make a type declaration instead
3366 of a function declaration. */
3368 case E_Subprogram_Type
:
3372 /* The first GCC parameter declaration (a PARM_DECL node). The
3373 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3374 actually is the head of this parameter list. */
3375 tree gnu_param_list
= NULL_TREE
;
3376 /* The type returned by a function. If the subprogram is a procedure
3377 this type should be void_type_node. */
3378 tree gnu_return_type
= void_type_node
;
3379 /* List of fields in return type of procedure with copy in copy out
3381 tree gnu_field_list
= NULL_TREE
;
3382 /* Non-null for subprograms containing parameters passed by copy in
3383 copy out (Ada IN OUT or OUT parameters not passed by reference),
3384 in which case it is the list of nodes used to specify the values of
3385 the in out/out parameters that are returned as a record upon
3386 procedure return. The TREE_PURPOSE of an element of this list is
3387 a field of the record and the TREE_VALUE is the PARM_DECL
3388 corresponding to that field. This list will be saved in the
3389 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3390 tree gnu_return_list
= NULL_TREE
;
3391 /* If an import pragma asks to map this subprogram to a GCC builtin,
3392 this is the builtin DECL node. */
3393 tree gnu_builtin_decl
= NULL_TREE
;
3394 Entity_Id gnat_param
;
3395 bool inline_flag
= Is_Inlined (gnat_entity
);
3396 bool public_flag
= Is_Public (gnat_entity
);
3398 = (Is_Public (gnat_entity
) && !definition
) || imported_p
;
3399 bool pure_flag
= Is_Pure (gnat_entity
);
3400 bool volatile_flag
= No_Return (gnat_entity
);
3401 bool returns_by_ref
= false;
3402 bool returns_unconstrained
= false;
3403 bool returns_by_target_ptr
= false;
3404 tree gnu_ext_name
= create_concat_name (gnat_entity
, 0);
3405 bool has_copy_in_out
= false;
3408 if (kind
== E_Subprogram_Type
&& !definition
)
3409 /* A parameter may refer to this type, so defer completion
3410 of any incomplete types. */
3411 defer_incomplete_level
++, this_deferred
= true;
3413 /* If the subprogram has an alias, it is probably inherited, so
3414 we can use the original one. If the original "subprogram"
3415 is actually an enumeration literal, it may be the first use
3416 of its type, so we must elaborate that type now. */
3417 if (Present (Alias (gnat_entity
)))
3419 if (Ekind (Alias (gnat_entity
)) == E_Enumeration_Literal
)
3420 gnat_to_gnu_entity (Etype (Alias (gnat_entity
)), NULL_TREE
, 0);
3422 gnu_decl
= gnat_to_gnu_entity (Alias (gnat_entity
),
3425 /* Elaborate any Itypes in the parameters of this entity. */
3426 for (gnat_temp
= First_Formal_With_Extras (gnat_entity
);
3427 Present (gnat_temp
);
3428 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
3429 if (Is_Itype (Etype (gnat_temp
)))
3430 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
3435 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3436 corresponding DECL node.
3438 We still want the parameter associations to take place because the
3439 proper generation of calls depends on it (a GNAT parameter without
3440 a corresponding GCC tree has a very specific meaning), so we don't
3442 if (Convention (gnat_entity
) == Convention_Intrinsic
)
3443 gnu_builtin_decl
= builtin_decl_for (gnu_ext_name
);
3445 /* ??? What if we don't find the builtin node above ? warn ? err ?
3446 In the current state we neither warn nor err, and calls will just
3447 be handled as for regular subprograms. */
3449 if (kind
== E_Function
|| kind
== E_Subprogram_Type
)
3450 gnu_return_type
= gnat_to_gnu_type (Etype (gnat_entity
));
3452 /* If this function returns by reference, make the actual
3453 return type of this function the pointer and mark the decl. */
3454 if (Returns_By_Ref (gnat_entity
))
3456 returns_by_ref
= true;
3457 gnu_return_type
= build_pointer_type (gnu_return_type
);
3460 /* If the Mechanism is By_Reference, ensure the return type uses
3461 the machine's by-reference mechanism, which may not the same
3462 as above (e.g., it might be by passing a fake parameter). */
3463 else if (kind
== E_Function
3464 && Mechanism (gnat_entity
) == By_Reference
)
3466 TREE_ADDRESSABLE (gnu_return_type
) = 1;
3468 /* We expect this bit to be reset by gigi shortly, so can avoid a
3469 type node copy here. This actually also prevents troubles with
3470 the generation of debug information for the function, because
3471 we might have issued such info for this type already, and would
3472 be attaching a distinct type node to the function if we made a
3476 /* If we are supposed to return an unconstrained array,
3477 actually return a fat pointer and make a note of that. Return
3478 a pointer to an unconstrained record of variable size. */
3479 else if (TREE_CODE (gnu_return_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3481 gnu_return_type
= TREE_TYPE (gnu_return_type
);
3482 returns_unconstrained
= true;
3485 /* If the type requires a transient scope, the result is allocated
3486 on the secondary stack, so the result type of the function is
3488 else if (Requires_Transient_Scope (Etype (gnat_entity
)))
3490 gnu_return_type
= build_pointer_type (gnu_return_type
);
3491 returns_unconstrained
= true;
3494 /* If the type is a padded type and the underlying type would not
3495 be passed by reference or this function has a foreign convention,
3496 return the underlying type. */
3497 else if (TREE_CODE (gnu_return_type
) == RECORD_TYPE
3498 && TYPE_IS_PADDING_P (gnu_return_type
)
3499 && (!default_pass_by_ref (TREE_TYPE
3500 (TYPE_FIELDS (gnu_return_type
)))
3501 || Has_Foreign_Convention (gnat_entity
)))
3502 gnu_return_type
= TREE_TYPE (TYPE_FIELDS (gnu_return_type
));
3504 /* If the return type is unconstrained, that means it must have a
3505 maximum size. We convert the function into a procedure and its
3506 caller will pass a pointer to an object of that maximum size as the
3507 first parameter when we call the function. */
3508 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type
)))
3510 returns_by_target_ptr
= true;
3512 = create_param_decl (get_identifier ("TARGET"),
3513 build_reference_type (gnu_return_type
),
3515 gnu_return_type
= void_type_node
;
3518 /* If the return type has a size that overflows, we cannot have
3519 a function that returns that type. This usage doesn't make
3520 sense anyway, so give an error here. */
3521 if (TYPE_SIZE_UNIT (gnu_return_type
)
3522 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type
))
3523 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type
)))
3525 post_error ("cannot return type whose size overflows",
3527 gnu_return_type
= copy_node (gnu_return_type
);
3528 TYPE_SIZE (gnu_return_type
) = bitsize_zero_node
;
3529 TYPE_SIZE_UNIT (gnu_return_type
) = size_zero_node
;
3530 TYPE_MAIN_VARIANT (gnu_return_type
) = gnu_return_type
;
3531 TYPE_NEXT_VARIANT (gnu_return_type
) = NULL_TREE
;
3534 /* Look at all our parameters and get the type of
3535 each. While doing this, build a copy-out structure if
3538 for (gnat_param
= First_Formal_With_Extras (gnat_entity
), parmnum
= 0;
3539 Present (gnat_param
);
3540 gnat_param
= Next_Formal_With_Extras (gnat_param
), parmnum
++)
3542 tree gnu_param_name
= get_entity_name (gnat_param
);
3543 tree gnu_param_type
= gnat_to_gnu_type (Etype (gnat_param
));
3544 tree gnu_param
, gnu_field
;
3545 bool by_ref_p
= false;
3546 bool by_descr_p
= false;
3547 bool by_component_ptr_p
= false;
3548 bool copy_in_copy_out_flag
= false;
3549 bool req_by_copy
= false, req_by_ref
= false;
3551 /* Builtins are expanded inline and there is no real call sequence
3552 involved. so the type expected by the underlying expander is
3553 always the type of each argument "as is". */
3554 if (gnu_builtin_decl
)
3557 /* Otherwise, see if a Mechanism was supplied that forced this
3558 parameter to be passed one way or another. */
3559 else if (Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
3561 else if (Mechanism (gnat_param
) == Default
)
3563 else if (Mechanism (gnat_param
) == By_Copy
)
3565 else if (Mechanism (gnat_param
) == By_Reference
)
3567 else if (Mechanism (gnat_param
) <= By_Descriptor
)
3569 else if (Mechanism (gnat_param
) > 0)
3571 if (TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
3572 || TREE_CODE (TYPE_SIZE (gnu_param_type
)) != INTEGER_CST
3573 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type
),
3574 Mechanism (gnat_param
)))
3580 post_error ("unsupported mechanism for&", gnat_param
);
3582 /* If this is either a foreign function or if the
3583 underlying type won't be passed by reference, strip off
3584 possible padding type. */
3585 if (TREE_CODE (gnu_param_type
) == RECORD_TYPE
3586 && TYPE_IS_PADDING_P (gnu_param_type
)
3587 && (req_by_ref
|| Has_Foreign_Convention (gnat_entity
)
3588 || (!must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
3591 || !default_pass_by_ref (TREE_TYPE
3593 (gnu_param_type
)))))))
3594 gnu_param_type
= TREE_TYPE (TYPE_FIELDS (gnu_param_type
));
3596 /* If this is an IN parameter it is read-only, so make a variant
3597 of the type that is read-only.
3599 ??? However, if this is an unconstrained array, that type can
3600 be very complex. So skip it for now. Likewise for any other
3601 self-referential type. */
3602 if (Ekind (gnat_param
) == E_In_Parameter
3603 && TREE_CODE (gnu_param_type
) != UNCONSTRAINED_ARRAY_TYPE
3604 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type
)))
3606 = build_qualified_type (gnu_param_type
,
3607 (TYPE_QUALS (gnu_param_type
)
3608 | TYPE_QUAL_CONST
));
3610 /* For foreign conventions, pass arrays as a pointer to the
3611 underlying type. First check for unconstrained array and get
3612 the underlying array. Then get the component type and build
3614 if (Has_Foreign_Convention (gnat_entity
)
3615 && TREE_CODE (gnu_param_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3617 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3618 (TREE_TYPE (gnu_param_type
))));
3622 = build_pointer_type
3623 (build_vms_descriptor (gnu_param_type
,
3624 Mechanism (gnat_param
), gnat_entity
));
3626 else if (Has_Foreign_Convention (gnat_entity
)
3628 && TREE_CODE (gnu_param_type
) == ARRAY_TYPE
)
3630 /* Strip off any multi-dimensional entries, then strip
3631 off the last array to get the component type. */
3632 while (TREE_CODE (TREE_TYPE (gnu_param_type
)) == ARRAY_TYPE
3633 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type
)))
3634 gnu_param_type
= TREE_TYPE (gnu_param_type
);
3636 by_component_ptr_p
= true;
3637 gnu_param_type
= TREE_TYPE (gnu_param_type
);
3639 if (Ekind (gnat_param
) == E_In_Parameter
)
3641 = build_qualified_type (gnu_param_type
,
3642 (TYPE_QUALS (gnu_param_type
)
3643 | TYPE_QUAL_CONST
));
3645 gnu_param_type
= build_pointer_type (gnu_param_type
);
3648 /* Fat pointers are passed as thin pointers for foreign
3650 else if (Has_Foreign_Convention (gnat_entity
)
3651 && TYPE_FAT_POINTER_P (gnu_param_type
))
3653 = make_type_from_size (gnu_param_type
,
3654 size_int (POINTER_SIZE
), false);
3656 /* If we must pass or were requested to pass by reference, do so.
3657 If we were requested to pass by copy, do so.
3658 Otherwise, for foreign conventions, pass all in out parameters
3659 or aggregates by reference. For COBOL and Fortran, pass
3660 all integer and FP types that way too. For Convention Ada,
3661 use the standard Ada default. */
3662 else if (must_pass_by_ref (gnu_param_type
) || req_by_ref
3664 && ((Has_Foreign_Convention (gnat_entity
)
3665 && (Ekind (gnat_param
) != E_In_Parameter
3666 || AGGREGATE_TYPE_P (gnu_param_type
)))
3667 || (((Convention (gnat_entity
)
3668 == Convention_Fortran
)
3669 || (Convention (gnat_entity
)
3670 == Convention_COBOL
))
3671 && (INTEGRAL_TYPE_P (gnu_param_type
)
3672 || FLOAT_TYPE_P (gnu_param_type
)))
3673 /* For convention Ada, see if we pass by reference
3675 || (!Has_Foreign_Convention (gnat_entity
)
3676 && default_pass_by_ref (gnu_param_type
)))))
3678 gnu_param_type
= build_reference_type (gnu_param_type
);
3682 else if (Ekind (gnat_param
) != E_In_Parameter
)
3683 copy_in_copy_out_flag
= true;
3685 if (req_by_copy
&& (by_ref_p
|| by_component_ptr_p
))
3686 post_error ("?cannot pass & by copy", gnat_param
);
3688 /* If this is an OUT parameter that isn't passed by reference
3689 and isn't a pointer or aggregate, we don't make a PARM_DECL
3690 for it. Instead, it will be a VAR_DECL created when we process
3691 the procedure. For the special parameter of Valued_Procedure,
3694 An exception is made to cover the RM-6.4.1 rule requiring "by
3695 copy" out parameters with discriminants or implicit initial
3696 values to be handled like in out parameters. These type are
3697 normally built as aggregates, and hence passed by reference,
3698 except for some packed arrays which end up encoded in special
3701 The exception we need to make is then for packed arrays of
3702 records with discriminants or implicit initial values. We have
3703 no light/easy way to check for the latter case, so we merely
3704 check for packed arrays of records. This may lead to useless
3705 copy-in operations, but in very rare cases only, as these would
3706 be exceptions in a set of already exceptional situations. */
3707 if (Ekind (gnat_param
) == E_Out_Parameter
&& !by_ref_p
3708 && ((Is_Valued_Procedure (gnat_entity
) && parmnum
== 0)
3710 && !POINTER_TYPE_P (gnu_param_type
)
3711 && !AGGREGATE_TYPE_P (gnu_param_type
)))
3712 && !(Is_Array_Type (Etype (gnat_param
))
3713 && Is_Packed (Etype (gnat_param
))
3714 && Is_Composite_Type (Component_Type
3715 (Etype (gnat_param
)))))
3716 gnu_param
= NULL_TREE
;
3721 (gnu_param_name
, gnu_param_type
,
3722 by_ref_p
|| by_component_ptr_p
3723 || Ekind (gnat_param
) == E_In_Parameter
);
3725 DECL_BY_REF_P (gnu_param
) = by_ref_p
;
3726 DECL_BY_COMPONENT_PTR_P (gnu_param
) = by_component_ptr_p
;
3727 DECL_BY_DESCRIPTOR_P (gnu_param
) = by_descr_p
;
3728 DECL_POINTS_TO_READONLY_P (gnu_param
)
3729 = (Ekind (gnat_param
) == E_In_Parameter
3730 && (by_ref_p
|| by_component_ptr_p
));
3731 Sloc_to_locus (Sloc (gnat_param
),
3732 &DECL_SOURCE_LOCATION (gnu_param
));
3733 save_gnu_tree (gnat_param
, gnu_param
, false);
3734 gnu_param_list
= chainon (gnu_param
, gnu_param_list
);
3736 /* If a parameter is a pointer, this function may modify
3737 memory through it and thus shouldn't be considered
3738 a pure function. Also, the memory may be modified
3739 between two calls, so they can't be CSE'ed. The latter
3740 case also handles by-ref parameters. */
3741 if (POINTER_TYPE_P (gnu_param_type
)
3742 || TYPE_FAT_POINTER_P (gnu_param_type
))
3746 if (copy_in_copy_out_flag
)
3748 if (!has_copy_in_out
)
3750 gcc_assert (TREE_CODE (gnu_return_type
) == VOID_TYPE
);
3751 gnu_return_type
= make_node (RECORD_TYPE
);
3752 TYPE_NAME (gnu_return_type
) = get_identifier ("RETURN");
3753 has_copy_in_out
= true;
3756 gnu_field
= create_field_decl (gnu_param_name
, gnu_param_type
,
3757 gnu_return_type
, 0, 0, 0, 0);
3758 Sloc_to_locus (Sloc (gnat_param
),
3759 &DECL_SOURCE_LOCATION (gnu_field
));
3760 TREE_CHAIN (gnu_field
) = gnu_field_list
;
3761 gnu_field_list
= gnu_field
;
3762 gnu_return_list
= tree_cons (gnu_field
, gnu_param
,
3767 /* Do not compute record for out parameters if subprogram is
3768 stubbed since structures are incomplete for the back-end. */
3770 && Convention (gnat_entity
) != Convention_Stubbed
)
3772 /* If all types are not complete, defer emission of debug
3773 information for this record types. Otherwise, we risk emitting
3774 debug information for a dummy type contained in the fields
3776 finish_record_type (gnu_return_type
, nreverse (gnu_field_list
),
3777 false, defer_incomplete_level
);
3779 if (defer_incomplete_level
)
3781 debug_deferred
= true;
3782 defer_debug_level
++;
3784 defer_debug_incomplete_list
3785 = tree_cons (NULL_TREE
, gnu_return_type
,
3786 defer_debug_incomplete_list
);
3790 /* If we have a CICO list but it has only one entry, we convert
3791 this function into a function that simply returns that one
3793 if (list_length (gnu_return_list
) == 1)
3794 gnu_return_type
= TREE_TYPE (TREE_PURPOSE (gnu_return_list
));
3796 if (Has_Stdcall_Convention (gnat_entity
))
3799 = (struct attrib
*) xmalloc (sizeof (struct attrib
));
3801 attr
->next
= attr_list
;
3802 attr
->type
= ATTR_MACHINE_ATTRIBUTE
;
3803 attr
->name
= get_identifier ("stdcall");
3804 attr
->args
= NULL_TREE
;
3805 attr
->error_point
= gnat_entity
;
3809 /* Both lists ware built in reverse. */
3810 gnu_param_list
= nreverse (gnu_param_list
);
3811 gnu_return_list
= nreverse (gnu_return_list
);
3814 = create_subprog_type (gnu_return_type
, gnu_param_list
,
3815 gnu_return_list
, returns_unconstrained
,
3817 Function_Returns_With_DSP (gnat_entity
),
3818 returns_by_target_ptr
);
3820 /* A subprogram (something that doesn't return anything) shouldn't
3821 be considered Pure since there would be no reason for such a
3822 subprogram. Note that procedures with Out (or In Out) parameters
3823 have already been converted into a function with a return type. */
3824 if (TREE_CODE (gnu_return_type
) == VOID_TYPE
)
3827 /* The semantics of "pure" in Ada essentially matches that of "const"
3828 in the back-end. In particular, both properties are orthogonal to
3829 the "nothrow" property. But this is true only if the EH circuitry
3830 is explicit in the internal representation of the back-end. If we
3831 are to completely hide the EH circuitry from it, we need to declare
3832 that calls to pure Ada subprograms that can throw have side effects
3833 since they can trigger an "abnormal" transfer of control flow; thus
3834 they can be neither "const" nor "pure" in the back-end sense. */
3836 = build_qualified_type (gnu_type
,
3837 TYPE_QUALS (gnu_type
)
3838 | (Exception_Mechanism
== Back_End_Exceptions
3839 ? TYPE_QUAL_CONST
* pure_flag
: 0)
3840 | (TYPE_QUAL_VOLATILE
* volatile_flag
));
3842 Sloc_to_locus (Sloc (gnat_entity
), &input_location
);
3844 /* If we have a builtin decl for that function, check the signatures
3845 compatibilities. If the signatures are compatible, use the builtin
3846 decl. If they are not, we expect the checker predicate to have
3847 posted the appropriate errors, and just continue with what we have
3849 if (gnu_builtin_decl
)
3851 tree gnu_builtin_type
= TREE_TYPE (gnu_builtin_decl
);
3853 if (compatible_signatures_p (gnu_type
, gnu_builtin_type
))
3855 gnu_decl
= gnu_builtin_decl
;
3856 gnu_type
= gnu_builtin_type
;
3861 /* If there was no specified Interface_Name and the external and
3862 internal names of the subprogram are the same, only use the
3863 internal name to allow disambiguation of nested subprograms. */
3864 if (No (Interface_Name (gnat_entity
)) && gnu_ext_name
== gnu_entity_id
)
3865 gnu_ext_name
= NULL_TREE
;
3867 /* If we are defining the subprogram and it has an Address clause
3868 we must get the address expression from the saved GCC tree for the
3869 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3870 the address expression here since the front-end has guaranteed
3871 in that case that the elaboration has no effects. If there is
3872 an Address clause and we are not defining the object, just
3873 make it a constant. */
3874 if (Present (Address_Clause (gnat_entity
)))
3876 tree gnu_address
= NULL_TREE
;
3880 = (present_gnu_tree (gnat_entity
)
3881 ? get_gnu_tree (gnat_entity
)
3882 : gnat_to_gnu (Expression (Address_Clause (gnat_entity
))));
3884 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
3886 /* Convert the type of the object to a reference type that can
3887 alias everything as per 13.3(19). */
3889 = build_reference_type_for_mode (gnu_type
, ptr_mode
, true);
3891 gnu_address
= convert (gnu_type
, gnu_address
);
3894 = create_var_decl (gnu_entity_id
, gnu_ext_name
, gnu_type
,
3895 gnu_address
, false, Is_Public (gnat_entity
),
3896 extern_flag
, false, NULL
, gnat_entity
);
3897 DECL_BY_REF_P (gnu_decl
) = 1;
3900 else if (kind
== E_Subprogram_Type
)
3901 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3902 !Comes_From_Source (gnat_entity
),
3903 debug_info_p
&& !defer_incomplete_level
,
3907 gnu_decl
= create_subprog_decl (gnu_entity_id
, gnu_ext_name
,
3908 gnu_type
, gnu_param_list
,
3909 inline_flag
, public_flag
,
3910 extern_flag
, attr_list
,
3913 DECL_STUBBED_P (gnu_decl
)
3914 = Convention (gnat_entity
) == Convention_Stubbed
;
3919 case E_Incomplete_Type
:
3920 case E_Incomplete_Subtype
:
3921 case E_Private_Type
:
3922 case E_Private_Subtype
:
3923 case E_Limited_Private_Type
:
3924 case E_Limited_Private_Subtype
:
3925 case E_Record_Type_With_Private
:
3926 case E_Record_Subtype_With_Private
:
3928 /* Get the "full view" of this entity. If this is an incomplete
3929 entity from a limited with, treat its non-limited view as the
3930 full view. Otherwise, use either the full view or the underlying
3931 full view, whichever is present. This is used in all the tests
3934 = (IN (Ekind (gnat_entity
), Incomplete_Kind
)
3935 && From_With_Type (gnat_entity
))
3936 ? Non_Limited_View (gnat_entity
)
3937 : Present (Full_View (gnat_entity
))
3938 ? Full_View (gnat_entity
)
3939 : Underlying_Full_View (gnat_entity
);
3941 /* If this is an incomplete type with no full view, it must be a Taft
3942 Amendment type, in which case we return a dummy type. Otherwise,
3943 just get the type from its Etype. */
3946 if (kind
== E_Incomplete_Type
)
3947 gnu_type
= make_dummy_type (gnat_entity
);
3950 gnu_decl
= gnat_to_gnu_entity (Etype (gnat_entity
),
3952 maybe_present
= true;
3957 /* If we already made a type for the full view, reuse it. */
3958 else if (present_gnu_tree (full_view
))
3960 gnu_decl
= get_gnu_tree (full_view
);
3964 /* Otherwise, if we are not defining the type now, get the type
3965 from the full view. But always get the type from the full view
3966 for define on use types, since otherwise we won't see them! */
3967 else if (!definition
3968 || (Is_Itype (full_view
)
3969 && No (Freeze_Node (gnat_entity
)))
3970 || (Is_Itype (gnat_entity
)
3971 && No (Freeze_Node (full_view
))))
3973 gnu_decl
= gnat_to_gnu_entity (full_view
, NULL_TREE
, 0);
3974 maybe_present
= true;
3978 /* For incomplete types, make a dummy type entry which will be
3980 gnu_type
= make_dummy_type (gnat_entity
);
3982 /* Save this type as the full declaration's type so we can do any
3983 needed updates when we see it. */
3984 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
3985 !Comes_From_Source (gnat_entity
),
3986 debug_info_p
, gnat_entity
);
3987 save_gnu_tree (full_view
, gnu_decl
, 0);
3991 /* Simple class_wide types are always viewed as their root_type
3992 by Gigi unless an Equivalent_Type is specified. */
3993 case E_Class_Wide_Type
:
3994 if (Present (Equivalent_Type (gnat_entity
)))
3995 gnu_decl
= gnat_to_gnu_entity (Equivalent_Type (gnat_entity
),
3998 gnu_decl
= gnat_to_gnu_entity (Root_Type (gnat_entity
),
4001 maybe_present
= true;
4005 case E_Task_Subtype
:
4006 case E_Protected_Type
:
4007 case E_Protected_Subtype
:
4008 if (type_annotate_only
&& No (Corresponding_Record_Type (gnat_entity
)))
4009 gnu_type
= void_type_node
;
4011 gnu_type
= gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity
));
4013 maybe_present
= true;
4017 gnu_decl
= create_label_decl (gnu_entity_id
);
4022 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4023 we've already saved it, so we don't try to. */
4024 gnu_decl
= error_mark_node
;
4032 /* If we had a case where we evaluated another type and it might have
4033 defined this one, handle it here. */
4034 if (maybe_present
&& present_gnu_tree (gnat_entity
))
4036 gnu_decl
= get_gnu_tree (gnat_entity
);
4040 /* If we are processing a type and there is either no decl for it or
4041 we just made one, do some common processing for the type, such as
4042 handling alignment and possible padding. */
4044 if ((!gnu_decl
|| this_made_decl
) && IN (kind
, Type_Kind
))
4046 if (Is_Tagged_Type (gnat_entity
)
4047 || Is_Class_Wide_Equivalent_Type (gnat_entity
))
4048 TYPE_ALIGN_OK (gnu_type
) = 1;
4050 if (AGGREGATE_TYPE_P (gnu_type
) && Is_By_Reference_Type (gnat_entity
))
4051 TYPE_BY_REFERENCE_P (gnu_type
) = 1;
4053 /* ??? Don't set the size for a String_Literal since it is either
4054 confirming or we don't handle it properly (if the low bound is
4056 if (!gnu_size
&& kind
!= E_String_Literal_Subtype
)
4057 gnu_size
= validate_size (Esize (gnat_entity
), gnu_type
, gnat_entity
,
4059 Has_Size_Clause (gnat_entity
));
4061 /* If a size was specified, see if we can make a new type of that size
4062 by rearranging the type, for example from a fat to a thin pointer. */
4066 = make_type_from_size (gnu_type
, gnu_size
,
4067 Has_Biased_Representation (gnat_entity
));
4069 if (operand_equal_p (TYPE_SIZE (gnu_type
), gnu_size
, 0)
4070 && operand_equal_p (rm_size (gnu_type
), gnu_size
, 0))
4074 /* If the alignment hasn't already been processed and this is
4075 not an unconstrained array, see if an alignment is specified.
4076 If not, we pick a default alignment for atomic objects. */
4077 if (align
!= 0 || TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4079 else if (Known_Alignment (gnat_entity
))
4080 align
= validate_alignment (Alignment (gnat_entity
), gnat_entity
,
4081 TYPE_ALIGN (gnu_type
));
4082 else if (Is_Atomic (gnat_entity
) && !gnu_size
4083 && host_integerp (TYPE_SIZE (gnu_type
), 1)
4084 && integer_pow2p (TYPE_SIZE (gnu_type
)))
4085 align
= MIN (BIGGEST_ALIGNMENT
,
4086 tree_low_cst (TYPE_SIZE (gnu_type
), 1));
4087 else if (Is_Atomic (gnat_entity
) && gnu_size
4088 && host_integerp (gnu_size
, 1)
4089 && integer_pow2p (gnu_size
))
4090 align
= MIN (BIGGEST_ALIGNMENT
, tree_low_cst (gnu_size
, 1));
4092 /* See if we need to pad the type. If we did, and made a record,
4093 the name of the new type may be changed. So get it back for
4094 us when we make the new TYPE_DECL below. */
4095 gnu_type
= maybe_pad_type (gnu_type
, gnu_size
, align
, gnat_entity
, "PAD",
4096 true, definition
, false);
4097 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4098 && TYPE_IS_PADDING_P (gnu_type
))
4100 gnu_entity_id
= TYPE_NAME (gnu_type
);
4101 if (TREE_CODE (gnu_entity_id
) == TYPE_DECL
)
4102 gnu_entity_id
= DECL_NAME (gnu_entity_id
);
4105 set_rm_size (RM_Size (gnat_entity
), gnu_type
, gnat_entity
);
4107 /* If we are at global level, GCC will have applied variable_size to
4108 the type, but that won't have done anything. So, if it's not
4109 a constant or self-referential, call elaborate_expression_1 to
4110 make a variable for the size rather than calculating it each time.
4111 Handle both the RM size and the actual size. */
4112 if (global_bindings_p ()
4113 && TYPE_SIZE (gnu_type
)
4114 && !TREE_CONSTANT (TYPE_SIZE (gnu_type
))
4115 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type
)))
4117 if (TREE_CODE (gnu_type
) == RECORD_TYPE
4118 && operand_equal_p (TYPE_ADA_SIZE (gnu_type
),
4119 TYPE_SIZE (gnu_type
), 0))
4121 TYPE_SIZE (gnu_type
)
4122 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4123 TYPE_SIZE (gnu_type
),
4124 get_identifier ("SIZE"),
4126 SET_TYPE_ADA_SIZE (gnu_type
, TYPE_SIZE (gnu_type
));
4130 TYPE_SIZE (gnu_type
)
4131 = elaborate_expression_1 (gnat_entity
, gnat_entity
,
4132 TYPE_SIZE (gnu_type
),
4133 get_identifier ("SIZE"),
4136 /* ??? For now, store the size as a multiple of the alignment
4137 in bytes so that we can see the alignment from the tree. */
4138 TYPE_SIZE_UNIT (gnu_type
)
4140 (MULT_EXPR
, sizetype
,
4141 elaborate_expression_1
4142 (gnat_entity
, gnat_entity
,
4143 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4144 TYPE_SIZE_UNIT (gnu_type
),
4145 size_int (TYPE_ALIGN (gnu_type
)
4147 get_identifier ("SIZE_A_UNIT"),
4149 size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4151 if (TREE_CODE (gnu_type
) == RECORD_TYPE
)
4154 elaborate_expression_1 (gnat_entity
,
4156 TYPE_ADA_SIZE (gnu_type
),
4157 get_identifier ("RM_SIZE"),
4162 /* If this is a record type or subtype, call elaborate_expression_1 on
4163 any field position. Do this for both global and local types.
4164 Skip any fields that we haven't made trees for to avoid problems with
4165 class wide types. */
4166 if (IN (kind
, Record_Kind
))
4167 for (gnat_temp
= First_Entity (gnat_entity
); Present (gnat_temp
);
4168 gnat_temp
= Next_Entity (gnat_temp
))
4169 if (Ekind (gnat_temp
) == E_Component
&& present_gnu_tree (gnat_temp
))
4171 tree gnu_field
= get_gnu_tree (gnat_temp
);
4173 /* ??? Unfortunately, GCC needs to be able to prove the
4174 alignment of this offset and if it's a variable, it can't.
4175 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4176 right now, we have to put in an explicit multiply and
4177 divide by that value. */
4178 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field
)))
4180 DECL_FIELD_OFFSET (gnu_field
)
4182 (MULT_EXPR
, sizetype
,
4183 elaborate_expression_1
4184 (gnat_temp
, gnat_temp
,
4185 build_binary_op (EXACT_DIV_EXPR
, sizetype
,
4186 DECL_FIELD_OFFSET (gnu_field
),
4187 size_int (DECL_OFFSET_ALIGN (gnu_field
)
4189 get_identifier ("OFFSET"),
4191 size_int (DECL_OFFSET_ALIGN (gnu_field
) / BITS_PER_UNIT
));
4193 /* ??? The context of gnu_field is not necessarily gnu_type so
4194 the MULT_EXPR node built above may not be marked by the call
4195 to create_type_decl below. Mark it manually for now. */
4196 if (global_bindings_p ())
4197 TREE_VISITED (DECL_FIELD_OFFSET (gnu_field
)) = 1;
4201 gnu_type
= build_qualified_type (gnu_type
,
4202 (TYPE_QUALS (gnu_type
)
4203 | (TYPE_QUAL_VOLATILE
4204 * Treat_As_Volatile (gnat_entity
))));
4206 if (Is_Atomic (gnat_entity
))
4207 check_ok_for_atomic (gnu_type
, gnat_entity
, false);
4209 if (Known_Alignment (gnat_entity
))
4210 TYPE_USER_ALIGN (gnu_type
) = 1;
4213 gnu_decl
= create_type_decl (gnu_entity_id
, gnu_type
, attr_list
,
4214 !Comes_From_Source (gnat_entity
),
4215 debug_info_p
, gnat_entity
);
4217 TREE_TYPE (gnu_decl
) = gnu_type
;
4220 if (IN (kind
, Type_Kind
) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl
)))
4222 gnu_type
= TREE_TYPE (gnu_decl
);
4224 /* Back-annotate the Alignment of the type if not already in the
4225 tree. Likewise for sizes. */
4226 if (Unknown_Alignment (gnat_entity
))
4227 Set_Alignment (gnat_entity
,
4228 UI_From_Int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
));
4230 if (Unknown_Esize (gnat_entity
) && TYPE_SIZE (gnu_type
))
4232 /* If the size is self-referential, we annotate the maximum
4233 value of that size. */
4234 tree gnu_size
= TYPE_SIZE (gnu_type
);
4236 if (CONTAINS_PLACEHOLDER_P (gnu_size
))
4237 gnu_size
= max_size (gnu_size
, true);
4239 Set_Esize (gnat_entity
, annotate_value (gnu_size
));
4241 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
4243 /* In this mode the tag and the parent components are not
4244 generated by the front-end, so the sizes must be adjusted
4250 if (Is_Derived_Type (gnat_entity
))
4253 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity
))));
4254 Set_Alignment (gnat_entity
,
4255 Alignment (Etype (Base_Type (gnat_entity
))));
4258 size_offset
= POINTER_SIZE
;
4260 new_size
= UI_To_Int (Esize (gnat_entity
)) + size_offset
;
4261 Set_Esize (gnat_entity
,
4262 UI_From_Int (((new_size
+ (POINTER_SIZE
- 1))
4263 / POINTER_SIZE
) * POINTER_SIZE
));
4264 Set_RM_Size (gnat_entity
, Esize (gnat_entity
));
4268 if (Unknown_RM_Size (gnat_entity
) && rm_size (gnu_type
))
4269 Set_RM_Size (gnat_entity
, annotate_value (rm_size (gnu_type
)));
4272 if (!Comes_From_Source (gnat_entity
) && DECL_P (gnu_decl
))
4273 DECL_ARTIFICIAL (gnu_decl
) = 1;
4275 if (!debug_info_p
&& DECL_P (gnu_decl
)
4276 && TREE_CODE (gnu_decl
) != FUNCTION_DECL
4277 && No (Renamed_Object (gnat_entity
)))
4278 DECL_IGNORED_P (gnu_decl
) = 1;
4280 /* If we haven't already, associate the ..._DECL node that we just made with
4281 the input GNAT entity node. */
4283 save_gnu_tree (gnat_entity
, gnu_decl
, false);
4285 /* If this is an enumeral or floating-point type, we were not able to set
4286 the bounds since they refer to the type. These bounds are always static.
4288 For enumeration types, also write debugging information and declare the
4289 enumeration literal table, if needed. */
4291 if ((kind
== E_Enumeration_Type
&& Present (First_Literal (gnat_entity
)))
4292 || (kind
== E_Floating_Point_Type
&& !Vax_Float (gnat_entity
)))
4294 tree gnu_scalar_type
= gnu_type
;
4296 /* If this is a padded type, we need to use the underlying type. */
4297 if (TREE_CODE (gnu_scalar_type
) == RECORD_TYPE
4298 && TYPE_IS_PADDING_P (gnu_scalar_type
))
4299 gnu_scalar_type
= TREE_TYPE (TYPE_FIELDS (gnu_scalar_type
));
4301 /* If this is a floating point type and we haven't set a floating
4302 point type yet, use this in the evaluation of the bounds. */
4303 if (!longest_float_type_node
&& kind
== E_Floating_Point_Type
)
4304 longest_float_type_node
= gnu_type
;
4306 TYPE_MIN_VALUE (gnu_scalar_type
)
4307 = gnat_to_gnu (Type_Low_Bound (gnat_entity
));
4308 TYPE_MAX_VALUE (gnu_scalar_type
)
4309 = gnat_to_gnu (Type_High_Bound (gnat_entity
));
4311 if (TREE_CODE (gnu_scalar_type
) == ENUMERAL_TYPE
)
4313 TYPE_STUB_DECL (gnu_scalar_type
) = gnu_decl
;
4315 /* Since this has both a typedef and a tag, avoid outputting
4317 DECL_ARTIFICIAL (gnu_decl
) = 1;
4318 rest_of_type_compilation (gnu_scalar_type
, global_bindings_p ());
4322 /* If we deferred processing of incomplete types, re-enable it. If there
4323 were no other disables and we have some to process, do so. */
4324 if (this_deferred
&& --defer_incomplete_level
== 0 && defer_incomplete_list
)
4326 struct incomplete
*incp
= defer_incomplete_list
;
4327 struct incomplete
*next
;
4329 defer_incomplete_list
= NULL
;
4330 for (; incp
; incp
= next
)
4335 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4336 gnat_to_gnu_type (incp
->full_type
));
4341 /* If we are not defining this type, see if it's in the incomplete list.
4342 If so, handle that list entry now. */
4343 else if (!definition
)
4345 struct incomplete
*incp
;
4347 for (incp
= defer_incomplete_list
; incp
; incp
= incp
->next
)
4348 if (incp
->old_type
&& incp
->full_type
== gnat_entity
)
4350 update_pointer_to (TYPE_MAIN_VARIANT (incp
->old_type
),
4351 TREE_TYPE (gnu_decl
));
4352 incp
->old_type
= NULL_TREE
;
4356 /* If there are no incomplete types and we have deferred emission
4357 of debug information, check whether we have finished defining
4359 If so, handle the list now. */
4362 defer_debug_level
--;
4364 if (defer_debug_incomplete_list
4365 && !defer_incomplete_level
4366 && !defer_debug_level
)
4370 defer_debug_incomplete_list
= nreverse (defer_debug_incomplete_list
);
4372 for (c
= defer_debug_incomplete_list
; c
; c
= n
)
4375 write_record_type_debug_info (TREE_VALUE (c
));
4378 defer_debug_incomplete_list
= 0;
4384 if (Is_Packed_Array_Type (gnat_entity
)
4385 && Is_Itype (Associated_Node_For_Itype (gnat_entity
))
4386 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity
)))
4387 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity
)))
4388 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity
), NULL_TREE
, 0);
4393 /* Similar, but if the returned value is a COMPONENT_REF, return the
4397 gnat_to_gnu_field_decl (Entity_Id gnat_entity
)
4399 tree gnu_field
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4401 if (TREE_CODE (gnu_field
) == COMPONENT_REF
)
4402 gnu_field
= TREE_OPERAND (gnu_field
, 1);
4407 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4410 bool same_discriminant_p (Entity_Id discr1
, Entity_Id discr2
)
4412 while (Present (Corresponding_Discriminant (discr1
)))
4413 discr1
= Corresponding_Discriminant (discr1
);
4415 while (Present (Corresponding_Discriminant (discr2
)))
4416 discr2
= Corresponding_Discriminant (discr2
);
4419 Original_Record_Component (discr1
) == Original_Record_Component (discr2
);
4422 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4423 be elaborated at the point of its definition, but do nothing else. */
4426 elaborate_entity (Entity_Id gnat_entity
)
4428 switch (Ekind (gnat_entity
))
4430 case E_Signed_Integer_Subtype
:
4431 case E_Modular_Integer_Subtype
:
4432 case E_Enumeration_Subtype
:
4433 case E_Ordinary_Fixed_Point_Subtype
:
4434 case E_Decimal_Fixed_Point_Subtype
:
4435 case E_Floating_Point_Subtype
:
4437 Node_Id gnat_lb
= Type_Low_Bound (gnat_entity
);
4438 Node_Id gnat_hb
= Type_High_Bound (gnat_entity
);
4440 /* ??? Tests for avoiding static constraint error expression
4441 is needed until the front stops generating bogus conversions
4442 on bounds of real types. */
4444 if (!Raises_Constraint_Error (gnat_lb
))
4445 elaborate_expression (gnat_lb
, gnat_entity
, get_identifier ("L"),
4446 1, 0, Needs_Debug_Info (gnat_entity
));
4447 if (!Raises_Constraint_Error (gnat_hb
))
4448 elaborate_expression (gnat_hb
, gnat_entity
, get_identifier ("U"),
4449 1, 0, Needs_Debug_Info (gnat_entity
));
4455 Node_Id full_definition
= Declaration_Node (gnat_entity
);
4456 Node_Id record_definition
= Type_Definition (full_definition
);
4458 /* If this is a record extension, go a level further to find the
4459 record definition. */
4460 if (Nkind (record_definition
) == N_Derived_Type_Definition
)
4461 record_definition
= Record_Extension_Part (record_definition
);
4465 case E_Record_Subtype
:
4466 case E_Private_Subtype
:
4467 case E_Limited_Private_Subtype
:
4468 case E_Record_Subtype_With_Private
:
4469 if (Is_Constrained (gnat_entity
)
4470 && Has_Discriminants (Base_Type (gnat_entity
))
4471 && Present (Discriminant_Constraint (gnat_entity
)))
4473 Node_Id gnat_discriminant_expr
;
4474 Entity_Id gnat_field
;
4476 for (gnat_field
= First_Discriminant (Base_Type (gnat_entity
)),
4477 gnat_discriminant_expr
4478 = First_Elmt (Discriminant_Constraint (gnat_entity
));
4479 Present (gnat_field
);
4480 gnat_field
= Next_Discriminant (gnat_field
),
4481 gnat_discriminant_expr
= Next_Elmt (gnat_discriminant_expr
))
4482 /* ??? For now, ignore access discriminants. */
4483 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr
))))
4484 elaborate_expression (Node (gnat_discriminant_expr
),
4486 get_entity_name (gnat_field
), 1, 0, 0);
4493 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4494 any entities on its entity chain similarly. */
4497 mark_out_of_scope (Entity_Id gnat_entity
)
4499 Entity_Id gnat_sub_entity
;
4500 unsigned int kind
= Ekind (gnat_entity
);
4502 /* If this has an entity list, process all in the list. */
4503 if (IN (kind
, Class_Wide_Kind
) || IN (kind
, Concurrent_Kind
)
4504 || IN (kind
, Private_Kind
)
4505 || kind
== E_Block
|| kind
== E_Entry
|| kind
== E_Entry_Family
4506 || kind
== E_Function
|| kind
== E_Generic_Function
4507 || kind
== E_Generic_Package
|| kind
== E_Generic_Procedure
4508 || kind
== E_Loop
|| kind
== E_Operator
|| kind
== E_Package
4509 || kind
== E_Package_Body
|| kind
== E_Procedure
4510 || kind
== E_Record_Type
|| kind
== E_Record_Subtype
4511 || kind
== E_Subprogram_Body
|| kind
== E_Subprogram_Type
)
4512 for (gnat_sub_entity
= First_Entity (gnat_entity
);
4513 Present (gnat_sub_entity
);
4514 gnat_sub_entity
= Next_Entity (gnat_sub_entity
))
4515 if (Scope (gnat_sub_entity
) == gnat_entity
4516 && gnat_sub_entity
!= gnat_entity
)
4517 mark_out_of_scope (gnat_sub_entity
);
4519 /* Now clear this if it has been defined, but only do so if it isn't
4520 a subprogram or parameter. We could refine this, but it isn't
4521 worth it. If this is statically allocated, it is supposed to
4522 hang around out of cope. */
4523 if (present_gnu_tree (gnat_entity
) && !Is_Statically_Allocated (gnat_entity
)
4524 && kind
!= E_Procedure
&& kind
!= E_Function
&& !IN (kind
, Formal_Kind
))
4526 save_gnu_tree (gnat_entity
, NULL_TREE
, true);
4527 save_gnu_tree (gnat_entity
, error_mark_node
, true);
4531 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4532 is a multi-dimensional array type, do this recursively. */
4535 copy_alias_set (tree gnu_new_type
, tree gnu_old_type
)
4537 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
4538 of a one-dimensional array, since the padding has the same alias set
4539 as the field type, but if it's a multi-dimensional array, we need to
4540 see the inner types. */
4541 while (TREE_CODE (gnu_old_type
) == RECORD_TYPE
4542 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type
)
4543 || TYPE_IS_PADDING_P (gnu_old_type
)))
4544 gnu_old_type
= TREE_TYPE (TYPE_FIELDS (gnu_old_type
));
4546 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4547 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4548 so we need to go down to what does. */
4549 if (TREE_CODE (gnu_old_type
) == UNCONSTRAINED_ARRAY_TYPE
)
4551 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type
))));
4553 if (TREE_CODE (gnu_new_type
) == ARRAY_TYPE
4554 && TREE_CODE (TREE_TYPE (gnu_new_type
)) == ARRAY_TYPE
4555 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type
)))
4556 copy_alias_set (TREE_TYPE (gnu_new_type
), TREE_TYPE (gnu_old_type
));
4558 TYPE_ALIAS_SET (gnu_new_type
) = get_alias_set (gnu_old_type
);
4559 record_component_aliases (gnu_new_type
);
4562 /* Return a TREE_LIST describing the substitutions needed to reflect
4563 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4564 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4565 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
4566 gives the tree for the discriminant and TREE_VALUES is the replacement
4567 value. They are in the form of operands to substitute_in_expr.
4568 DEFINITION is as in gnat_to_gnu_entity. */
4571 substitution_list (Entity_Id gnat_subtype
, Entity_Id gnat_type
,
4572 tree gnu_list
, bool definition
)
4574 Entity_Id gnat_discrim
;
4578 gnat_type
= Implementation_Base_Type (gnat_subtype
);
4580 if (Has_Discriminants (gnat_type
))
4581 for (gnat_discrim
= First_Stored_Discriminant (gnat_type
),
4582 gnat_value
= First_Elmt (Stored_Constraint (gnat_subtype
));
4583 Present (gnat_discrim
);
4584 gnat_discrim
= Next_Stored_Discriminant (gnat_discrim
),
4585 gnat_value
= Next_Elmt (gnat_value
))
4586 /* Ignore access discriminants. */
4587 if (!Is_Access_Type (Etype (Node (gnat_value
))))
4588 gnu_list
= tree_cons (gnat_to_gnu_field_decl (gnat_discrim
),
4589 elaborate_expression
4590 (Node (gnat_value
), gnat_subtype
,
4591 get_entity_name (gnat_discrim
), definition
,
4598 /* Return true if the size represented by GNU_SIZE can be handled by an
4599 allocation. If STATIC_P is true, consider only what can be done with a
4600 static allocation. */
4603 allocatable_size_p (tree gnu_size
, bool static_p
)
4605 HOST_WIDE_INT our_size
;
4607 /* If this is not a static allocation, the only case we want to forbid
4608 is an overflowing size. That will be converted into a raise a
4611 return !(TREE_CODE (gnu_size
) == INTEGER_CST
4612 && TREE_OVERFLOW (gnu_size
));
4614 /* Otherwise, we need to deal with both variable sizes and constant
4615 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4616 since assemblers may not like very large sizes. */
4617 if (!host_integerp (gnu_size
, 1))
4620 our_size
= tree_low_cst (gnu_size
, 1);
4621 return (int) our_size
== our_size
;
4624 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
4627 prepend_attributes (Entity_Id gnat_entity
, struct attrib
** attr_list
)
4631 for (gnat_temp
= First_Rep_Item (gnat_entity
); Present (gnat_temp
);
4632 gnat_temp
= Next_Rep_Item (gnat_temp
))
4633 if (Nkind (gnat_temp
) == N_Pragma
)
4635 struct attrib
*attr
;
4636 tree gnu_arg0
= NULL_TREE
, gnu_arg1
= NULL_TREE
;
4637 Node_Id gnat_assoc
= Pragma_Argument_Associations (gnat_temp
);
4638 enum attr_type etype
;
4640 if (Present (gnat_assoc
) && Present (First (gnat_assoc
))
4641 && Present (Next (First (gnat_assoc
)))
4642 && (Nkind (Expression (Next (First (gnat_assoc
))))
4643 == N_String_Literal
))
4645 gnu_arg0
= get_identifier (TREE_STRING_POINTER
4648 (First (gnat_assoc
))))));
4649 if (Present (Next (Next (First (gnat_assoc
))))
4650 && (Nkind (Expression (Next (Next (First (gnat_assoc
)))))
4651 == N_String_Literal
))
4652 gnu_arg1
= get_identifier (TREE_STRING_POINTER
4656 (First (gnat_assoc
)))))));
4659 switch (Get_Pragma_Id (Chars (gnat_temp
)))
4661 case Pragma_Machine_Attribute
:
4662 etype
= ATTR_MACHINE_ATTRIBUTE
;
4665 case Pragma_Linker_Alias
:
4666 etype
= ATTR_LINK_ALIAS
;
4669 case Pragma_Linker_Section
:
4670 etype
= ATTR_LINK_SECTION
;
4673 case Pragma_Linker_Constructor
:
4674 etype
= ATTR_LINK_CONSTRUCTOR
;
4677 case Pragma_Linker_Destructor
:
4678 etype
= ATTR_LINK_DESTRUCTOR
;
4681 case Pragma_Weak_External
:
4682 etype
= ATTR_WEAK_EXTERNAL
;
4689 attr
= (struct attrib
*) xmalloc (sizeof (struct attrib
));
4690 attr
->next
= *attr_list
;
4692 attr
->name
= gnu_arg0
;
4694 /* If we have an argument specified together with an attribute name,
4695 make it a single TREE_VALUE entry in a list of arguments, as GCC
4697 if (gnu_arg1
!= NULL_TREE
)
4698 attr
->args
= build_tree_list (NULL_TREE
, gnu_arg1
);
4700 attr
->args
= NULL_TREE
;
4703 = Present (Next (First (gnat_assoc
)))
4704 ? Expression (Next (First (gnat_assoc
))) : gnat_temp
;
4709 /* Get the unpadded version of a GNAT type. */
4712 get_unpadded_type (Entity_Id gnat_entity
)
4714 tree type
= gnat_to_gnu_type (gnat_entity
);
4716 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
4717 type
= TREE_TYPE (TYPE_FIELDS (type
));
4722 /* Called when we need to protect a variable object using a save_expr. */
4725 maybe_variable (tree gnu_operand
)
4727 if (TREE_CONSTANT (gnu_operand
) || TREE_READONLY (gnu_operand
)
4728 || TREE_CODE (gnu_operand
) == SAVE_EXPR
4729 || TREE_CODE (gnu_operand
) == NULL_EXPR
)
4732 if (TREE_CODE (gnu_operand
) == UNCONSTRAINED_ARRAY_REF
)
4734 tree gnu_result
= build1 (UNCONSTRAINED_ARRAY_REF
,
4735 TREE_TYPE (gnu_operand
),
4736 variable_size (TREE_OPERAND (gnu_operand
, 0)));
4738 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
)
4739 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand
)));
4743 return variable_size (gnu_operand
);
4746 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4747 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4748 return the GCC tree to use for that expression. GNU_NAME is the
4749 qualification to use if an external name is appropriate and DEFINITION is
4750 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4751 we need a result. Otherwise, we are just elaborating this for
4752 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4753 purposes even if it isn't needed for code generation. */
4756 elaborate_expression (Node_Id gnat_expr
, Entity_Id gnat_entity
,
4757 tree gnu_name
, bool definition
, bool need_value
,
4762 /* If we already elaborated this expression (e.g., it was involved
4763 in the definition of a private type), use the old value. */
4764 if (present_gnu_tree (gnat_expr
))
4765 return get_gnu_tree (gnat_expr
);
4767 /* If we don't need a value and this is static or a discriminant, we
4768 don't need to do anything. */
4769 else if (!need_value
4770 && (Is_OK_Static_Expression (gnat_expr
)
4771 || (Nkind (gnat_expr
) == N_Identifier
4772 && Ekind (Entity (gnat_expr
)) == E_Discriminant
)))
4775 /* Otherwise, convert this tree to its GCC equivalent. */
4777 = elaborate_expression_1 (gnat_expr
, gnat_entity
, gnat_to_gnu (gnat_expr
),
4778 gnu_name
, definition
, need_debug
);
4780 /* Save the expression in case we try to elaborate this entity again. Since
4781 this is not a DECL, don't check it. Don't save if it's a discriminant. */
4782 if (!CONTAINS_PLACEHOLDER_P (gnu_expr
))
4783 save_gnu_tree (gnat_expr
, gnu_expr
, true);
4785 return need_value
? gnu_expr
: error_mark_node
;
4788 /* Similar, but take a GNU expression. */
4791 elaborate_expression_1 (Node_Id gnat_expr
, Entity_Id gnat_entity
,
4792 tree gnu_expr
, tree gnu_name
, bool definition
,
4795 tree gnu_decl
= NULL_TREE
;
4796 /* Strip any conversions to see if the expression is a readonly variable.
4797 ??? This really should remain readonly, but we have to think about
4798 the typing of the tree here. */
4799 tree gnu_inner_expr
= remove_conversions (gnu_expr
, true);
4800 bool expr_global
= Is_Public (gnat_entity
) || global_bindings_p ();
4803 /* In most cases, we won't see a naked FIELD_DECL here because a
4804 discriminant reference will have been replaced with a COMPONENT_REF
4805 when the type is being elaborated. However, there are some cases
4806 involving child types where we will. So convert it to a COMPONENT_REF
4807 here. We have to hope it will be at the highest level of the
4808 expression in these cases. */
4809 if (TREE_CODE (gnu_expr
) == FIELD_DECL
)
4810 gnu_expr
= build3 (COMPONENT_REF
, TREE_TYPE (gnu_expr
),
4811 build0 (PLACEHOLDER_EXPR
, DECL_CONTEXT (gnu_expr
)),
4812 gnu_expr
, NULL_TREE
);
4814 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
4815 that is a constant, make a variable that is initialized to contain the
4816 bound when the package containing the definition is elaborated. If
4817 this entity is defined at top level and a bound or discriminant value
4818 isn't a constant or a reference to a discriminant, replace the bound
4819 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
4820 rely here on the fact that an expression cannot contain both the
4821 discriminant and some other variable. */
4823 expr_variable
= (!CONSTANT_CLASS_P (gnu_expr
)
4824 && !(TREE_CODE (gnu_inner_expr
) == VAR_DECL
4825 && (TREE_READONLY (gnu_inner_expr
)
4826 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr
)))
4827 && !CONTAINS_PLACEHOLDER_P (gnu_expr
));
4829 /* If this is a static expression or contains a discriminant, we don't
4830 need the variable for debugging (and can't elaborate anyway if a
4833 && (Is_OK_Static_Expression (gnat_expr
)
4834 || CONTAINS_PLACEHOLDER_P (gnu_expr
)))
4837 /* Now create the variable if we need it. */
4838 if (need_debug
|| (expr_variable
&& expr_global
))
4840 = create_var_decl (create_concat_name (gnat_entity
,
4841 IDENTIFIER_POINTER (gnu_name
)),
4842 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
4843 !need_debug
, Is_Public (gnat_entity
),
4844 !definition
, false, NULL
, gnat_entity
);
4846 /* We only need to use this variable if we are in global context since GCC
4847 can do the right thing in the local case. */
4848 if (expr_global
&& expr_variable
)
4850 else if (!expr_variable
)
4853 return maybe_variable (gnu_expr
);
4856 /* Create a record type that contains a field of TYPE with a starting bit
4857 position so that it is aligned to ALIGN bits and is SIZE bytes long. */
4860 make_aligning_type (tree type
, int align
, tree size
)
4862 tree record_type
= make_node (RECORD_TYPE
);
4863 tree place
= build0 (PLACEHOLDER_EXPR
, record_type
);
4864 tree size_addr_place
= convert (sizetype
,
4865 build_unary_op (ADDR_EXPR
, NULL_TREE
,
4867 tree name
= TYPE_NAME (type
);
4870 if (TREE_CODE (name
) == TYPE_DECL
)
4871 name
= DECL_NAME (name
);
4873 TYPE_NAME (record_type
) = concat_id_with_name (name
, "_ALIGN");
4875 /* The bit position is obtained by "and"ing the alignment minus 1
4876 with the two's complement of the address and multiplying
4877 by the number of bits per unit. Do all this in sizetype. */
4878 pos
= size_binop (MULT_EXPR
,
4879 convert (bitsizetype
,
4880 size_binop (BIT_AND_EXPR
,
4881 size_diffop (size_zero_node
,
4883 ssize_int ((align
/ BITS_PER_UNIT
)
4887 /* Create the field, with -1 as the 'addressable' indication to avoid the
4888 creation of a bitfield. We don't need one, it would have damaging
4889 consequences on the alignment computation, and create_field_decl would
4890 make one without this special argument, for instance because of the
4891 complex position expression. */
4892 field
= create_field_decl (get_identifier ("F"), type
, record_type
, 1, size
,
4895 finish_record_type (record_type
, field
, true, false);
4896 TYPE_ALIGN (record_type
) = BIGGEST_ALIGNMENT
;
4897 TYPE_SIZE (record_type
)
4898 = size_binop (PLUS_EXPR
,
4899 size_binop (MULT_EXPR
, convert (bitsizetype
, size
),
4901 bitsize_int (align
));
4902 TYPE_SIZE_UNIT (record_type
)
4903 = size_binop (PLUS_EXPR
, size
, size_int (align
/ BITS_PER_UNIT
));
4904 copy_alias_set (record_type
, type
);
4908 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
4909 being used as the field type of a packed record. See if we can rewrite it
4910 as a record that has a non-BLKmode type, which we can pack tighter. If so,
4911 return the new type. If not, return the original type. */
4914 make_packable_type (tree type
)
4916 tree new_type
= make_node (TREE_CODE (type
));
4917 tree field_list
= NULL_TREE
;
4920 /* Copy the name and flags from the old type to that of the new and set
4921 the alignment to try for an integral type. For QUAL_UNION_TYPE,
4922 also copy the size. */
4923 TYPE_NAME (new_type
) = TYPE_NAME (type
);
4924 TYPE_JUSTIFIED_MODULAR_P (new_type
)
4925 = TYPE_JUSTIFIED_MODULAR_P (type
);
4926 TYPE_CONTAINS_TEMPLATE_P (new_type
) = TYPE_CONTAINS_TEMPLATE_P (type
);
4928 if (TREE_CODE (type
) == RECORD_TYPE
)
4929 TYPE_IS_PADDING_P (new_type
) = TYPE_IS_PADDING_P (type
);
4930 else if (TREE_CODE (type
) == QUAL_UNION_TYPE
)
4932 TYPE_SIZE (new_type
) = TYPE_SIZE (type
);
4933 TYPE_SIZE_UNIT (new_type
) = TYPE_SIZE_UNIT (type
);
4936 TYPE_ALIGN (new_type
)
4937 = ((HOST_WIDE_INT
) 1
4938 << (floor_log2 (tree_low_cst (TYPE_SIZE (type
), 1) - 1) + 1));
4940 /* Now copy the fields, keeping the position and size. */
4941 for (old_field
= TYPE_FIELDS (type
); old_field
;
4942 old_field
= TREE_CHAIN (old_field
))
4944 tree new_field_type
= TREE_TYPE (old_field
);
4947 if (TYPE_MODE (new_field_type
) == BLKmode
4948 && (TREE_CODE (new_field_type
) == RECORD_TYPE
4949 || TREE_CODE (new_field_type
) == UNION_TYPE
4950 || TREE_CODE (new_field_type
) == QUAL_UNION_TYPE
)
4951 && host_integerp (TYPE_SIZE (new_field_type
), 1))
4952 new_field_type
= make_packable_type (new_field_type
);
4954 new_field
= create_field_decl (DECL_NAME (old_field
), new_field_type
,
4955 new_type
, TYPE_PACKED (type
),
4956 DECL_SIZE (old_field
),
4957 bit_position (old_field
),
4958 !DECL_NONADDRESSABLE_P (old_field
));
4960 DECL_INTERNAL_P (new_field
) = DECL_INTERNAL_P (old_field
);
4961 SET_DECL_ORIGINAL_FIELD
4962 (new_field
, (DECL_ORIGINAL_FIELD (old_field
)
4963 ? DECL_ORIGINAL_FIELD (old_field
) : old_field
));
4965 if (TREE_CODE (new_type
) == QUAL_UNION_TYPE
)
4966 DECL_QUALIFIER (new_field
) = DECL_QUALIFIER (old_field
);
4968 TREE_CHAIN (new_field
) = field_list
;
4969 field_list
= new_field
;
4972 finish_record_type (new_type
, nreverse (field_list
), true, true);
4973 copy_alias_set (new_type
, type
);
4974 return TYPE_MODE (new_type
) == BLKmode
? type
: new_type
;
4977 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
4978 if needed. We have already verified that SIZE and TYPE are large enough.
4980 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
4983 IS_USER_TYPE is true if we must be sure we complete the original type.
4985 DEFINITION is true if this type is being defined.
4987 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
4988 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
4992 maybe_pad_type (tree type
, tree size
, unsigned int align
,
4993 Entity_Id gnat_entity
, const char *name_trailer
,
4994 bool is_user_type
, bool definition
, bool same_rm_size
)
4996 tree orig_size
= TYPE_SIZE (type
);
5000 /* If TYPE is a padded type, see if it agrees with any size and alignment
5001 we were given. If so, return the original type. Otherwise, strip
5002 off the padding, since we will either be returning the inner type
5003 or repadding it. If no size or alignment is specified, use that of
5004 the original padded type. */
5006 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5009 || operand_equal_p (round_up (size
,
5010 MAX (align
, TYPE_ALIGN (type
))),
5011 round_up (TYPE_SIZE (type
),
5012 MAX (align
, TYPE_ALIGN (type
))),
5014 && (align
== 0 || align
== TYPE_ALIGN (type
)))
5018 size
= TYPE_SIZE (type
);
5020 align
= TYPE_ALIGN (type
);
5022 type
= TREE_TYPE (TYPE_FIELDS (type
));
5023 orig_size
= TYPE_SIZE (type
);
5026 /* If the size is either not being changed or is being made smaller (which
5027 is not done here (and is only valid for bitfields anyway), show the size
5028 isn't changing. Likewise, clear the alignment if it isn't being
5029 changed. Then return if we aren't doing anything. */
5032 && (operand_equal_p (size
, orig_size
, 0)
5033 || (TREE_CODE (orig_size
) == INTEGER_CST
5034 && tree_int_cst_lt (size
, orig_size
))))
5037 if (align
== TYPE_ALIGN (type
))
5040 if (align
== 0 && !size
)
5043 /* We used to modify the record in place in some cases, but that could
5044 generate incorrect debugging information. So make a new record
5046 record
= make_node (RECORD_TYPE
);
5048 if (Present (gnat_entity
))
5049 TYPE_NAME (record
) = create_concat_name (gnat_entity
, name_trailer
);
5051 /* If we were making a type, complete the original type and give it a
5054 create_type_decl (get_entity_name (gnat_entity
), type
,
5055 NULL
, !Comes_From_Source (gnat_entity
),
5057 && TREE_CODE (TYPE_NAME (type
)) == TYPE_DECL
5058 && DECL_IGNORED_P (TYPE_NAME (type
))),
5061 /* If we are changing the alignment and the input type is a record with
5062 BLKmode and a small constant size, try to make a form that has an
5063 integral mode. That might allow this record to have an integral mode,
5064 which will be much more efficient. There is no point in doing this if a
5065 size is specified unless it is also smaller than the biggest alignment
5066 and it is incorrect to do this if the size of the original type is not a
5067 multiple of the alignment. */
5069 && TREE_CODE (type
) == RECORD_TYPE
5070 && TYPE_MODE (type
) == BLKmode
5071 && host_integerp (orig_size
, 1)
5072 && compare_tree_int (orig_size
, BIGGEST_ALIGNMENT
) <= 0
5074 || (TREE_CODE (size
) == INTEGER_CST
5075 && compare_tree_int (size
, BIGGEST_ALIGNMENT
) <= 0))
5076 && tree_low_cst (orig_size
, 1) % align
== 0)
5077 type
= make_packable_type (type
);
5079 field
= create_field_decl (get_identifier ("F"), type
, record
, 0,
5080 NULL_TREE
, bitsize_zero_node
, 1);
5082 DECL_INTERNAL_P (field
) = 1;
5083 TYPE_SIZE (record
) = size
? size
: orig_size
;
5084 TYPE_SIZE_UNIT (record
)
5085 = (size
? convert (sizetype
,
5086 size_binop (CEIL_DIV_EXPR
, size
, bitsize_unit_node
))
5087 : TYPE_SIZE_UNIT (type
));
5089 TYPE_ALIGN (record
) = align
;
5090 TYPE_IS_PADDING_P (record
) = 1;
5091 TYPE_VOLATILE (record
)
5092 = Present (gnat_entity
) && Treat_As_Volatile (gnat_entity
);
5093 finish_record_type (record
, field
, true, false);
5095 /* Keep the RM_Size of the padded record as that of the old record
5097 SET_TYPE_ADA_SIZE (record
, same_rm_size
? size
: rm_size (type
));
5099 /* Unless debugging information isn't being written for the input type,
5100 write a record that shows what we are a subtype of and also make a
5101 variable that indicates our size, if variable. */
5102 if (TYPE_NAME (record
) && AGGREGATE_TYPE_P (type
)
5103 && (TREE_CODE (TYPE_NAME (type
)) != TYPE_DECL
5104 || !DECL_IGNORED_P (TYPE_NAME (type
))))
5106 tree marker
= make_node (RECORD_TYPE
);
5107 tree name
= (TREE_CODE (TYPE_NAME (record
)) == TYPE_DECL
5108 ? DECL_NAME (TYPE_NAME (record
))
5109 : TYPE_NAME (record
));
5110 tree orig_name
= TYPE_NAME (type
);
5112 if (TREE_CODE (orig_name
) == TYPE_DECL
)
5113 orig_name
= DECL_NAME (orig_name
);
5115 TYPE_NAME (marker
) = concat_id_with_name (name
, "XVS");
5116 finish_record_type (marker
,
5117 create_field_decl (orig_name
, integer_type_node
,
5118 marker
, 0, NULL_TREE
, NULL_TREE
,
5122 if (size
&& TREE_CODE (size
) != INTEGER_CST
&& definition
)
5123 create_var_decl (concat_id_with_name (name
, "XVZ"), NULL_TREE
,
5124 bitsizetype
, TYPE_SIZE (record
), false, false, false,
5125 false, NULL
, gnat_entity
);
5130 if (CONTAINS_PLACEHOLDER_P (orig_size
))
5131 orig_size
= max_size (orig_size
, true);
5133 /* If the size was widened explicitly, maybe give a warning. */
5134 if (size
&& Present (gnat_entity
)
5135 && !operand_equal_p (size
, orig_size
, 0)
5136 && !(TREE_CODE (size
) == INTEGER_CST
5137 && TREE_CODE (orig_size
) == INTEGER_CST
5138 && tree_int_cst_lt (size
, orig_size
)))
5140 Node_Id gnat_error_node
= Empty
;
5142 if (Is_Packed_Array_Type (gnat_entity
))
5143 gnat_entity
= Associated_Node_For_Itype (gnat_entity
);
5145 if ((Ekind (gnat_entity
) == E_Component
5146 || Ekind (gnat_entity
) == E_Discriminant
)
5147 && Present (Component_Clause (gnat_entity
)))
5148 gnat_error_node
= Last_Bit (Component_Clause (gnat_entity
));
5149 else if (Present (Size_Clause (gnat_entity
)))
5150 gnat_error_node
= Expression (Size_Clause (gnat_entity
));
5152 /* Generate message only for entities that come from source, since
5153 if we have an entity created by expansion, the message will be
5154 generated for some other corresponding source entity. */
5155 if (Comes_From_Source (gnat_entity
) && Present (gnat_error_node
))
5156 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node
,
5158 size_diffop (size
, orig_size
));
5160 else if (*name_trailer
== 'C' && !Is_Internal (gnat_entity
))
5161 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5162 gnat_entity
, gnat_entity
,
5163 size_diffop (size
, orig_size
));
5169 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5170 the value passed against the list of choices. */
5173 choices_to_gnu (tree operand
, Node_Id choices
)
5177 tree result
= integer_zero_node
;
5178 tree this_test
, low
= 0, high
= 0, single
= 0;
5180 for (choice
= First (choices
); Present (choice
); choice
= Next (choice
))
5182 switch (Nkind (choice
))
5185 low
= gnat_to_gnu (Low_Bound (choice
));
5186 high
= gnat_to_gnu (High_Bound (choice
));
5188 /* There's no good type to use here, so we might as well use
5189 integer_type_node. */
5191 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5192 build_binary_op (GE_EXPR
, integer_type_node
,
5194 build_binary_op (LE_EXPR
, integer_type_node
,
5199 case N_Subtype_Indication
:
5200 gnat_temp
= Range_Expression (Constraint (choice
));
5201 low
= gnat_to_gnu (Low_Bound (gnat_temp
));
5202 high
= gnat_to_gnu (High_Bound (gnat_temp
));
5205 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5206 build_binary_op (GE_EXPR
, integer_type_node
,
5208 build_binary_op (LE_EXPR
, integer_type_node
,
5213 case N_Expanded_Name
:
5214 /* This represents either a subtype range, an enumeration
5215 literal, or a constant Ekind says which. If an enumeration
5216 literal or constant, fall through to the next case. */
5217 if (Ekind (Entity (choice
)) != E_Enumeration_Literal
5218 && Ekind (Entity (choice
)) != E_Constant
)
5220 tree type
= gnat_to_gnu_type (Entity (choice
));
5222 low
= TYPE_MIN_VALUE (type
);
5223 high
= TYPE_MAX_VALUE (type
);
5226 = build_binary_op (TRUTH_ANDIF_EXPR
, integer_type_node
,
5227 build_binary_op (GE_EXPR
, integer_type_node
,
5229 build_binary_op (LE_EXPR
, integer_type_node
,
5233 /* ... fall through ... */
5234 case N_Character_Literal
:
5235 case N_Integer_Literal
:
5236 single
= gnat_to_gnu (choice
);
5237 this_test
= build_binary_op (EQ_EXPR
, integer_type_node
, operand
,
5241 case N_Others_Choice
:
5242 this_test
= integer_one_node
;
5249 result
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5256 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5257 placed in GNU_RECORD_TYPE.
5259 PACKED is 1 if the enclosing record is packed and -1 if the enclosing
5260 record has a Component_Alignment of Storage_Unit.
5262 DEFINITION is true if this field is for a record being defined. */
5265 gnat_to_gnu_field (Entity_Id gnat_field
, tree gnu_record_type
, int packed
,
5268 tree gnu_field_id
= get_entity_name (gnat_field
);
5269 tree gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field
));
5273 bool needs_strict_alignment
5274 = (Is_Aliased (gnat_field
) || Strict_Alignment (Etype (gnat_field
))
5275 || Treat_As_Volatile (gnat_field
));
5277 /* If this field requires strict alignment or contains an item of
5278 variable sized, pretend it isn't packed. */
5279 if (needs_strict_alignment
|| is_variable_size (gnu_field_type
))
5282 /* For packed records, this is one of the few occasions on which we use
5283 the official RM size for discrete or fixed-point components, instead
5284 of the normal GNAT size stored in Esize. See description in Einfo:
5285 "Handling of Type'Size Values" for further details. */
5288 gnu_size
= validate_size (RM_Size (Etype (gnat_field
)), gnu_field_type
,
5289 gnat_field
, FIELD_DECL
, false, true);
5291 if (Known_Static_Esize (gnat_field
))
5292 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5293 gnat_field
, FIELD_DECL
, false, true);
5295 /* If we have a specified size that's smaller than that of the field type,
5296 or a position is specified, and the field type is also a record that's
5297 BLKmode and with a small constant size, see if we can get an integral
5298 mode form of the type when appropriate. If we can, show a size was
5299 specified for the field if there wasn't one already, so we know to make
5300 this a bitfield and avoid making things wider.
5302 Doing this is first useful if the record is packed because we can then
5303 place the field at a non-byte-aligned position and so achieve tighter
5306 This is in addition *required* if the field shares a byte with another
5307 field and the front-end lets the back-end handle the references, because
5308 GCC does not handle BLKmode bitfields properly.
5310 We avoid the transformation if it is not required or potentially useful,
5311 as it might entail an increase of the field's alignment and have ripple
5312 effects on the outer record type. A typical case is a field known to be
5313 byte aligned and not to share a byte with another field.
5315 Besides, we don't even look the possibility of a transformation in cases
5316 known to be in error already, for instance when an invalid size results
5317 from a component clause. */
5319 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
5320 && TYPE_MODE (gnu_field_type
) == BLKmode
5321 && host_integerp (TYPE_SIZE (gnu_field_type
), 1)
5322 && compare_tree_int (TYPE_SIZE (gnu_field_type
), BIGGEST_ALIGNMENT
) <= 0
5325 && tree_int_cst_lt (gnu_size
, TYPE_SIZE (gnu_field_type
)))
5326 || (Present (Component_Clause (gnat_field
)) && gnu_size
!= 0)))
5328 /* See what the alternate type and size would be. */
5329 tree gnu_packable_type
= make_packable_type (gnu_field_type
);
5331 bool has_byte_aligned_clause
5332 = Present (Component_Clause (gnat_field
))
5333 && (UI_To_Int (Component_Bit_Offset (gnat_field
))
5334 % BITS_PER_UNIT
== 0);
5336 /* Compute whether we should avoid the substitution. */
5338 /* There is no point substituting if there is no change. */
5339 (gnu_packable_type
== gnu_field_type
5341 /* ... nor when the field is known to be byte aligned and not to
5342 share a byte with another field. */
5343 (has_byte_aligned_clause
5344 && value_factor_p (gnu_size
, BITS_PER_UNIT
))
5346 /* The size of an aliased field must be an exact multiple of the
5347 type's alignment, which the substitution might increase. Reject
5348 substitutions that would so invalidate a component clause when the
5349 specified position is byte aligned, as the change would have no
5350 real benefit from the packing standpoint anyway. */
5351 (Is_Aliased (gnat_field
)
5352 && has_byte_aligned_clause
5353 && ! value_factor_p (gnu_size
, TYPE_ALIGN (gnu_packable_type
)))
5356 /* Substitute unless told otherwise. */
5359 gnu_field_type
= gnu_packable_type
;
5362 gnu_size
= rm_size (gnu_field_type
);
5366 /* If we are packing the record and the field is BLKmode, round the
5367 size up to a byte boundary. */
5368 if (packed
&& TYPE_MODE (gnu_field_type
) == BLKmode
&& gnu_size
)
5369 gnu_size
= round_up (gnu_size
, BITS_PER_UNIT
);
5371 if (Present (Component_Clause (gnat_field
)))
5373 gnu_pos
= UI_To_gnu (Component_Bit_Offset (gnat_field
), bitsizetype
);
5374 gnu_size
= validate_size (Esize (gnat_field
), gnu_field_type
,
5375 gnat_field
, FIELD_DECL
, false, true);
5377 /* Ensure the position does not overlap with the parent subtype,
5379 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field
)))))
5382 = gnat_to_gnu_type (Parent_Subtype
5383 (Underlying_Type (Scope (gnat_field
))));
5385 if (TREE_CODE (TYPE_SIZE (gnu_parent
)) == INTEGER_CST
5386 && tree_int_cst_lt (gnu_pos
, TYPE_SIZE (gnu_parent
)))
5389 ("offset of& must be beyond parent{, minimum allowed is ^}",
5390 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5391 TYPE_SIZE_UNIT (gnu_parent
));
5395 /* If this field needs strict alignment, ensure the record is
5396 sufficiently aligned and that that position and size are
5397 consistent with the alignment. */
5398 if (needs_strict_alignment
)
5400 tree gnu_rounded_size
= round_up (rm_size (gnu_field_type
),
5401 TYPE_ALIGN (gnu_field_type
));
5403 TYPE_ALIGN (gnu_record_type
)
5404 = MAX (TYPE_ALIGN (gnu_record_type
), TYPE_ALIGN (gnu_field_type
));
5406 /* If Atomic, the size must match exactly that of the field. */
5407 if ((Is_Atomic (gnat_field
) || Is_Atomic (Etype (gnat_field
)))
5408 && !operand_equal_p (gnu_size
, TYPE_SIZE (gnu_field_type
), 0))
5411 ("atomic field& must be natural size of type{ (^)}",
5412 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
5413 TYPE_SIZE (gnu_field_type
));
5415 gnu_size
= NULL_TREE
;
5418 /* If Aliased, the size must match exactly the rounded size. We
5419 used to be more accommodating here and accept greater sizes, but
5420 fully supporting this case on big-endian platforms would require
5421 switching to a more involved layout for the field. */
5422 else if (Is_Aliased (gnat_field
)
5424 && ! operand_equal_p (gnu_size
, gnu_rounded_size
, 0))
5427 ("size of aliased field& must be ^ bits",
5428 Last_Bit (Component_Clause (gnat_field
)), gnat_field
,
5430 gnu_size
= NULL_TREE
;
5433 if (!integer_zerop (size_binop
5434 (TRUNC_MOD_EXPR
, gnu_pos
,
5435 bitsize_int (TYPE_ALIGN (gnu_field_type
)))))
5437 if (Is_Aliased (gnat_field
))
5439 ("position of aliased field& must be multiple of ^ bits",
5440 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5441 TYPE_ALIGN (gnu_field_type
));
5443 else if (Treat_As_Volatile (gnat_field
))
5445 ("position of volatile field& must be multiple of ^ bits",
5446 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5447 TYPE_ALIGN (gnu_field_type
));
5449 else if (Strict_Alignment (Etype (gnat_field
)))
5451 ("position of & with aliased or tagged components not multiple of ^ bits",
5452 First_Bit (Component_Clause (gnat_field
)), gnat_field
,
5453 TYPE_ALIGN (gnu_field_type
));
5457 gnu_pos
= NULL_TREE
;
5461 if (Is_Atomic (gnat_field
))
5462 check_ok_for_atomic (gnu_field_type
, gnat_field
, false);
5465 /* If the record has rep clauses and this is the tag field, make a rep
5466 clause for it as well. */
5467 else if (Has_Specified_Layout (Scope (gnat_field
))
5468 && Chars (gnat_field
) == Name_uTag
)
5470 gnu_pos
= bitsize_zero_node
;
5471 gnu_size
= TYPE_SIZE (gnu_field_type
);
5474 /* We need to make the size the maximum for the type if it is
5475 self-referential and an unconstrained type. In that case, we can't
5476 pack the field since we can't make a copy to align it. */
5477 if (TREE_CODE (gnu_field_type
) == RECORD_TYPE
5479 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type
))
5480 && !Is_Constrained (Underlying_Type (Etype (gnat_field
))))
5482 gnu_size
= max_size (TYPE_SIZE (gnu_field_type
), true);
5486 /* If no size is specified (or if there was an error), don't specify a
5489 gnu_pos
= NULL_TREE
;
5492 /* If the field's type is justified modular, we would need to remove
5493 the wrapper to (better) meet the layout requirements. However we
5494 can do so only if the field is not aliased to preserve the unique
5495 layout and if the prescribed size is not greater than that of the
5496 packed array to preserve the justification. */
5497 if (!needs_strict_alignment
5498 && TREE_CODE (gnu_field_type
) == RECORD_TYPE
5499 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type
)
5500 && tree_int_cst_compare (gnu_size
, TYPE_ADA_SIZE (gnu_field_type
))
5502 gnu_field_type
= TREE_TYPE (TYPE_FIELDS (gnu_field_type
));
5505 = make_type_from_size (gnu_field_type
, gnu_size
,
5506 Has_Biased_Representation (gnat_field
));
5507 gnu_field_type
= maybe_pad_type (gnu_field_type
, gnu_size
, 0, gnat_field
,
5508 "PAD", false, definition
, true);
5511 gcc_assert (TREE_CODE (gnu_field_type
) != RECORD_TYPE
5512 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type
));
5514 /* Now create the decl for the field. */
5515 gnu_field
= create_field_decl (gnu_field_id
, gnu_field_type
, gnu_record_type
,
5516 packed
, gnu_size
, gnu_pos
,
5517 Is_Aliased (gnat_field
));
5518 Sloc_to_locus (Sloc (gnat_field
), &DECL_SOURCE_LOCATION (gnu_field
));
5519 TREE_THIS_VOLATILE (gnu_field
) = Treat_As_Volatile (gnat_field
);
5521 if (Ekind (gnat_field
) == E_Discriminant
)
5522 DECL_DISCRIMINANT_NUMBER (gnu_field
)
5523 = UI_To_gnu (Discriminant_Number (gnat_field
), sizetype
);
5528 /* Return true if TYPE is a type with variable size, a padding type with a
5529 field of variable size or is a record that has a field such a field. */
5532 is_variable_size (tree type
)
5536 /* We need not be concerned about this at all if we don't have
5537 strict alignment. */
5538 if (!STRICT_ALIGNMENT
)
5540 else if (!TREE_CONSTANT (TYPE_SIZE (type
)))
5542 else if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
)
5543 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type
))))
5545 else if (TREE_CODE (type
) != RECORD_TYPE
5546 && TREE_CODE (type
) != UNION_TYPE
5547 && TREE_CODE (type
) != QUAL_UNION_TYPE
)
5550 for (field
= TYPE_FIELDS (type
); field
; field
= TREE_CHAIN (field
))
5551 if (is_variable_size (TREE_TYPE (field
)))
5557 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5558 of GCC trees for fields that are in the record and have already been
5559 processed. When called from gnat_to_gnu_entity during the processing of a
5560 record type definition, the GCC nodes for the discriminants will be on
5561 the chain. The other calls to this function are recursive calls from
5562 itself for the Component_List of a variant and the chain is empty.
5564 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is
5565 for a record type with "pragma component_alignment (storage_unit)".
5567 DEFINITION is true if we are defining this record.
5569 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5570 with a rep clause is to be added. If it is nonzero, that is all that
5571 should be done with such fields.
5573 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
5574 laying out the record. This means the alignment only serves to force fields
5575 to be bitfields, but not require the record to be that aligned. This is
5578 ALL_REP, if true, means a rep clause was found for all the fields. This
5579 simplifies the logic since we know we're not in the mixed case.
5581 DEFER_DEBUG, if true, means that the debugging routines should not be
5582 called when finishing constructing the record type.
5584 UNCHECKED_UNION, if tree, means that we are building a type for a record
5585 with a Pragma Unchecked_Union.
5587 The processing of the component list fills in the chain with all of the
5588 fields of the record and then the record type is finished. */
5591 components_to_record (tree gnu_record_type
, Node_Id component_list
,
5592 tree gnu_field_list
, int packed
, bool definition
,
5593 tree
*p_gnu_rep_list
, bool cancel_alignment
,
5594 bool all_rep
, bool defer_debug
, bool unchecked_union
)
5596 Node_Id component_decl
;
5597 Entity_Id gnat_field
;
5598 Node_Id variant_part
;
5599 tree gnu_our_rep_list
= NULL_TREE
;
5600 tree gnu_field
, gnu_last
;
5601 bool layout_with_rep
= false;
5602 bool all_rep_and_size
= all_rep
&& TYPE_SIZE (gnu_record_type
);
5604 /* For each variable within each component declaration create a GCC field
5605 and add it to the list, skipping any pragmas in the list. */
5607 if (Present (Component_Items (component_list
)))
5608 for (component_decl
= First_Non_Pragma (Component_Items (component_list
));
5609 Present (component_decl
);
5610 component_decl
= Next_Non_Pragma (component_decl
))
5612 gnat_field
= Defining_Entity (component_decl
);
5614 if (Chars (gnat_field
) == Name_uParent
)
5615 gnu_field
= tree_last (TYPE_FIELDS (gnu_record_type
));
5618 gnu_field
= gnat_to_gnu_field (gnat_field
, gnu_record_type
,
5619 packed
, definition
);
5621 /* If this is the _Tag field, put it before any discriminants,
5622 instead of after them as is the case for all other fields.
5623 Ignore field of void type if only annotating. */
5624 if (Chars (gnat_field
) == Name_uTag
)
5625 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
5628 TREE_CHAIN (gnu_field
) = gnu_field_list
;
5629 gnu_field_list
= gnu_field
;
5633 save_gnu_tree (gnat_field
, gnu_field
, false);
5636 /* At the end of the component list there may be a variant part. */
5637 variant_part
= Variant_Part (component_list
);
5639 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5640 mutually exclusive and should go in the same memory. To do this we need
5641 to treat each variant as a record whose elements are created from the
5642 component list for the variant. So here we create the records from the
5643 lists for the variants and put them all into the QUAL_UNION_TYPE.
5644 If this is an Unchecked_Union, we make a UNION_TYPE instead or
5645 use GNU_RECORD_TYPE if there are no fields so far. */
5646 if (Present (variant_part
))
5648 tree gnu_discriminant
= gnat_to_gnu (Name (variant_part
));
5650 tree gnu_name
= TYPE_NAME (gnu_record_type
);
5652 = concat_id_with_name (get_identifier (Get_Name_String
5653 (Chars (Name (variant_part
)))),
5655 tree gnu_union_type
;
5656 tree gnu_union_name
;
5657 tree gnu_union_field
;
5658 tree gnu_variant_list
= NULL_TREE
;
5660 if (TREE_CODE (gnu_name
) == TYPE_DECL
)
5661 gnu_name
= DECL_NAME (gnu_name
);
5663 gnu_union_name
= concat_id_with_name (gnu_name
,
5664 IDENTIFIER_POINTER (gnu_var_name
));
5666 if (!gnu_field_list
&& TREE_CODE (gnu_record_type
) == UNION_TYPE
)
5667 gnu_union_type
= gnu_record_type
;
5672 = make_node (unchecked_union
? UNION_TYPE
: QUAL_UNION_TYPE
);
5674 TYPE_NAME (gnu_union_type
) = gnu_union_name
;
5675 TYPE_PACKED (gnu_union_type
) = TYPE_PACKED (gnu_record_type
);
5678 for (variant
= First_Non_Pragma (Variants (variant_part
));
5680 variant
= Next_Non_Pragma (variant
))
5682 tree gnu_variant_type
= make_node (RECORD_TYPE
);
5683 tree gnu_inner_name
;
5686 Get_Variant_Encoding (variant
);
5687 gnu_inner_name
= get_identifier (Name_Buffer
);
5688 TYPE_NAME (gnu_variant_type
)
5689 = concat_id_with_name (gnu_union_name
,
5690 IDENTIFIER_POINTER (gnu_inner_name
));
5692 /* Set the alignment of the inner type in case we need to make
5693 inner objects into bitfields, but then clear it out
5694 so the record actually gets only the alignment required. */
5695 TYPE_ALIGN (gnu_variant_type
) = TYPE_ALIGN (gnu_record_type
);
5696 TYPE_PACKED (gnu_variant_type
) = TYPE_PACKED (gnu_record_type
);
5698 /* Similarly, if the outer record has a size specified and all fields
5699 have record rep clauses, we can propagate the size into the
5701 if (all_rep_and_size
)
5703 TYPE_SIZE (gnu_variant_type
) = TYPE_SIZE (gnu_record_type
);
5704 TYPE_SIZE_UNIT (gnu_variant_type
)
5705 = TYPE_SIZE_UNIT (gnu_record_type
);
5708 /* Create the record for the variant. Note that we defer emitting
5709 debug info for it until after we are sure to actually use it. */
5710 components_to_record (gnu_variant_type
, Component_List (variant
),
5711 NULL_TREE
, packed
, definition
,
5712 &gnu_our_rep_list
, !all_rep_and_size
, all_rep
,
5713 true, unchecked_union
);
5715 gnu_qual
= choices_to_gnu (gnu_discriminant
,
5716 Discrete_Choices (variant
));
5718 Set_Present_Expr (variant
, annotate_value (gnu_qual
));
5720 /* If this is an Unchecked_Union and we have exactly one field,
5721 use that field here. */
5722 if (unchecked_union
&& TYPE_FIELDS (gnu_variant_type
)
5723 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type
)))
5724 gnu_field
= TYPE_FIELDS (gnu_variant_type
);
5727 /* Emit debug info for the record. We used to throw away
5728 empty records but we no longer do that because we need
5729 them to generate complete debug info for the variant;
5730 otherwise, the union type definition will be lacking
5731 the fields associated with these empty variants. */
5732 write_record_type_debug_info (gnu_variant_type
);
5734 gnu_field
= create_field_decl (gnu_inner_name
, gnu_variant_type
,
5737 ? TYPE_SIZE (gnu_record_type
)
5740 ? bitsize_zero_node
: 0),
5743 DECL_INTERNAL_P (gnu_field
) = 1;
5745 if (!unchecked_union
)
5746 DECL_QUALIFIER (gnu_field
) = gnu_qual
;
5749 TREE_CHAIN (gnu_field
) = gnu_variant_list
;
5750 gnu_variant_list
= gnu_field
;
5753 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
5754 if (gnu_variant_list
)
5756 if (all_rep_and_size
)
5758 TYPE_SIZE (gnu_union_type
) = TYPE_SIZE (gnu_record_type
);
5759 TYPE_SIZE_UNIT (gnu_union_type
)
5760 = TYPE_SIZE_UNIT (gnu_record_type
);
5763 finish_record_type (gnu_union_type
, nreverse (gnu_variant_list
),
5764 all_rep_and_size
, false);
5766 /* If GNU_UNION_TYPE is our record type, it means we must have an
5767 Unchecked_Union with no fields. Verify that and, if so, just
5769 if (gnu_union_type
== gnu_record_type
)
5771 gcc_assert (!gnu_field_list
&& unchecked_union
);
5776 = create_field_decl (gnu_var_name
, gnu_union_type
, gnu_record_type
,
5778 all_rep
? TYPE_SIZE (gnu_union_type
) : 0,
5779 all_rep
? bitsize_zero_node
: 0, 0);
5781 DECL_INTERNAL_P (gnu_union_field
) = 1;
5782 TREE_CHAIN (gnu_union_field
) = gnu_field_list
;
5783 gnu_field_list
= gnu_union_field
;
5787 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
5788 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
5789 in a separate pass since we want to handle the discriminants but can't
5790 play with them until we've used them in debugging data above.
5792 ??? Note: if we then reorder them, debugging information will be wrong,
5793 but there's nothing that can be done about this at the moment. */
5795 for (gnu_field
= gnu_field_list
, gnu_last
= NULL_TREE
; gnu_field
; )
5797 if (DECL_FIELD_OFFSET (gnu_field
))
5799 tree gnu_next
= TREE_CHAIN (gnu_field
);
5802 gnu_field_list
= gnu_next
;
5804 TREE_CHAIN (gnu_last
) = gnu_next
;
5806 TREE_CHAIN (gnu_field
) = gnu_our_rep_list
;
5807 gnu_our_rep_list
= gnu_field
;
5808 gnu_field
= gnu_next
;
5812 gnu_last
= gnu_field
;
5813 gnu_field
= TREE_CHAIN (gnu_field
);
5817 /* If we have any items in our rep'ed field list, it is not the case that all
5818 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
5819 set it and ignore the items. */
5820 if (gnu_our_rep_list
&& p_gnu_rep_list
&& !all_rep
)
5821 *p_gnu_rep_list
= chainon (*p_gnu_rep_list
, gnu_our_rep_list
);
5822 else if (gnu_our_rep_list
)
5824 /* Otherwise, sort the fields by bit position and put them into their
5825 own record if we have any fields without rep clauses. */
5827 = (gnu_field_list
? make_node (RECORD_TYPE
) : gnu_record_type
);
5828 int len
= list_length (gnu_our_rep_list
);
5829 tree
*gnu_arr
= (tree
*) alloca (sizeof (tree
) * len
);
5832 for (i
= 0, gnu_field
= gnu_our_rep_list
; gnu_field
;
5833 gnu_field
= TREE_CHAIN (gnu_field
), i
++)
5834 gnu_arr
[i
] = gnu_field
;
5836 qsort (gnu_arr
, len
, sizeof (tree
), compare_field_bitpos
);
5838 /* Put the fields in the list in order of increasing position, which
5839 means we start from the end. */
5840 gnu_our_rep_list
= NULL_TREE
;
5841 for (i
= len
- 1; i
>= 0; i
--)
5843 TREE_CHAIN (gnu_arr
[i
]) = gnu_our_rep_list
;
5844 gnu_our_rep_list
= gnu_arr
[i
];
5845 DECL_CONTEXT (gnu_arr
[i
]) = gnu_rep_type
;
5850 finish_record_type (gnu_rep_type
, gnu_our_rep_list
, true, false);
5851 gnu_field
= create_field_decl (get_identifier ("REP"), gnu_rep_type
,
5852 gnu_record_type
, 0, 0, 0, 1);
5853 DECL_INTERNAL_P (gnu_field
) = 1;
5854 gnu_field_list
= chainon (gnu_field_list
, gnu_field
);
5858 layout_with_rep
= true;
5859 gnu_field_list
= nreverse (gnu_our_rep_list
);
5863 if (cancel_alignment
)
5864 TYPE_ALIGN (gnu_record_type
) = 0;
5866 finish_record_type (gnu_record_type
, nreverse (gnu_field_list
),
5867 layout_with_rep
, defer_debug
);
5870 /* Called via qsort from the above. Returns -1, 1, depending on the
5871 bit positions and ordinals of the two fields. Use DECL_UID to ensure
5875 compare_field_bitpos (const PTR rt1
, const PTR rt2
)
5877 tree
*t1
= (tree
*) rt1
;
5878 tree
*t2
= (tree
*) rt2
;
5880 if (tree_int_cst_equal (bit_position (*t1
), bit_position (*t2
)))
5881 return DECL_UID (*t1
) < DECL_UID (*t2
) ? -1 : 1;
5882 else if (tree_int_cst_lt (bit_position (*t1
), bit_position (*t2
)))
5888 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
5889 placed into an Esize, Component_Bit_Offset, or Component_Size value
5890 in the GNAT tree. */
5893 annotate_value (tree gnu_size
)
5895 int len
= TREE_CODE_LENGTH (TREE_CODE (gnu_size
));
5897 Node_Ref_Or_Val ops
[3], ret
;
5900 struct tree_int_map
**h
= NULL
;
5902 /* See if we've already saved the value for this node. */
5903 if (EXPR_P (gnu_size
))
5905 struct tree_int_map in
;
5906 if (!annotate_value_cache
)
5907 annotate_value_cache
= htab_create_ggc (512, tree_int_map_hash
,
5908 tree_int_map_eq
, 0);
5909 in
.base
.from
= gnu_size
;
5910 h
= (struct tree_int_map
**)
5911 htab_find_slot (annotate_value_cache
, &in
, INSERT
);
5914 return (Node_Ref_Or_Val
) (*h
)->to
;
5917 /* If we do not return inside this switch, TCODE will be set to the
5918 code to use for a Create_Node operand and LEN (set above) will be
5919 the number of recursive calls for us to make. */
5921 switch (TREE_CODE (gnu_size
))
5924 if (TREE_OVERFLOW (gnu_size
))
5927 /* This may have come from a conversion from some smaller type,
5928 so ensure this is in bitsizetype. */
5929 gnu_size
= convert (bitsizetype
, gnu_size
);
5931 /* For negative values, use NEGATE_EXPR of the supplied value. */
5932 if (tree_int_cst_sgn (gnu_size
) < 0)
5934 /* The ridiculous code below is to handle the case of the largest
5935 negative integer. */
5936 tree negative_size
= size_diffop (bitsize_zero_node
, gnu_size
);
5937 bool adjust
= false;
5940 if (TREE_OVERFLOW (negative_size
))
5943 = size_binop (MINUS_EXPR
, bitsize_zero_node
,
5944 size_binop (PLUS_EXPR
, gnu_size
,
5949 temp
= build1 (NEGATE_EXPR
, bitsizetype
, negative_size
);
5951 temp
= build2 (MINUS_EXPR
, bitsizetype
, temp
, bitsize_one_node
);
5953 return annotate_value (temp
);
5956 if (!host_integerp (gnu_size
, 1))
5959 size
= tree_low_cst (gnu_size
, 1);
5961 /* This peculiar test is to make sure that the size fits in an int
5962 on machines where HOST_WIDE_INT is not "int". */
5963 if (tree_low_cst (gnu_size
, 1) == size
)
5964 return UI_From_Int (size
);
5969 /* The only case we handle here is a simple discriminant reference. */
5970 if (TREE_CODE (TREE_OPERAND (gnu_size
, 0)) == PLACEHOLDER_EXPR
5971 && TREE_CODE (TREE_OPERAND (gnu_size
, 1)) == FIELD_DECL
5972 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size
, 1)))
5973 return Create_Node (Discrim_Val
,
5974 annotate_value (DECL_DISCRIMINANT_NUMBER
5975 (TREE_OPERAND (gnu_size
, 1))),
5980 case NOP_EXPR
: case CONVERT_EXPR
: case NON_LVALUE_EXPR
:
5981 return annotate_value (TREE_OPERAND (gnu_size
, 0));
5983 /* Now just list the operations we handle. */
5984 case COND_EXPR
: tcode
= Cond_Expr
; break;
5985 case PLUS_EXPR
: tcode
= Plus_Expr
; break;
5986 case MINUS_EXPR
: tcode
= Minus_Expr
; break;
5987 case MULT_EXPR
: tcode
= Mult_Expr
; break;
5988 case TRUNC_DIV_EXPR
: tcode
= Trunc_Div_Expr
; break;
5989 case CEIL_DIV_EXPR
: tcode
= Ceil_Div_Expr
; break;
5990 case FLOOR_DIV_EXPR
: tcode
= Floor_Div_Expr
; break;
5991 case TRUNC_MOD_EXPR
: tcode
= Trunc_Mod_Expr
; break;
5992 case CEIL_MOD_EXPR
: tcode
= Ceil_Mod_Expr
; break;
5993 case FLOOR_MOD_EXPR
: tcode
= Floor_Mod_Expr
; break;
5994 case EXACT_DIV_EXPR
: tcode
= Exact_Div_Expr
; break;
5995 case NEGATE_EXPR
: tcode
= Negate_Expr
; break;
5996 case MIN_EXPR
: tcode
= Min_Expr
; break;
5997 case MAX_EXPR
: tcode
= Max_Expr
; break;
5998 case ABS_EXPR
: tcode
= Abs_Expr
; break;
5999 case TRUTH_ANDIF_EXPR
: tcode
= Truth_Andif_Expr
; break;
6000 case TRUTH_ORIF_EXPR
: tcode
= Truth_Orif_Expr
; break;
6001 case TRUTH_AND_EXPR
: tcode
= Truth_And_Expr
; break;
6002 case TRUTH_OR_EXPR
: tcode
= Truth_Or_Expr
; break;
6003 case TRUTH_XOR_EXPR
: tcode
= Truth_Xor_Expr
; break;
6004 case TRUTH_NOT_EXPR
: tcode
= Truth_Not_Expr
; break;
6005 case BIT_AND_EXPR
: tcode
= Bit_And_Expr
; break;
6006 case LT_EXPR
: tcode
= Lt_Expr
; break;
6007 case LE_EXPR
: tcode
= Le_Expr
; break;
6008 case GT_EXPR
: tcode
= Gt_Expr
; break;
6009 case GE_EXPR
: tcode
= Ge_Expr
; break;
6010 case EQ_EXPR
: tcode
= Eq_Expr
; break;
6011 case NE_EXPR
: tcode
= Ne_Expr
; break;
6017 /* Now get each of the operands that's relevant for this code. If any
6018 cannot be expressed as a repinfo node, say we can't. */
6019 for (i
= 0; i
< 3; i
++)
6022 for (i
= 0; i
< len
; i
++)
6024 ops
[i
] = annotate_value (TREE_OPERAND (gnu_size
, i
));
6025 if (ops
[i
] == No_Uint
)
6029 ret
= Create_Node (tcode
, ops
[0], ops
[1], ops
[2]);
6031 /* Save the result in the cache. */
6034 *h
= ggc_alloc (sizeof (struct tree_int_map
));
6035 (*h
)->base
.from
= gnu_size
;
6042 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6043 GCC type, set Component_Bit_Offset and Esize to the position and size
6047 annotate_rep (Entity_Id gnat_entity
, tree gnu_type
)
6051 Entity_Id gnat_field
;
6053 /* We operate by first making a list of all fields and their positions
6054 (we can get the sizes easily at any time) by a recursive call
6055 and then update all the sizes into the tree. */
6056 gnu_list
= compute_field_positions (gnu_type
, NULL_TREE
,
6057 size_zero_node
, bitsize_zero_node
,
6060 for (gnat_field
= First_Entity (gnat_entity
); Present (gnat_field
);
6061 gnat_field
= Next_Entity (gnat_field
))
6062 if ((Ekind (gnat_field
) == E_Component
6063 || (Ekind (gnat_field
) == E_Discriminant
6064 && !Is_Unchecked_Union (Scope (gnat_field
)))))
6066 tree parent_offset
= bitsize_zero_node
;
6068 gnu_entry
= purpose_member (gnat_to_gnu_field_decl (gnat_field
),
6073 if (type_annotate_only
&& Is_Tagged_Type (gnat_entity
))
6075 /* In this mode the tag and parent components have not been
6076 generated, so we add the appropriate offset to each
6077 component. For a component appearing in the current
6078 extension, the offset is the size of the parent. */
6079 if (Is_Derived_Type (gnat_entity
)
6080 && Original_Record_Component (gnat_field
) == gnat_field
)
6082 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity
))),
6085 parent_offset
= bitsize_int (POINTER_SIZE
);
6088 Set_Component_Bit_Offset
6091 (size_binop (PLUS_EXPR
,
6092 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry
)),
6093 TREE_VALUE (TREE_VALUE
6094 (TREE_VALUE (gnu_entry
)))),
6097 Set_Esize (gnat_field
,
6098 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry
))));
6100 else if (Is_Tagged_Type (gnat_entity
)
6101 && Is_Derived_Type (gnat_entity
))
6103 /* If there is no gnu_entry, this is an inherited component whose
6104 position is the same as in the parent type. */
6105 Set_Component_Bit_Offset
6107 Component_Bit_Offset (Original_Record_Component (gnat_field
)));
6108 Set_Esize (gnat_field
,
6109 Esize (Original_Record_Component (gnat_field
)));
6114 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6115 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6116 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6117 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6118 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6119 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6123 compute_field_positions (tree gnu_type
, tree gnu_list
, tree gnu_pos
,
6124 tree gnu_bitpos
, unsigned int offset_align
)
6127 tree gnu_result
= gnu_list
;
6129 for (gnu_field
= TYPE_FIELDS (gnu_type
); gnu_field
;
6130 gnu_field
= TREE_CHAIN (gnu_field
))
6132 tree gnu_our_bitpos
= size_binop (PLUS_EXPR
, gnu_bitpos
,
6133 DECL_FIELD_BIT_OFFSET (gnu_field
));
6134 tree gnu_our_offset
= size_binop (PLUS_EXPR
, gnu_pos
,
6135 DECL_FIELD_OFFSET (gnu_field
));
6136 unsigned int our_offset_align
6137 = MIN (offset_align
, DECL_OFFSET_ALIGN (gnu_field
));
6140 = tree_cons (gnu_field
,
6141 tree_cons (gnu_our_offset
,
6142 tree_cons (size_int (our_offset_align
),
6143 gnu_our_bitpos
, NULL_TREE
),
6147 if (DECL_INTERNAL_P (gnu_field
))
6149 = compute_field_positions (TREE_TYPE (gnu_field
), gnu_result
,
6150 gnu_our_offset
, gnu_our_bitpos
,
6157 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6158 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6159 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6160 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6161 for the size of a field. COMPONENT_P is true if we are being called
6162 to process the Component_Size of GNAT_OBJECT. This is used for error
6163 message handling and to indicate to use the object size of GNU_TYPE.
6164 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6165 it means that a size of zero should be treated as an unspecified size. */
6168 validate_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_object
,
6169 enum tree_code kind
, bool component_p
, bool zero_ok
)
6171 Node_Id gnat_error_node
;
6173 = kind
== VAR_DECL
? TYPE_SIZE (gnu_type
) : rm_size (gnu_type
);
6176 /* Find the node to use for errors. */
6177 if ((Ekind (gnat_object
) == E_Component
6178 || Ekind (gnat_object
) == E_Discriminant
)
6179 && Present (Component_Clause (gnat_object
)))
6180 gnat_error_node
= Last_Bit (Component_Clause (gnat_object
));
6181 else if (Present (Size_Clause (gnat_object
)))
6182 gnat_error_node
= Expression (Size_Clause (gnat_object
));
6184 gnat_error_node
= gnat_object
;
6186 /* Return 0 if no size was specified, either because Esize was not Present or
6187 the specified size was zero. */
6188 if (No (uint_size
) || uint_size
== No_Uint
)
6191 /* Get the size as a tree. Give an error if a size was specified, but cannot
6192 be represented as in sizetype. */
6193 size
= UI_To_gnu (uint_size
, bitsizetype
);
6194 if (TREE_OVERFLOW (size
))
6196 post_error_ne (component_p
? "component size of & is too large"
6197 : "size of & is too large",
6198 gnat_error_node
, gnat_object
);
6202 /* Ignore a negative size since that corresponds to our back-annotation.
6203 Also ignore a zero size unless a size clause exists. */
6204 else if (tree_int_cst_sgn (size
) < 0 || (integer_zerop (size
) && !zero_ok
))
6207 /* The size of objects is always a multiple of a byte. */
6208 if (kind
== VAR_DECL
6209 && !integer_zerop (size_binop (TRUNC_MOD_EXPR
, size
, bitsize_unit_node
)))
6212 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6213 gnat_error_node
, gnat_object
);
6215 post_error_ne ("size for& is not a multiple of Storage_Unit",
6216 gnat_error_node
, gnat_object
);
6220 /* If this is an integral type or a packed array type, the front-end has
6221 verified the size, so we need not do it here (which would entail
6222 checking against the bounds). However, if this is an aliased object, it
6223 may not be smaller than the type of the object. */
6224 if ((INTEGRAL_TYPE_P (gnu_type
) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type
))
6225 && !(kind
== VAR_DECL
&& Is_Aliased (gnat_object
)))
6228 /* If the object is a record that contains a template, add the size of
6229 the template to the specified size. */
6230 if (TREE_CODE (gnu_type
) == RECORD_TYPE
6231 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
6232 size
= size_binop (PLUS_EXPR
, DECL_SIZE (TYPE_FIELDS (gnu_type
)), size
);
6234 /* Modify the size of the type to be that of the maximum size if it has a
6235 discriminant or the size of a thin pointer if this is a fat pointer. */
6236 if (type_size
&& CONTAINS_PLACEHOLDER_P (type_size
))
6237 type_size
= max_size (type_size
, true);
6238 else if (TYPE_FAT_POINTER_P (gnu_type
))
6239 type_size
= bitsize_int (POINTER_SIZE
);
6241 /* If this is an access type, the minimum size is that given by the smallest
6242 integral mode that's valid for pointers. */
6243 if (TREE_CODE (gnu_type
) == POINTER_TYPE
)
6245 enum machine_mode p_mode
;
6247 for (p_mode
= GET_CLASS_NARROWEST_MODE (MODE_INT
);
6248 !targetm
.valid_pointer_mode (p_mode
);
6249 p_mode
= GET_MODE_WIDER_MODE (p_mode
))
6252 type_size
= bitsize_int (GET_MODE_BITSIZE (p_mode
));
6255 /* If the size of the object is a constant, the new size must not be
6257 if (TREE_CODE (type_size
) != INTEGER_CST
6258 || TREE_OVERFLOW (type_size
)
6259 || tree_int_cst_lt (size
, type_size
))
6263 ("component size for& too small{, minimum allowed is ^}",
6264 gnat_error_node
, gnat_object
, type_size
);
6266 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
6267 gnat_error_node
, gnat_object
, type_size
);
6269 if (kind
== VAR_DECL
&& !component_p
6270 && TREE_CODE (rm_size (gnu_type
)) == INTEGER_CST
6271 && !tree_int_cst_lt (size
, rm_size (gnu_type
)))
6272 post_error_ne_tree_2
6273 ("\\size of ^ is not a multiple of alignment (^ bits)",
6274 gnat_error_node
, gnat_object
, rm_size (gnu_type
),
6275 TYPE_ALIGN (gnu_type
));
6277 else if (INTEGRAL_TYPE_P (gnu_type
))
6278 post_error_ne ("\\size would be legal if & were not aliased!",
6279 gnat_error_node
, gnat_object
);
6287 /* Similarly, but both validate and process a value of RM_Size. This
6288 routine is only called for types. */
6291 set_rm_size (Uint uint_size
, tree gnu_type
, Entity_Id gnat_entity
)
6293 /* Only give an error if a Value_Size clause was explicitly given.
6294 Otherwise, we'd be duplicating an error on the Size clause. */
6295 Node_Id gnat_attr_node
6296 = Get_Attribute_Definition_Clause (gnat_entity
, Attr_Value_Size
);
6297 tree old_size
= rm_size (gnu_type
);
6300 /* Get the size as a tree. Do nothing if none was specified, either
6301 because RM_Size was not Present or if the specified size was zero.
6302 Give an error if a size was specified, but cannot be represented as
6304 if (No (uint_size
) || uint_size
== No_Uint
)
6307 size
= UI_To_gnu (uint_size
, bitsizetype
);
6308 if (TREE_OVERFLOW (size
))
6310 if (Present (gnat_attr_node
))
6311 post_error_ne ("Value_Size of & is too large", gnat_attr_node
,
6317 /* Ignore a negative size since that corresponds to our back-annotation.
6318 Also ignore a zero size unless a size clause exists, a Value_Size
6319 clause exists, or this is an integer type, in which case the
6320 front end will have always set it. */
6321 else if (tree_int_cst_sgn (size
) < 0
6322 || (integer_zerop (size
) && No (gnat_attr_node
)
6323 && !Has_Size_Clause (gnat_entity
)
6324 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity
)))
6327 /* If the old size is self-referential, get the maximum size. */
6328 if (CONTAINS_PLACEHOLDER_P (old_size
))
6329 old_size
= max_size (old_size
, true);
6331 /* If the size of the object is a constant, the new size must not be
6332 smaller (the front end checks this for scalar types). */
6333 if (TREE_CODE (old_size
) != INTEGER_CST
6334 || TREE_OVERFLOW (old_size
)
6335 || (AGGREGATE_TYPE_P (gnu_type
)
6336 && tree_int_cst_lt (size
, old_size
)))
6338 if (Present (gnat_attr_node
))
6340 ("Value_Size for& too small{, minimum allowed is ^}",
6341 gnat_attr_node
, gnat_entity
, old_size
);
6346 /* Otherwise, set the RM_Size. */
6347 if (TREE_CODE (gnu_type
) == INTEGER_TYPE
6348 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity
))
6349 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6350 else if (TREE_CODE (gnu_type
) == ENUMERAL_TYPE
)
6351 TYPE_RM_SIZE_NUM (gnu_type
) = size
;
6352 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
6353 || TREE_CODE (gnu_type
) == UNION_TYPE
6354 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
6355 && !TYPE_IS_FAT_POINTER_P (gnu_type
))
6356 SET_TYPE_ADA_SIZE (gnu_type
, size
);
6359 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
6360 If TYPE is the best type, return it. Otherwise, make a new type. We
6361 only support new integral and pointer types. BIASED_P is nonzero if
6362 we are making a biased type. */
6365 make_type_from_size (tree type
, tree size_tree
, bool biased_p
)
6368 unsigned HOST_WIDE_INT size
;
6371 /* If size indicates an error, just return TYPE to avoid propagating the
6372 error. Likewise if it's too large to represent. */
6373 if (!size_tree
|| !host_integerp (size_tree
, 1))
6376 size
= tree_low_cst (size_tree
, 1);
6377 switch (TREE_CODE (type
))
6381 /* Only do something if the type is not already the proper size and is
6382 not a packed array type. */
6383 if (TYPE_PACKED_ARRAY_TYPE_P (type
)
6384 || (TYPE_PRECISION (type
) == size
6385 && biased_p
== (TREE_CODE (type
) == INTEGER_CST
6386 && TYPE_BIASED_REPRESENTATION_P (type
))))
6389 biased_p
|= (TREE_CODE (type
) == INTEGER_TYPE
6390 && TYPE_BIASED_REPRESENTATION_P (type
));
6391 unsigned_p
= TYPE_UNSIGNED (type
) || biased_p
;
6393 size
= MIN (size
, LONG_LONG_TYPE_SIZE
);
6395 = unsigned_p
? make_unsigned_type (size
) : make_signed_type (size
);
6396 TREE_TYPE (new_type
) = TREE_TYPE (type
) ? TREE_TYPE (type
) : type
;
6397 TYPE_MIN_VALUE (new_type
)
6398 = convert (TREE_TYPE (new_type
), TYPE_MIN_VALUE (type
));
6399 TYPE_MAX_VALUE (new_type
)
6400 = convert (TREE_TYPE (new_type
), TYPE_MAX_VALUE (type
));
6401 TYPE_BIASED_REPRESENTATION_P (new_type
) = biased_p
;
6402 TYPE_RM_SIZE_NUM (new_type
) = bitsize_int (size
);
6406 /* Do something if this is a fat pointer, in which case we
6407 may need to return the thin pointer. */
6408 if (TYPE_IS_FAT_POINTER_P (type
) && size
< POINTER_SIZE
* 2)
6411 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type
)));
6415 /* Only do something if this is a thin pointer, in which case we
6416 may need to return the fat pointer. */
6417 if (TYPE_THIN_POINTER_P (type
) && size
>= POINTER_SIZE
* 2)
6419 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)));
6430 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6431 a type or object whose present alignment is ALIGN. If this alignment is
6432 valid, return it. Otherwise, give an error and return ALIGN. */
6435 validate_alignment (Uint alignment
, Entity_Id gnat_entity
, unsigned int align
)
6437 Node_Id gnat_error_node
= gnat_entity
;
6438 unsigned int new_align
;
6440 #ifndef MAX_OFILE_ALIGNMENT
6441 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
6444 if (Present (Alignment_Clause (gnat_entity
)))
6445 gnat_error_node
= Expression (Alignment_Clause (gnat_entity
));
6447 /* Don't worry about checking alignment if alignment was not specified
6448 by the source program and we already posted an error for this entity. */
6450 if (Error_Posted (gnat_entity
) && !Has_Alignment_Clause (gnat_entity
))
6453 /* Within GCC, an alignment is an integer, so we must make sure a
6454 value is specified that fits in that range. Also, alignments of
6455 more than MAX_OFILE_ALIGNMENT can't be supported. */
6457 if (! UI_Is_In_Int_Range (alignment
)
6458 || ((new_align
= UI_To_Int (alignment
))
6459 > MAX_OFILE_ALIGNMENT
/ BITS_PER_UNIT
))
6460 post_error_ne_num ("largest supported alignment for& is ^",
6461 gnat_error_node
, gnat_entity
,
6462 MAX_OFILE_ALIGNMENT
/ BITS_PER_UNIT
);
6463 else if (!(Present (Alignment_Clause (gnat_entity
))
6464 && From_At_Mod (Alignment_Clause (gnat_entity
)))
6465 && new_align
* BITS_PER_UNIT
< align
)
6466 post_error_ne_num ("alignment for& must be at least ^",
6467 gnat_error_node
, gnat_entity
,
6468 align
/ BITS_PER_UNIT
);
6470 align
= MAX (align
, new_align
== 0 ? 1 : new_align
* BITS_PER_UNIT
);
6475 /* Verify that OBJECT, a type or decl, is something we can implement
6476 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
6477 if we require atomic components. */
6480 check_ok_for_atomic (tree object
, Entity_Id gnat_entity
, bool comp_p
)
6482 Node_Id gnat_error_point
= gnat_entity
;
6484 enum machine_mode mode
;
6488 /* There are three case of what OBJECT can be. It can be a type, in which
6489 case we take the size, alignment and mode from the type. It can be a
6490 declaration that was indirect, in which case the relevant values are
6491 that of the type being pointed to, or it can be a normal declaration,
6492 in which case the values are of the decl. The code below assumes that
6493 OBJECT is either a type or a decl. */
6494 if (TYPE_P (object
))
6496 mode
= TYPE_MODE (object
);
6497 align
= TYPE_ALIGN (object
);
6498 size
= TYPE_SIZE (object
);
6500 else if (DECL_BY_REF_P (object
))
6502 mode
= TYPE_MODE (TREE_TYPE (TREE_TYPE (object
)));
6503 align
= TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object
)));
6504 size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (object
)));
6508 mode
= DECL_MODE (object
);
6509 align
= DECL_ALIGN (object
);
6510 size
= DECL_SIZE (object
);
6513 /* Consider all floating-point types atomic and any types that that are
6514 represented by integers no wider than a machine word. */
6515 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
6516 || ((GET_MODE_CLASS (mode
) == MODE_INT
6517 || GET_MODE_CLASS (mode
) == MODE_PARTIAL_INT
)
6518 && GET_MODE_BITSIZE (mode
) <= BITS_PER_WORD
))
6521 /* For the moment, also allow anything that has an alignment equal
6522 to its size and which is smaller than a word. */
6523 if (size
&& TREE_CODE (size
) == INTEGER_CST
6524 && compare_tree_int (size
, align
) == 0
6525 && align
<= BITS_PER_WORD
)
6528 for (gnat_node
= First_Rep_Item (gnat_entity
); Present (gnat_node
);
6529 gnat_node
= Next_Rep_Item (gnat_node
))
6531 if (!comp_p
&& Nkind (gnat_node
) == N_Pragma
6532 && Get_Pragma_Id (Chars (gnat_node
)) == Pragma_Atomic
)
6533 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
6534 else if (comp_p
&& Nkind (gnat_node
) == N_Pragma
6535 && (Get_Pragma_Id (Chars (gnat_node
))
6536 == Pragma_Atomic_Components
))
6537 gnat_error_point
= First (Pragma_Argument_Associations (gnat_node
));
6541 post_error_ne ("atomic access to component of & cannot be guaranteed",
6542 gnat_error_point
, gnat_entity
);
6544 post_error_ne ("atomic access to & cannot be guaranteed",
6545 gnat_error_point
, gnat_entity
);
6548 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
6549 have compatible signatures so that a call using one type may be safely
6550 issued if the actual target function type is the other. Return 1 if it is
6551 the case, 0 otherwise, and post errors on the incompatibilities.
6553 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
6554 that calls to the subprogram will have arguments suitable for the later
6555 underlying builtin expansion. */
6558 compatible_signatures_p (tree ftype1
, tree ftype2
)
6560 /* As of now, we only perform very trivial tests and consider it's the
6561 programmer's responsibility to ensure the type correctness in the Ada
6562 declaration, as in the regular Import cases.
6564 Mismatches typically result in either error messages from the builtin
6565 expander, internal compiler errors, or in a real call sequence. This
6566 should be refined to issue diagnostics helping error detection and
6569 /* Almost fake test, ensuring a use of each argument. */
6570 if (ftype1
== ftype2
)
6576 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type
6577 with all size expressions that contain F updated by replacing F with R.
6578 This is identical to GCC's substitute_in_type except that it knows about
6579 TYPE_INDEX_TYPE. If F is NULL_TREE, always make a new RECORD_TYPE, even if
6580 nothing has changed. */
6583 gnat_substitute_in_type (tree t
, tree f
, tree r
)
6588 switch (TREE_CODE (t
))
6593 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
6594 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
6596 tree low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
6597 tree high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
6599 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
6602 new = build_range_type (TREE_TYPE (t
), low
, high
);
6603 if (TYPE_INDEX_TYPE (t
))
6605 (new, gnat_substitute_in_type (TYPE_INDEX_TYPE (t
), f
, r
));
6612 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t
))
6613 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t
)))
6615 tree low
= NULL_TREE
, high
= NULL_TREE
;
6617 if (TYPE_MIN_VALUE (t
))
6618 low
= SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t
), f
, r
);
6619 if (TYPE_MAX_VALUE (t
))
6620 high
= SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t
), f
, r
);
6622 if (low
== TYPE_MIN_VALUE (t
) && high
== TYPE_MAX_VALUE (t
))
6626 TYPE_MIN_VALUE (t
) = low
;
6627 TYPE_MAX_VALUE (t
) = high
;
6632 tem
= gnat_substitute_in_type (TREE_TYPE (t
), f
, r
);
6633 if (tem
== TREE_TYPE (t
))
6636 return build_complex_type (tem
);
6642 /* Don't know how to do these yet. */
6647 tree component
= gnat_substitute_in_type (TREE_TYPE (t
), f
, r
);
6648 tree domain
= gnat_substitute_in_type (TYPE_DOMAIN (t
), f
, r
);
6650 if (component
== TREE_TYPE (t
) && domain
== TYPE_DOMAIN (t
))
6653 new = build_array_type (component
, domain
);
6654 TYPE_SIZE (new) = 0;
6655 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t
);
6656 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t
);
6658 TYPE_ALIGN (new) = TYPE_ALIGN (t
);
6660 /* If we had bounded the sizes of T by a constant, bound the sizes of
6661 NEW by the same constant. */
6662 if (TREE_CODE (TYPE_SIZE (t
)) == MIN_EXPR
)
6664 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE (t
), 1),
6666 if (TREE_CODE (TYPE_SIZE_UNIT (t
)) == MIN_EXPR
)
6667 TYPE_SIZE_UNIT (new)
6668 = size_binop (MIN_EXPR
, TREE_OPERAND (TYPE_SIZE_UNIT (t
), 1),
6669 TYPE_SIZE_UNIT (new));
6675 case QUAL_UNION_TYPE
:
6679 = (f
== NULL_TREE
&& !TREE_CONSTANT (TYPE_SIZE (t
)));
6680 bool field_has_rep
= false;
6681 tree last_field
= NULL_TREE
;
6683 tree
new = copy_type (t
);
6685 /* Start out with no fields, make new fields, and chain them
6686 in. If we haven't actually changed the type of any field,
6687 discard everything we've done and return the old type. */
6689 TYPE_FIELDS (new) = NULL_TREE
;
6690 TYPE_SIZE (new) = NULL_TREE
;
6692 for (field
= TYPE_FIELDS (t
); field
; field
= TREE_CHAIN (field
))
6694 tree new_field
= copy_node (field
);
6696 TREE_TYPE (new_field
)
6697 = gnat_substitute_in_type (TREE_TYPE (new_field
), f
, r
);
6699 if (DECL_HAS_REP_P (field
) && !DECL_INTERNAL_P (field
))
6700 field_has_rep
= true;
6701 else if (TREE_TYPE (new_field
) != TREE_TYPE (field
))
6702 changed_field
= true;
6704 /* If this is an internal field and the type of this field is
6705 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
6706 the type just has one element, treat that as the field.
6707 But don't do this if we are processing a QUAL_UNION_TYPE. */
6708 if (TREE_CODE (t
) != QUAL_UNION_TYPE
6709 && DECL_INTERNAL_P (new_field
)
6710 && (TREE_CODE (TREE_TYPE (new_field
)) == UNION_TYPE
6711 || TREE_CODE (TREE_TYPE (new_field
)) == RECORD_TYPE
))
6713 if (!TYPE_FIELDS (TREE_TYPE (new_field
)))
6716 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field
))))
6719 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field
)));
6721 /* Make sure omitting the union doesn't change
6723 DECL_ALIGN (next_new_field
) = DECL_ALIGN (new_field
);
6724 new_field
= next_new_field
;
6728 DECL_CONTEXT (new_field
) = new;
6729 SET_DECL_ORIGINAL_FIELD (new_field
,
6730 (DECL_ORIGINAL_FIELD (field
)
6731 ? DECL_ORIGINAL_FIELD (field
) : field
));
6733 /* If the size of the old field was set at a constant,
6734 propagate the size in case the type's size was variable.
6735 (This occurs in the case of a variant or discriminated
6736 record with a default size used as a field of another
6738 DECL_SIZE (new_field
)
6739 = TREE_CODE (DECL_SIZE (field
)) == INTEGER_CST
6740 ? DECL_SIZE (field
) : NULL_TREE
;
6741 DECL_SIZE_UNIT (new_field
)
6742 = TREE_CODE (DECL_SIZE_UNIT (field
)) == INTEGER_CST
6743 ? DECL_SIZE_UNIT (field
) : NULL_TREE
;
6745 if (TREE_CODE (t
) == QUAL_UNION_TYPE
)
6747 tree new_q
= SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field
), f
, r
);
6749 if (new_q
!= DECL_QUALIFIER (new_field
))
6750 changed_field
= true;
6752 /* Do the substitution inside the qualifier and if we find
6753 that this field will not be present, omit it. */
6754 DECL_QUALIFIER (new_field
) = new_q
;
6756 if (integer_zerop (DECL_QUALIFIER (new_field
)))
6761 TYPE_FIELDS (new) = new_field
;
6763 TREE_CHAIN (last_field
) = new_field
;
6765 last_field
= new_field
;
6767 /* If this is a qualified type and this field will always be
6768 present, we are done. */
6769 if (TREE_CODE (t
) == QUAL_UNION_TYPE
6770 && integer_onep (DECL_QUALIFIER (new_field
)))
6774 /* If this used to be a qualified union type, but we now know what
6775 field will be present, make this a normal union. */
6776 if (changed_field
&& TREE_CODE (new) == QUAL_UNION_TYPE
6777 && (!TYPE_FIELDS (new)
6778 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
6779 TREE_SET_CODE (new, UNION_TYPE
);
6780 else if (!changed_field
)
6783 gcc_assert (!field_has_rep
);
6786 /* If the size was originally a constant use it. */
6787 if (TYPE_SIZE (t
) && TREE_CODE (TYPE_SIZE (t
)) == INTEGER_CST
6788 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST
)
6790 TYPE_SIZE (new) = TYPE_SIZE (t
);
6791 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t
);
6792 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t
));
6803 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
6804 needed to represent the object. */
6807 rm_size (tree gnu_type
)
6809 /* For integer types, this is the precision. For record types, we store
6810 the size explicitly. For other types, this is just the size. */
6812 if (INTEGRAL_TYPE_P (gnu_type
) && TYPE_RM_SIZE (gnu_type
))
6813 return TYPE_RM_SIZE (gnu_type
);
6814 else if (TREE_CODE (gnu_type
) == RECORD_TYPE
6815 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
6816 /* Return the rm_size of the actual data plus the size of the template. */
6818 size_binop (PLUS_EXPR
,
6819 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)))),
6820 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
6821 else if ((TREE_CODE (gnu_type
) == RECORD_TYPE
6822 || TREE_CODE (gnu_type
) == UNION_TYPE
6823 || TREE_CODE (gnu_type
) == QUAL_UNION_TYPE
)
6824 && !TYPE_IS_FAT_POINTER_P (gnu_type
)
6825 && TYPE_ADA_SIZE (gnu_type
))
6826 return TYPE_ADA_SIZE (gnu_type
);
6828 return TYPE_SIZE (gnu_type
);
6831 /* Return an identifier representing the external name to be used for
6832 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
6833 and the specified suffix. */
6836 create_concat_name (Entity_Id gnat_entity
, const char *suffix
)
6838 Entity_Kind kind
= Ekind (gnat_entity
);
6840 const char *str
= (!suffix
? "" : suffix
);
6841 String_Template temp
= {1, strlen (str
)};
6842 Fat_Pointer fp
= {str
, &temp
};
6844 Get_External_Name_With_Suffix (gnat_entity
, fp
);
6846 /* A variable using the Stdcall convention (meaning we are running
6847 on a Windows box) live in a DLL. Here we adjust its name to use
6848 the jump-table, the _imp__NAME contains the address for the NAME
6850 if ((kind
== E_Variable
|| kind
== E_Constant
)
6851 && Has_Stdcall_Convention (gnat_entity
))
6853 const char *prefix
= "_imp__";
6854 int k
, plen
= strlen (prefix
);
6856 for (k
= 0; k
<= Name_Len
; k
++)
6857 Name_Buffer
[Name_Len
- k
+ plen
] = Name_Buffer
[Name_Len
- k
];
6858 strncpy (Name_Buffer
, prefix
, plen
);
6861 return get_identifier (Name_Buffer
);
6864 /* Return the name to be used for GNAT_ENTITY. If a type, create a
6865 fully-qualified name, possibly with type information encoding.
6866 Otherwise, return the name. */
6869 get_entity_name (Entity_Id gnat_entity
)
6871 Get_Encoded_Name (gnat_entity
);
6872 return get_identifier (Name_Buffer
);
6875 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
6876 string, return a new IDENTIFIER_NODE that is the concatenation of
6877 the name in GNU_ID and SUFFIX. */
6880 concat_id_with_name (tree gnu_id
, const char *suffix
)
6882 int len
= IDENTIFIER_LENGTH (gnu_id
);
6884 strncpy (Name_Buffer
, IDENTIFIER_POINTER (gnu_id
),
6885 IDENTIFIER_LENGTH (gnu_id
));
6886 strncpy (Name_Buffer
+ len
, "___", 3);
6888 strcpy (Name_Buffer
+ len
, suffix
);
6889 return get_identifier (Name_Buffer
);
6892 #include "gt-ada-decl.h"