1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
35 #include "tree-inline.h"
53 /* Convention_Stdcall should be processed in a specific way on 32 bits
54 Windows targets only. The macro below is a helper to avoid having to
55 check for a Windows specific attribute throughout this unit. */
57 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
59 #define Has_Stdcall_Convention(E) \
60 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
62 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Stdcall_Convention(E) 0
68 /* Stack realignment is necessary for functions with foreign conventions when
69 the ABI doesn't mandate as much as what the compiler assumes - that is, up
70 to PREFERRED_STACK_BOUNDARY.
72 Such realignment can be requested with a dedicated function type attribute
73 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
74 characterize the situations where the attribute should be set. We rely on
75 compiler configuration settings for 'main' to decide. */
77 #ifdef MAIN_STACK_BOUNDARY
78 #define FOREIGN_FORCE_REALIGN_STACK \
79 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
81 #define FOREIGN_FORCE_REALIGN_STACK 0
86 struct incomplete *next;
91 /* These variables are used to defer recursively expanding incomplete types
92 while we are processing an array, a record or a subprogram type. */
93 static int defer_incomplete_level = 0;
94 static struct incomplete *defer_incomplete_list;
96 /* This variable is used to delay expanding From_With_Type types until the
98 static struct incomplete *defer_limited_with;
100 /* These variables are used to defer finalizing types. The element of the
101 list is the TYPE_DECL associated with the type. */
102 static int defer_finalize_level = 0;
103 static VEC (tree,heap) *defer_finalize_list;
105 typedef struct subst_pair_d {
110 DEF_VEC_O(subst_pair);
111 DEF_VEC_ALLOC_O(subst_pair,heap);
113 typedef struct variant_desc_d {
114 /* The type of the variant. */
117 /* The associated field. */
120 /* The value of the qualifier. */
123 /* The record associated with this variant. */
127 DEF_VEC_O(variant_desc);
128 DEF_VEC_ALLOC_O(variant_desc,heap);
130 /* A hash table used to cache the result of annotate_value. */
131 static GTY ((if_marked ("tree_int_map_marked_p"),
132 param_is (struct tree_int_map))) htab_t annotate_value_cache;
141 static void relate_alias_sets (tree, tree, enum alias_set_op);
143 static bool allocatable_size_p (tree, bool);
144 static void prepend_one_attribute_to (struct attrib **,
145 enum attr_type, tree, tree, Node_Id);
146 static void prepend_attributes (Entity_Id, struct attrib **);
147 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
148 static bool type_has_variable_size (tree);
149 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
150 static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool,
152 static tree make_packable_type (tree, bool);
153 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
154 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
156 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
157 static bool same_discriminant_p (Entity_Id, Entity_Id);
158 static bool array_type_has_nonaliased_component (tree, Entity_Id);
159 static bool compile_time_known_address_p (Node_Id);
160 static bool cannot_be_superflat_p (Node_Id);
161 static bool constructor_address_p (tree);
162 static void components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
163 bool, bool, bool, bool, bool, tree, tree *);
164 static Uint annotate_value (tree);
165 static void annotate_rep (Entity_Id, tree);
166 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
167 static VEC(subst_pair,heap) *build_subst_list (Entity_Id, Entity_Id, bool);
168 static VEC(variant_desc,heap) *build_variant_list (tree,
169 VEC(subst_pair,heap) *,
170 VEC(variant_desc,heap) *);
171 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
172 static void set_rm_size (Uint, tree, Entity_Id);
173 static tree make_type_from_size (tree, tree, bool);
174 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
175 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
176 static void check_ok_for_atomic (tree, Entity_Id, bool);
177 static tree create_field_decl_from (tree, tree, tree, tree, tree,
178 VEC(subst_pair,heap) *);
179 static tree create_rep_part (tree, tree, tree);
180 static tree get_rep_part (tree);
181 static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree,
182 tree, VEC(subst_pair,heap) *);
183 static void copy_and_substitute_in_size (tree, tree, VEC(subst_pair,heap) *);
184 static void rest_of_type_decl_compilation_no_defer (tree);
186 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
187 to pass around calls performing profile compatibility checks. */
190 Entity_Id gnat_entity; /* The Ada subprogram entity. */
191 tree ada_fntype; /* The corresponding GCC type node. */
192 tree btin_fntype; /* The GCC builtin function type node. */
195 static bool intrin_profiles_compatible_p (intrin_binding_t *);
197 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
198 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
199 and associate the ..._DECL node with the input GNAT defining identifier.
201 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
202 initial value (in GCC tree form). This is optional for a variable. For
203 a renamed entity, GNU_EXPR gives the object being renamed.
205 DEFINITION is nonzero if this call is intended for a definition. This is
206 used for separate compilation where it is necessary to know whether an
207 external declaration or a definition must be created if the GCC equivalent
208 was not created previously. The value of 1 is normally used for a nonzero
209 DEFINITION, but a value of 2 is used in special circumstances, defined in
213 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
215 /* Contains the kind of the input GNAT node. */
216 const Entity_Kind kind = Ekind (gnat_entity);
217 /* True if this is a type. */
218 const bool is_type = IN (kind, Type_Kind);
219 /* True if debug info is requested for this entity. */
220 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
221 /* True if this entity is to be considered as imported. */
222 const bool imported_p
223 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
224 /* For a type, contains the equivalent GNAT node to be used in gigi. */
225 Entity_Id gnat_equiv_type = Empty;
226 /* Temporary used to walk the GNAT tree. */
228 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
229 This node will be associated with the GNAT node by calling at the end
230 of the `switch' statement. */
231 tree gnu_decl = NULL_TREE;
232 /* Contains the GCC type to be used for the GCC node. */
233 tree gnu_type = NULL_TREE;
234 /* Contains the GCC size tree to be used for the GCC node. */
235 tree gnu_size = NULL_TREE;
236 /* Contains the GCC name to be used for the GCC node. */
237 tree gnu_entity_name;
238 /* True if we have already saved gnu_decl as a GNAT association. */
240 /* True if we incremented defer_incomplete_level. */
241 bool this_deferred = false;
242 /* True if we incremented force_global. */
243 bool this_global = false;
244 /* True if we should check to see if elaborated during processing. */
245 bool maybe_present = false;
246 /* True if we made GNU_DECL and its type here. */
247 bool this_made_decl = false;
248 /* Size and alignment of the GCC node, if meaningful. */
249 unsigned int esize = 0, align = 0;
250 /* Contains the list of attributes directly attached to the entity. */
251 struct attrib *attr_list = NULL;
253 /* Since a use of an Itype is a definition, process it as such if it
254 is not in a with'ed unit. */
257 && Is_Itype (gnat_entity)
258 && !present_gnu_tree (gnat_entity)
259 && In_Extended_Main_Code_Unit (gnat_entity))
261 /* Ensure that we are in a subprogram mentioned in the Scope chain of
262 this entity, our current scope is global, or we encountered a task
263 or entry (where we can't currently accurately check scoping). */
264 if (!current_function_decl
265 || DECL_ELABORATION_PROC_P (current_function_decl))
267 process_type (gnat_entity);
268 return get_gnu_tree (gnat_entity);
271 for (gnat_temp = Scope (gnat_entity);
273 gnat_temp = Scope (gnat_temp))
275 if (Is_Type (gnat_temp))
276 gnat_temp = Underlying_Type (gnat_temp);
278 if (Ekind (gnat_temp) == E_Subprogram_Body)
280 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
282 if (IN (Ekind (gnat_temp), Subprogram_Kind)
283 && Present (Protected_Body_Subprogram (gnat_temp)))
284 gnat_temp = Protected_Body_Subprogram (gnat_temp);
286 if (Ekind (gnat_temp) == E_Entry
287 || Ekind (gnat_temp) == E_Entry_Family
288 || Ekind (gnat_temp) == E_Task_Type
289 || (IN (Ekind (gnat_temp), Subprogram_Kind)
290 && present_gnu_tree (gnat_temp)
291 && (current_function_decl
292 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
294 process_type (gnat_entity);
295 return get_gnu_tree (gnat_entity);
299 /* This abort means the Itype has an incorrect scope, i.e. that its
300 scope does not correspond to the subprogram it is declared in. */
304 /* If we've already processed this entity, return what we got last time.
305 If we are defining the node, we should not have already processed it.
306 In that case, we will abort below when we try to save a new GCC tree
307 for this object. We also need to handle the case of getting a dummy
308 type when a Full_View exists. */
309 if ((!definition || (is_type && imported_p))
310 && present_gnu_tree (gnat_entity))
312 gnu_decl = get_gnu_tree (gnat_entity);
314 if (TREE_CODE (gnu_decl) == TYPE_DECL
315 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
316 && IN (kind, Incomplete_Or_Private_Kind)
317 && Present (Full_View (gnat_entity)))
320 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
321 save_gnu_tree (gnat_entity, NULL_TREE, false);
322 save_gnu_tree (gnat_entity, gnu_decl, false);
328 /* If this is a numeric or enumeral type, or an access type, a nonzero
329 Esize must be specified unless it was specified by the programmer. */
330 gcc_assert (!Unknown_Esize (gnat_entity)
331 || Has_Size_Clause (gnat_entity)
332 || (!IN (kind, Numeric_Kind)
333 && !IN (kind, Enumeration_Kind)
334 && (!IN (kind, Access_Kind)
335 || kind == E_Access_Protected_Subprogram_Type
336 || kind == E_Anonymous_Access_Protected_Subprogram_Type
337 || kind == E_Access_Subtype)));
339 /* The RM size must be specified for all discrete and fixed-point types. */
340 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
341 && Unknown_RM_Size (gnat_entity)));
343 /* If we get here, it means we have not yet done anything with this entity.
344 If we are not defining it, it must be a type or an entity that is defined
345 elsewhere or externally, otherwise we should have defined it already. */
346 gcc_assert (definition
347 || type_annotate_only
349 || kind == E_Discriminant
350 || kind == E_Component
352 || (kind == E_Constant && Present (Full_View (gnat_entity)))
353 || Is_Public (gnat_entity));
355 /* Get the name of the entity and set up the line number and filename of
356 the original definition for use in any decl we make. */
357 gnu_entity_name = get_entity_name (gnat_entity);
358 Sloc_to_locus (Sloc (gnat_entity), &input_location);
360 /* For cases when we are not defining (i.e., we are referencing from
361 another compilation unit) public entities, show we are at global level
362 for the purpose of computing scopes. Don't do this for components or
363 discriminants since the relevant test is whether or not the record is
364 being defined. Don't do this for constants either as we'll look into
365 their defining expression in the local context. */
367 && kind != E_Component
368 && kind != E_Discriminant
369 && kind != E_Constant
370 && Is_Public (gnat_entity)
371 && !Is_Statically_Allocated (gnat_entity))
372 force_global++, this_global = true;
374 /* Handle any attributes directly attached to the entity. */
375 if (Has_Gigi_Rep_Item (gnat_entity))
376 prepend_attributes (gnat_entity, &attr_list);
378 /* Do some common processing for types. */
381 /* Compute the equivalent type to be used in gigi. */
382 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
384 /* Machine_Attributes on types are expected to be propagated to
385 subtypes. The corresponding Gigi_Rep_Items are only attached
386 to the first subtype though, so we handle the propagation here. */
387 if (Base_Type (gnat_entity) != gnat_entity
388 && !Is_First_Subtype (gnat_entity)
389 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
390 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
393 /* Compute a default value for the size of the type. */
394 if (Known_Esize (gnat_entity)
395 && UI_Is_In_Int_Range (Esize (gnat_entity)))
397 unsigned int max_esize;
398 esize = UI_To_Int (Esize (gnat_entity));
400 if (IN (kind, Float_Kind))
401 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
402 else if (IN (kind, Access_Kind))
403 max_esize = POINTER_SIZE * 2;
405 max_esize = LONG_LONG_TYPE_SIZE;
407 if (esize > max_esize)
415 /* If this is a use of a deferred constant without address clause,
416 get its full definition. */
418 && No (Address_Clause (gnat_entity))
419 && Present (Full_View (gnat_entity)))
422 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
427 /* If we have an external constant that we are not defining, get the
428 expression that is was defined to represent. We may throw it away
429 later if it is not a constant. But do not retrieve the expression
430 if it is an allocator because the designated type might be dummy
433 && !No_Initialization (Declaration_Node (gnat_entity))
434 && Present (Expression (Declaration_Node (gnat_entity)))
435 && Nkind (Expression (Declaration_Node (gnat_entity)))
438 bool went_into_elab_proc = false;
440 /* The expression may contain N_Expression_With_Actions nodes and
441 thus object declarations from other units. In this case, even
442 though the expression will eventually be discarded since not a
443 constant, the declarations would be stuck either in the global
444 varpool or in the current scope. Therefore we force the local
445 context and create a fake scope that we'll zap at the end. */
446 if (!current_function_decl)
448 current_function_decl = get_elaboration_procedure ();
449 went_into_elab_proc = true;
453 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
456 if (went_into_elab_proc)
457 current_function_decl = NULL_TREE;
460 /* Ignore deferred constant definitions without address clause since
461 they are processed fully in the front-end. If No_Initialization
462 is set, this is not a deferred constant but a constant whose value
463 is built manually. And constants that are renamings are handled
467 && No (Address_Clause (gnat_entity))
468 && !No_Initialization (Declaration_Node (gnat_entity))
469 && No (Renamed_Object (gnat_entity)))
471 gnu_decl = error_mark_node;
476 /* Ignore constant definitions already marked with the error node. See
477 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
480 && present_gnu_tree (gnat_entity)
481 && get_gnu_tree (gnat_entity) == error_mark_node)
483 maybe_present = true;
490 /* We used to special case VMS exceptions here to directly map them to
491 their associated condition code. Since this code had to be masked
492 dynamically to strip off the severity bits, this caused trouble in
493 the GCC/ZCX case because the "type" pointers we store in the tables
494 have to be static. We now don't special case here anymore, and let
495 the regular processing take place, which leaves us with a regular
496 exception data object for VMS exceptions too. The condition code
497 mapping is taken care of by the front end and the bitmasking by the
504 /* The GNAT record where the component was defined. */
505 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
507 /* If the variable is an inherited record component (in the case of
508 extended record types), just return the inherited entity, which
509 must be a FIELD_DECL. Likewise for discriminants.
510 For discriminants of untagged records which have explicit
511 stored discriminants, return the entity for the corresponding
512 stored discriminant. Also use Original_Record_Component
513 if the record has a private extension. */
514 if (Present (Original_Record_Component (gnat_entity))
515 && Original_Record_Component (gnat_entity) != gnat_entity)
518 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
519 gnu_expr, definition);
524 /* If the enclosing record has explicit stored discriminants,
525 then it is an untagged record. If the Corresponding_Discriminant
526 is not empty then this must be a renamed discriminant and its
527 Original_Record_Component must point to the corresponding explicit
528 stored discriminant (i.e. we should have taken the previous
530 else if (Present (Corresponding_Discriminant (gnat_entity))
531 && Is_Tagged_Type (gnat_record))
533 /* A tagged record has no explicit stored discriminants. */
534 gcc_assert (First_Discriminant (gnat_record)
535 == First_Stored_Discriminant (gnat_record));
537 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
538 gnu_expr, definition);
543 else if (Present (CR_Discriminant (gnat_entity))
544 && type_annotate_only)
546 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
547 gnu_expr, definition);
552 /* If the enclosing record has explicit stored discriminants, then
553 it is an untagged record. If the Corresponding_Discriminant
554 is not empty then this must be a renamed discriminant and its
555 Original_Record_Component must point to the corresponding explicit
556 stored discriminant (i.e. we should have taken the first
558 else if (Present (Corresponding_Discriminant (gnat_entity))
559 && (First_Discriminant (gnat_record)
560 != First_Stored_Discriminant (gnat_record)))
563 /* Otherwise, if we are not defining this and we have no GCC type
564 for the containing record, make one for it. Then we should
565 have made our own equivalent. */
566 else if (!definition && !present_gnu_tree (gnat_record))
568 /* ??? If this is in a record whose scope is a protected
569 type and we have an Original_Record_Component, use it.
570 This is a workaround for major problems in protected type
572 Entity_Id Scop = Scope (Scope (gnat_entity));
573 if ((Is_Protected_Type (Scop)
574 || (Is_Private_Type (Scop)
575 && Present (Full_View (Scop))
576 && Is_Protected_Type (Full_View (Scop))))
577 && Present (Original_Record_Component (gnat_entity)))
580 = gnat_to_gnu_entity (Original_Record_Component
587 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
588 gnu_decl = get_gnu_tree (gnat_entity);
594 /* Here we have no GCC type and this is a reference rather than a
595 definition. This should never happen. Most likely the cause is
596 reference before declaration in the gnat tree for gnat_entity. */
600 case E_Loop_Parameter:
601 case E_Out_Parameter:
604 /* Simple variables, loop variables, Out parameters and exceptions. */
608 = ((kind == E_Constant || kind == E_Variable)
609 && Is_True_Constant (gnat_entity)
610 && !Treat_As_Volatile (gnat_entity)
611 && (((Nkind (Declaration_Node (gnat_entity))
612 == N_Object_Declaration)
613 && Present (Expression (Declaration_Node (gnat_entity))))
614 || Present (Renamed_Object (gnat_entity))
616 bool inner_const_flag = const_flag;
617 bool static_p = Is_Statically_Allocated (gnat_entity);
618 bool mutable_p = false;
619 bool used_by_ref = false;
620 tree gnu_ext_name = NULL_TREE;
621 tree renamed_obj = NULL_TREE;
622 tree gnu_object_size;
624 if (Present (Renamed_Object (gnat_entity)) && !definition)
626 if (kind == E_Exception)
627 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
630 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
633 /* Get the type after elaborating the renamed object. */
634 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
636 /* If this is a standard exception definition, then use the standard
637 exception type. This is necessary to make sure that imported and
638 exported views of exceptions are properly merged in LTO mode. */
639 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
640 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
641 gnu_type = except_type_node;
643 /* For a debug renaming declaration, build a debug-only entity. */
644 if (Present (Debug_Renaming_Link (gnat_entity)))
646 /* Force a non-null value to make sure the symbol is retained. */
647 tree value = build1 (INDIRECT_REF, gnu_type,
649 build_pointer_type (gnu_type),
650 integer_minus_one_node));
651 gnu_decl = build_decl (input_location,
652 VAR_DECL, gnu_entity_name, gnu_type);
653 SET_DECL_VALUE_EXPR (gnu_decl, value);
654 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
655 gnat_pushdecl (gnu_decl, gnat_entity);
659 /* If this is a loop variable, its type should be the base type.
660 This is because the code for processing a loop determines whether
661 a normal loop end test can be done by comparing the bounds of the
662 loop against those of the base type, which is presumed to be the
663 size used for computation. But this is not correct when the size
664 of the subtype is smaller than the type. */
665 if (kind == E_Loop_Parameter)
666 gnu_type = get_base_type (gnu_type);
668 /* Reject non-renamed objects whose type is an unconstrained array or
669 any object whose type is a dummy type or void. */
670 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
671 && No (Renamed_Object (gnat_entity)))
672 || TYPE_IS_DUMMY_P (gnu_type)
673 || TREE_CODE (gnu_type) == VOID_TYPE)
675 gcc_assert (type_annotate_only);
678 return error_mark_node;
681 /* If an alignment is specified, use it if valid. Note that exceptions
682 are objects but don't have an alignment. We must do this before we
683 validate the size, since the alignment can affect the size. */
684 if (kind != E_Exception && Known_Alignment (gnat_entity))
686 gcc_assert (Present (Alignment (gnat_entity)));
688 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
689 TYPE_ALIGN (gnu_type));
691 /* No point in changing the type if there is an address clause
692 as the final type of the object will be a reference type. */
693 if (Present (Address_Clause (gnat_entity)))
697 tree orig_type = gnu_type;
700 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
701 false, false, definition, true);
703 /* If a padding record was made, declare it now since it will
704 never be declared otherwise. This is necessary to ensure
705 that its subtrees are properly marked. */
706 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
707 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
708 debug_info_p, gnat_entity);
712 /* If we are defining the object, see if it has a Size and validate it
713 if so. If we are not defining the object and a Size clause applies,
714 simply retrieve the value. We don't want to ignore the clause and
715 it is expected to have been validated already. Then get the new
718 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
719 gnat_entity, VAR_DECL, false,
720 Has_Size_Clause (gnat_entity));
721 else if (Has_Size_Clause (gnat_entity))
722 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
727 = make_type_from_size (gnu_type, gnu_size,
728 Has_Biased_Representation (gnat_entity));
730 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
731 gnu_size = NULL_TREE;
734 /* If this object has self-referential size, it must be a record with
735 a default discriminant. We are supposed to allocate an object of
736 the maximum size in this case, unless it is a constant with an
737 initializing expression, in which case we can get the size from
738 that. Note that the resulting size may still be a variable, so
739 this may end up with an indirect allocation. */
740 if (No (Renamed_Object (gnat_entity))
741 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
743 if (gnu_expr && kind == E_Constant)
745 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
746 if (CONTAINS_PLACEHOLDER_P (size))
748 /* If the initializing expression is itself a constant,
749 despite having a nominal type with self-referential
750 size, we can get the size directly from it. */
751 if (TREE_CODE (gnu_expr) == COMPONENT_REF
753 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
754 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
755 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
756 || DECL_READONLY_ONCE_ELAB
757 (TREE_OPERAND (gnu_expr, 0))))
758 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
761 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
766 /* We may have no GNU_EXPR because No_Initialization is
767 set even though there's an Expression. */
768 else if (kind == E_Constant
769 && (Nkind (Declaration_Node (gnat_entity))
770 == N_Object_Declaration)
771 && Present (Expression (Declaration_Node (gnat_entity))))
773 = TYPE_SIZE (gnat_to_gnu_type
775 (Expression (Declaration_Node (gnat_entity)))));
778 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
782 /* If we are at global level and the size isn't constant, call
783 elaborate_expression_1 to make a variable for it rather than
784 calculating it each time. */
785 if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
786 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
787 get_identifier ("SIZE"),
791 /* If the size is zero byte, make it one byte since some linkers have
792 troubles with zero-sized objects. If the object will have a
793 template, that will make it nonzero so don't bother. Also avoid
794 doing that for an object renaming or an object with an address
795 clause, as we would lose useful information on the view size
796 (e.g. for null array slices) and we are not allocating the object
799 && integer_zerop (gnu_size)
800 && !TREE_OVERFLOW (gnu_size))
801 || (TYPE_SIZE (gnu_type)
802 && integer_zerop (TYPE_SIZE (gnu_type))
803 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
804 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
805 || !Is_Array_Type (Etype (gnat_entity)))
806 && No (Renamed_Object (gnat_entity))
807 && No (Address_Clause (gnat_entity)))
808 gnu_size = bitsize_unit_node;
810 /* If this is an object with no specified size and alignment, and
811 if either it is atomic or we are not optimizing alignment for
812 space and it is composite and not an exception, an Out parameter
813 or a reference to another object, and the size of its type is a
814 constant, set the alignment to the smallest one which is not
815 smaller than the size, with an appropriate cap. */
816 if (!gnu_size && align == 0
817 && (Is_Atomic (gnat_entity)
818 || (!Optimize_Alignment_Space (gnat_entity)
819 && kind != E_Exception
820 && kind != E_Out_Parameter
821 && Is_Composite_Type (Etype (gnat_entity))
822 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
823 && !Is_Exported (gnat_entity)
825 && No (Renamed_Object (gnat_entity))
826 && No (Address_Clause (gnat_entity))))
827 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
829 unsigned int size_cap, align_cap;
831 /* No point in promoting the alignment if this doesn't prevent
832 BLKmode access to the object, in particular block copy, as
833 this will for example disable the NRV optimization for it.
834 No point in jumping through all the hoops needed in order
835 to support BIGGEST_ALIGNMENT if we don't really have to.
836 So we cap to the smallest alignment that corresponds to
837 a known efficient memory access pattern of the target. */
838 if (Is_Atomic (gnat_entity))
841 align_cap = BIGGEST_ALIGNMENT;
845 size_cap = MAX_FIXED_MODE_SIZE;
846 align_cap = get_mode_alignment (ptr_mode);
849 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
850 || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
852 else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
855 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
857 /* But make sure not to under-align the object. */
858 if (align <= TYPE_ALIGN (gnu_type))
861 /* And honor the minimum valid atomic alignment, if any. */
862 #ifdef MINIMUM_ATOMIC_ALIGNMENT
863 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
864 align = MINIMUM_ATOMIC_ALIGNMENT;
868 /* If the object is set to have atomic components, find the component
869 type and validate it.
871 ??? Note that we ignore Has_Volatile_Components on objects; it's
872 not at all clear what to do in that case. */
873 if (Has_Atomic_Components (gnat_entity))
875 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
876 ? TREE_TYPE (gnu_type) : gnu_type);
878 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
879 && TYPE_MULTI_ARRAY_P (gnu_inner))
880 gnu_inner = TREE_TYPE (gnu_inner);
882 check_ok_for_atomic (gnu_inner, gnat_entity, true);
885 /* Now check if the type of the object allows atomic access. Note
886 that we must test the type, even if this object has size and
887 alignment to allow such access, because we will be going inside
888 the padded record to assign to the object. We could fix this by
889 always copying via an intermediate value, but it's not clear it's
891 if (Is_Atomic (gnat_entity))
892 check_ok_for_atomic (gnu_type, gnat_entity, false);
894 /* If this is an aliased object with an unconstrained nominal subtype,
895 make a type that includes the template. */
896 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
897 && Is_Array_Type (Etype (gnat_entity))
898 && !type_annotate_only)
901 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
903 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
905 concat_name (gnu_entity_name,
910 #ifdef MINIMUM_ATOMIC_ALIGNMENT
911 /* If the size is a constant and no alignment is specified, force
912 the alignment to be the minimum valid atomic alignment. The
913 restriction on constant size avoids problems with variable-size
914 temporaries; if the size is variable, there's no issue with
915 atomic access. Also don't do this for a constant, since it isn't
916 necessary and can interfere with constant replacement. Finally,
917 do not do it for Out parameters since that creates an
918 size inconsistency with In parameters. */
919 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
920 && !FLOAT_TYPE_P (gnu_type)
921 && !const_flag && No (Renamed_Object (gnat_entity))
922 && !imported_p && No (Address_Clause (gnat_entity))
923 && kind != E_Out_Parameter
924 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
925 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
926 align = MINIMUM_ATOMIC_ALIGNMENT;
929 /* Make a new type with the desired size and alignment, if needed.
930 But do not take into account alignment promotions to compute the
931 size of the object. */
932 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
933 if (gnu_size || align > 0)
935 tree orig_type = gnu_type;
937 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
938 false, false, definition,
939 gnu_size ? true : false);
941 /* If a padding record was made, declare it now since it will
942 never be declared otherwise. This is necessary to ensure
943 that its subtrees are properly marked. */
944 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
945 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
946 debug_info_p, gnat_entity);
949 /* If this is a renaming, avoid as much as possible to create a new
950 object. However, in several cases, creating it is required.
951 This processing needs to be applied to the raw expression so
952 as to make it more likely to rename the underlying object. */
953 if (Present (Renamed_Object (gnat_entity)))
955 bool create_normal_object = false;
957 /* If the renamed object had padding, strip off the reference
958 to the inner object and reset our type. */
959 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
960 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
961 /* Strip useless conversions around the object. */
962 || gnat_useless_type_conversion (gnu_expr))
964 gnu_expr = TREE_OPERAND (gnu_expr, 0);
965 gnu_type = TREE_TYPE (gnu_expr);
968 /* Case 1: If this is a constant renaming stemming from a function
969 call, treat it as a normal object whose initial value is what
970 is being renamed. RM 3.3 says that the result of evaluating a
971 function call is a constant object. As a consequence, it can
972 be the inner object of a constant renaming. In this case, the
973 renaming must be fully instantiated, i.e. it cannot be a mere
974 reference to (part of) an existing object. */
977 tree inner_object = gnu_expr;
978 while (handled_component_p (inner_object))
979 inner_object = TREE_OPERAND (inner_object, 0);
980 if (TREE_CODE (inner_object) == CALL_EXPR)
981 create_normal_object = true;
984 /* Otherwise, see if we can proceed with a stabilized version of
985 the renamed entity or if we need to make a new object. */
986 if (!create_normal_object)
988 tree maybe_stable_expr = NULL_TREE;
991 /* Case 2: If the renaming entity need not be materialized and
992 the renamed expression is something we can stabilize, use
993 that for the renaming. At the global level, we can only do
994 this if we know no SAVE_EXPRs need be made, because the
995 expression we return might be used in arbitrary conditional
996 branches so we must force the evaluation of the SAVE_EXPRs
997 immediately and this requires a proper function context.
998 Note that an external constant is at the global level. */
999 if (!Materialize_Entity (gnat_entity)
1000 && (!((!definition && kind == E_Constant)
1001 || global_bindings_p ())
1002 || (staticp (gnu_expr)
1003 && !TREE_SIDE_EFFECTS (gnu_expr))))
1006 = gnat_stabilize_reference (gnu_expr, true, &stable);
1010 /* ??? No DECL_EXPR is created so we need to mark
1011 the expression manually lest it is shared. */
1012 if ((!definition && kind == E_Constant)
1013 || global_bindings_p ())
1014 MARK_VISITED (maybe_stable_expr);
1015 gnu_decl = maybe_stable_expr;
1016 save_gnu_tree (gnat_entity, gnu_decl, true);
1018 annotate_object (gnat_entity, gnu_type, NULL_TREE,
1020 /* This assertion will fail if the renamed object
1021 isn't aligned enough as to make it possible to
1022 honor the alignment set on the renaming. */
1025 unsigned int renamed_align
1027 ? DECL_ALIGN (gnu_decl)
1028 : TYPE_ALIGN (TREE_TYPE (gnu_decl));
1029 gcc_assert (renamed_align >= align);
1034 /* The stabilization failed. Keep maybe_stable_expr
1035 untouched here to let the pointer case below know
1036 about that failure. */
1039 /* Case 3: If this is a constant renaming and creating a
1040 new object is allowed and cheap, treat it as a normal
1041 object whose initial value is what is being renamed. */
1043 && !Is_Composite_Type
1044 (Underlying_Type (Etype (gnat_entity))))
1047 /* Case 4: Make this into a constant pointer to the object we
1048 are to rename and attach the object to the pointer if it is
1049 something we can stabilize.
1051 From the proper scope, attached objects will be referenced
1052 directly instead of indirectly via the pointer to avoid
1053 subtle aliasing problems with non-addressable entities.
1054 They have to be stable because we must not evaluate the
1055 variables in the expression every time the renaming is used.
1056 The pointer is called a "renaming" pointer in this case.
1058 In the rare cases where we cannot stabilize the renamed
1059 object, we just make a "bare" pointer, and the renamed
1060 entity is always accessed indirectly through it. */
1063 /* We need to preserve the volatileness of the renamed
1064 object through the indirection. */
1065 if (TREE_THIS_VOLATILE (gnu_expr)
1066 && !TYPE_VOLATILE (gnu_type))
1068 = build_qualified_type (gnu_type,
1069 (TYPE_QUALS (gnu_type)
1070 | TYPE_QUAL_VOLATILE));
1071 gnu_type = build_reference_type (gnu_type);
1072 inner_const_flag = TREE_READONLY (gnu_expr);
1075 /* If the previous attempt at stabilizing failed, there
1076 is no point in trying again and we reuse the result
1077 without attaching it to the pointer. In this case it
1078 will only be used as the initializing expression of
1079 the pointer and thus needs no special treatment with
1080 regard to multiple evaluations. */
1081 if (maybe_stable_expr)
1084 /* Otherwise, try to stabilize and attach the expression
1085 to the pointer if the stabilization succeeds.
1087 Note that this might introduce SAVE_EXPRs and we don't
1088 check whether we're at the global level or not. This
1089 is fine since we are building a pointer initializer and
1090 neither the pointer nor the initializing expression can
1091 be accessed before the pointer elaboration has taken
1092 place in a correct program.
1094 These SAVE_EXPRs will be evaluated at the right place
1095 by either the evaluation of the initializer for the
1096 non-global case or the elaboration code for the global
1097 case, and will be attached to the elaboration procedure
1098 in the latter case. */
1102 = gnat_stabilize_reference (gnu_expr, true, &stable);
1105 renamed_obj = maybe_stable_expr;
1107 /* Attaching is actually performed downstream, as soon
1108 as we have a VAR_DECL for the pointer we make. */
1111 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type,
1114 gnu_size = NULL_TREE;
1120 /* Make a volatile version of this object's type if we are to make
1121 the object volatile. We also interpret 13.3(19) conservatively
1122 and disallow any optimizations for such a non-constant object. */
1123 if ((Treat_As_Volatile (gnat_entity)
1125 && gnu_type != except_type_node
1126 && (Is_Exported (gnat_entity)
1128 || Present (Address_Clause (gnat_entity)))))
1129 && !TYPE_VOLATILE (gnu_type))
1130 gnu_type = build_qualified_type (gnu_type,
1131 (TYPE_QUALS (gnu_type)
1132 | TYPE_QUAL_VOLATILE));
1134 /* If we are defining an aliased object whose nominal subtype is
1135 unconstrained, the object is a record that contains both the
1136 template and the object. If there is an initializer, it will
1137 have already been converted to the right type, but we need to
1138 create the template if there is no initializer. */
1141 && TREE_CODE (gnu_type) == RECORD_TYPE
1142 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1143 /* Beware that padding might have been introduced above. */
1144 || (TYPE_PADDING_P (gnu_type)
1145 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1147 && TYPE_CONTAINS_TEMPLATE_P
1148 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1151 = TYPE_PADDING_P (gnu_type)
1152 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1153 : TYPE_FIELDS (gnu_type);
1154 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
1155 tree t = build_template (TREE_TYPE (template_field),
1156 TREE_TYPE (DECL_CHAIN (template_field)),
1158 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1159 gnu_expr = gnat_build_constructor (gnu_type, v);
1162 /* Convert the expression to the type of the object except in the
1163 case where the object's type is unconstrained or the object's type
1164 is a padded record whose field is of self-referential size. In
1165 the former case, converting will generate unnecessary evaluations
1166 of the CONSTRUCTOR to compute the size and in the latter case, we
1167 want to only copy the actual data. Also don't convert to a record
1168 type with a variant part from a record type without one, to keep
1169 the object simpler. */
1171 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1172 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1173 && !(TYPE_IS_PADDING_P (gnu_type)
1174 && CONTAINS_PLACEHOLDER_P
1175 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1176 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1177 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1178 && get_variant_part (gnu_type) != NULL_TREE
1179 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1180 gnu_expr = convert (gnu_type, gnu_expr);
1182 /* If this is a pointer that doesn't have an initializing expression,
1183 initialize it to NULL, unless the object is imported. */
1185 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1187 && !Is_Imported (gnat_entity))
1188 gnu_expr = integer_zero_node;
1190 /* If we are defining the object and it has an Address clause, we must
1191 either get the address expression from the saved GCC tree for the
1192 object if it has a Freeze node, or elaborate the address expression
1193 here since the front-end has guaranteed that the elaboration has no
1194 effects in this case. */
1195 if (definition && Present (Address_Clause (gnat_entity)))
1197 Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1199 = present_gnu_tree (gnat_entity)
1200 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1202 save_gnu_tree (gnat_entity, NULL_TREE, false);
1204 /* Ignore the size. It's either meaningless or was handled
1206 gnu_size = NULL_TREE;
1207 /* Convert the type of the object to a reference type that can
1208 alias everything as per 13.3(19). */
1210 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1211 gnu_address = convert (gnu_type, gnu_address);
1214 = !Is_Public (gnat_entity)
1215 || compile_time_known_address_p (gnat_expr);
1217 /* If this is a deferred constant, the initializer is attached to
1219 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1222 (Expression (Declaration_Node (Full_View (gnat_entity))));
1224 /* If we don't have an initializing expression for the underlying
1225 variable, the initializing expression for the pointer is the
1226 specified address. Otherwise, we have to make a COMPOUND_EXPR
1227 to assign both the address and the initial value. */
1229 gnu_expr = gnu_address;
1232 = build2 (COMPOUND_EXPR, gnu_type,
1234 (MODIFY_EXPR, NULL_TREE,
1235 build_unary_op (INDIRECT_REF, NULL_TREE,
1241 /* If it has an address clause and we are not defining it, mark it
1242 as an indirect object. Likewise for Stdcall objects that are
1244 if ((!definition && Present (Address_Clause (gnat_entity)))
1245 || (Is_Imported (gnat_entity)
1246 && Has_Stdcall_Convention (gnat_entity)))
1248 /* Convert the type of the object to a reference type that can
1249 alias everything as per 13.3(19). */
1251 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1252 gnu_size = NULL_TREE;
1254 /* No point in taking the address of an initializing expression
1255 that isn't going to be used. */
1256 gnu_expr = NULL_TREE;
1258 /* If it has an address clause whose value is known at compile
1259 time, make the object a CONST_DECL. This will avoid a
1260 useless dereference. */
1261 if (Present (Address_Clause (gnat_entity)))
1263 Node_Id gnat_address
1264 = Expression (Address_Clause (gnat_entity));
1266 if (compile_time_known_address_p (gnat_address))
1268 gnu_expr = gnat_to_gnu (gnat_address);
1276 /* If we are at top level and this object is of variable size,
1277 make the actual type a hidden pointer to the real type and
1278 make the initializer be a memory allocation and initialization.
1279 Likewise for objects we aren't defining (presumed to be
1280 external references from other packages), but there we do
1281 not set up an initialization.
1283 If the object's size overflows, make an allocator too, so that
1284 Storage_Error gets raised. Note that we will never free
1285 such memory, so we presume it never will get allocated. */
1286 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1287 global_bindings_p ()
1290 || (gnu_size && !allocatable_size_p (gnu_size,
1291 global_bindings_p ()
1295 gnu_type = build_reference_type (gnu_type);
1296 gnu_size = NULL_TREE;
1299 /* In case this was a aliased object whose nominal subtype is
1300 unconstrained, the pointer above will be a thin pointer and
1301 build_allocator will automatically make the template.
1303 If we have a template initializer only (that we made above),
1304 pretend there is none and rely on what build_allocator creates
1305 again anyway. Otherwise (if we have a full initializer), get
1306 the data part and feed that to build_allocator.
1308 If we are elaborating a mutable object, tell build_allocator to
1309 ignore a possibly simpler size from the initializer, if any, as
1310 we must allocate the maximum possible size in this case. */
1311 if (definition && !imported_p)
1313 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1315 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1316 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1319 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1321 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1322 && 1 == VEC_length (constructor_elt,
1323 CONSTRUCTOR_ELTS (gnu_expr)))
1327 = build_component_ref
1328 (gnu_expr, NULL_TREE,
1329 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1333 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1334 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)))
1335 post_error ("?`Storage_Error` will be raised at run time!",
1339 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1340 Empty, Empty, gnat_entity, mutable_p);
1345 gnu_expr = NULL_TREE;
1350 /* If this object would go into the stack and has an alignment larger
1351 than the largest stack alignment the back-end can honor, resort to
1352 a variable of "aligning type". */
1353 if (!global_bindings_p () && !static_p && definition
1354 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1356 /* Create the new variable. No need for extra room before the
1357 aligned field as this is in automatic storage. */
1359 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1360 TYPE_SIZE_UNIT (gnu_type),
1361 BIGGEST_ALIGNMENT, 0);
1363 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1364 NULL_TREE, gnu_new_type, NULL_TREE, false,
1365 false, false, false, NULL, gnat_entity);
1367 /* Initialize the aligned field if we have an initializer. */
1370 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1372 (gnu_new_var, NULL_TREE,
1373 TYPE_FIELDS (gnu_new_type), false),
1377 /* And setup this entity as a reference to the aligned field. */
1378 gnu_type = build_reference_type (gnu_type);
1381 (ADDR_EXPR, gnu_type,
1382 build_component_ref (gnu_new_var, NULL_TREE,
1383 TYPE_FIELDS (gnu_new_type), false));
1385 gnu_size = NULL_TREE;
1390 /* If this is an aliased object with an unconstrained nominal subtype,
1391 we make its type a thin reference, i.e. the reference counterpart
1392 of a thin pointer, so that it points to the array part. This is
1393 aimed at making it easier for the debugger to decode the object.
1394 Note that we have to do that this late because of the couple of
1395 allocation adjustments that might be made just above. */
1396 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
1397 && Is_Array_Type (Etype (gnat_entity))
1398 && !type_annotate_only)
1401 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
1403 /* In case the object with the template has already been allocated
1404 just above, we have nothing to do here. */
1405 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1407 gnu_size = NULL_TREE;
1410 if (definition && !imported_p)
1413 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1414 NULL_TREE, gnu_type, gnu_expr,
1415 const_flag, Is_Public (gnat_entity),
1416 false, static_p, NULL, gnat_entity);
1418 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1419 TREE_CONSTANT (gnu_expr) = 1;
1424 gnu_expr = NULL_TREE;
1430 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1434 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1435 | TYPE_QUAL_CONST));
1437 /* Convert the expression to the type of the object except in the
1438 case where the object's type is unconstrained or the object's type
1439 is a padded record whose field is of self-referential size. In
1440 the former case, converting will generate unnecessary evaluations
1441 of the CONSTRUCTOR to compute the size and in the latter case, we
1442 want to only copy the actual data. Also don't convert to a record
1443 type with a variant part from a record type without one, to keep
1444 the object simpler. */
1446 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1447 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1448 && !(TYPE_IS_PADDING_P (gnu_type)
1449 && CONTAINS_PLACEHOLDER_P
1450 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1451 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1452 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1453 && get_variant_part (gnu_type) != NULL_TREE
1454 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1455 gnu_expr = convert (gnu_type, gnu_expr);
1457 /* If this name is external or there was a name specified, use it,
1458 unless this is a VMS exception object since this would conflict
1459 with the symbol we need to export in addition. Don't use the
1460 Interface_Name if there is an address clause (see CD30005). */
1461 if (!Is_VMS_Exception (gnat_entity)
1462 && ((Present (Interface_Name (gnat_entity))
1463 && No (Address_Clause (gnat_entity)))
1464 || (Is_Public (gnat_entity)
1465 && (!Is_Imported (gnat_entity)
1466 || Is_Exported (gnat_entity)))))
1467 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1469 /* If this is an aggregate constant initialized to a constant, force it
1470 to be statically allocated. This saves an initialization copy. */
1473 && gnu_expr && TREE_CONSTANT (gnu_expr)
1474 && AGGREGATE_TYPE_P (gnu_type)
1475 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1476 && !(TYPE_IS_PADDING_P (gnu_type)
1477 && !host_integerp (TYPE_SIZE_UNIT
1478 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1481 /* Now create the variable or the constant and set various flags. */
1483 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1484 gnu_expr, const_flag, Is_Public (gnat_entity),
1485 imported_p || !definition, static_p, attr_list,
1487 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1488 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1489 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1491 /* If we are defining an Out parameter and optimization isn't enabled,
1492 create a fake PARM_DECL for debugging purposes and make it point to
1493 the VAR_DECL. Suppress debug info for the latter but make sure it
1494 will live on the stack so that it can be accessed from within the
1495 debugger through the PARM_DECL. */
1496 if (kind == E_Out_Parameter && definition && !optimize && debug_info_p)
1498 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1499 gnat_pushdecl (param, gnat_entity);
1500 SET_DECL_VALUE_EXPR (param, gnu_decl);
1501 DECL_HAS_VALUE_EXPR_P (param) = 1;
1502 DECL_IGNORED_P (gnu_decl) = 1;
1503 TREE_ADDRESSABLE (gnu_decl) = 1;
1506 /* If this is a loop parameter, set the corresponding flag. */
1507 else if (kind == E_Loop_Parameter)
1508 DECL_LOOP_PARM_P (gnu_decl) = 1;
1510 /* If this is a renaming pointer, attach the renamed object to it and
1511 register it if we are at the global level. Note that an external
1512 constant is at the global level. */
1513 else if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1515 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1516 if ((!definition && kind == E_Constant) || global_bindings_p ())
1518 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1519 record_global_renaming_pointer (gnu_decl);
1523 /* If this is a constant and we are defining it or it generates a real
1524 symbol at the object level and we are referencing it, we may want
1525 or need to have a true variable to represent it:
1526 - if optimization isn't enabled, for debugging purposes,
1527 - if the constant is public and not overlaid on something else,
1528 - if its address is taken,
1529 - if either itself or its type is aliased. */
1530 if (TREE_CODE (gnu_decl) == CONST_DECL
1531 && (definition || Sloc (gnat_entity) > Standard_Location)
1532 && ((!optimize && debug_info_p)
1533 || (Is_Public (gnat_entity)
1534 && No (Address_Clause (gnat_entity)))
1535 || Address_Taken (gnat_entity)
1536 || Is_Aliased (gnat_entity)
1537 || Is_Aliased (Etype (gnat_entity))))
1540 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1541 gnu_expr, true, Is_Public (gnat_entity),
1542 !definition, static_p, attr_list,
1545 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1547 /* As debugging information will be generated for the variable,
1548 do not generate debugging information for the constant. */
1550 DECL_IGNORED_P (gnu_decl) = 1;
1552 DECL_IGNORED_P (gnu_corr_var) = 1;
1555 /* If this is a constant, even if we don't need a true variable, we
1556 may need to avoid returning the initializer in every case. That
1557 can happen for the address of a (constant) constructor because,
1558 upon dereferencing it, the constructor will be reinjected in the
1559 tree, which may not be valid in every case; see lvalue_required_p
1560 for more details. */
1561 if (TREE_CODE (gnu_decl) == CONST_DECL)
1562 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1564 /* If this object is declared in a block that contains a block with an
1565 exception handler, and we aren't using the GCC exception mechanism,
1566 we must force this variable in memory in order to avoid an invalid
1568 if (Exception_Mechanism != Back_End_Exceptions
1569 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1570 TREE_ADDRESSABLE (gnu_decl) = 1;
1572 /* If we are defining an object with variable size or an object with
1573 fixed size that will be dynamically allocated, and we are using the
1574 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1576 && Exception_Mechanism == Setjmp_Longjmp
1577 && get_block_jmpbuf_decl ()
1578 && DECL_SIZE_UNIT (gnu_decl)
1579 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1580 || (flag_stack_check == GENERIC_STACK_CHECK
1581 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1582 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1583 add_stmt_with_node (build_call_n_expr
1584 (update_setjmp_buf_decl, 1,
1585 build_unary_op (ADDR_EXPR, NULL_TREE,
1586 get_block_jmpbuf_decl ())),
1589 /* Back-annotate Esize and Alignment of the object if not already
1590 known. Note that we pick the values of the type, not those of
1591 the object, to shield ourselves from low-level platform-dependent
1592 adjustments like alignment promotion. This is both consistent with
1593 all the treatment above, where alignment and size are set on the
1594 type of the object and not on the object directly, and makes it
1595 possible to support all confirming representation clauses. */
1596 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1597 used_by_ref, false);
1602 /* Return a TYPE_DECL for "void" that we previously made. */
1603 gnu_decl = TYPE_NAME (void_type_node);
1606 case E_Enumeration_Type:
1607 /* A special case: for the types Character and Wide_Character in
1608 Standard, we do not list all the literals. So if the literals
1609 are not specified, make this an unsigned type. */
1610 if (No (First_Literal (gnat_entity)))
1612 gnu_type = make_unsigned_type (esize);
1613 TYPE_NAME (gnu_type) = gnu_entity_name;
1615 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1616 This is needed by the DWARF-2 back-end to distinguish between
1617 unsigned integer types and character types. */
1618 TYPE_STRING_FLAG (gnu_type) = 1;
1623 /* We have a list of enumeral constants in First_Literal. We make a
1624 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1625 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1626 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1627 value of the literal. But when we have a regular boolean type, we
1628 simplify this a little by using a BOOLEAN_TYPE. */
1629 bool is_boolean = Is_Boolean_Type (gnat_entity)
1630 && !Has_Non_Standard_Rep (gnat_entity);
1631 tree gnu_literal_list = NULL_TREE;
1632 Entity_Id gnat_literal;
1634 if (Is_Unsigned_Type (gnat_entity))
1635 gnu_type = make_unsigned_type (esize);
1637 gnu_type = make_signed_type (esize);
1639 TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1641 for (gnat_literal = First_Literal (gnat_entity);
1642 Present (gnat_literal);
1643 gnat_literal = Next_Literal (gnat_literal))
1646 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1648 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1649 gnu_type, gnu_value, true, false, false,
1650 false, NULL, gnat_literal);
1651 /* Do not generate debug info for individual enumerators. */
1652 DECL_IGNORED_P (gnu_literal) = 1;
1653 save_gnu_tree (gnat_literal, gnu_literal, false);
1654 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1655 gnu_value, gnu_literal_list);
1659 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1661 /* Note that the bounds are updated at the end of this function
1662 to avoid an infinite recursion since they refer to the type. */
1666 case E_Signed_Integer_Type:
1667 case E_Ordinary_Fixed_Point_Type:
1668 case E_Decimal_Fixed_Point_Type:
1669 /* For integer types, just make a signed type the appropriate number
1671 gnu_type = make_signed_type (esize);
1674 case E_Modular_Integer_Type:
1676 /* For modular types, make the unsigned type of the proper number
1677 of bits and then set up the modulus, if required. */
1678 tree gnu_modulus, gnu_high = NULL_TREE;
1680 /* Packed array types are supposed to be subtypes only. */
1681 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1683 gnu_type = make_unsigned_type (esize);
1685 /* Get the modulus in this type. If it overflows, assume it is because
1686 it is equal to 2**Esize. Note that there is no overflow checking
1687 done on unsigned type, so we detect the overflow by looking for
1688 a modulus of zero, which is otherwise invalid. */
1689 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1691 if (!integer_zerop (gnu_modulus))
1693 TYPE_MODULAR_P (gnu_type) = 1;
1694 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1695 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1696 convert (gnu_type, integer_one_node));
1699 /* If the upper bound is not maximal, make an extra subtype. */
1701 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1703 tree gnu_subtype = make_unsigned_type (esize);
1704 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1705 TREE_TYPE (gnu_subtype) = gnu_type;
1706 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1707 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1708 gnu_type = gnu_subtype;
1713 case E_Signed_Integer_Subtype:
1714 case E_Enumeration_Subtype:
1715 case E_Modular_Integer_Subtype:
1716 case E_Ordinary_Fixed_Point_Subtype:
1717 case E_Decimal_Fixed_Point_Subtype:
1719 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1720 not want to call create_range_type since we would like each subtype
1721 node to be distinct. ??? Historically this was in preparation for
1722 when memory aliasing is implemented, but that's obsolete now given
1723 the call to relate_alias_sets below.
1725 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1726 this fact is used by the arithmetic conversion functions.
1728 We elaborate the Ancestor_Subtype if it is not in the current unit
1729 and one of our bounds is non-static. We do this to ensure consistent
1730 naming in the case where several subtypes share the same bounds, by
1731 elaborating the first such subtype first, thus using its name. */
1734 && Present (Ancestor_Subtype (gnat_entity))
1735 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1736 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1737 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1738 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1740 /* Set the precision to the Esize except for bit-packed arrays. */
1741 if (Is_Packed_Array_Type (gnat_entity)
1742 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1743 esize = UI_To_Int (RM_Size (gnat_entity));
1745 /* This should be an unsigned type if the base type is unsigned or
1746 if the lower bound is constant and non-negative or if the type
1748 if (Is_Unsigned_Type (Etype (gnat_entity))
1749 || Is_Unsigned_Type (gnat_entity)
1750 || Has_Biased_Representation (gnat_entity))
1751 gnu_type = make_unsigned_type (esize);
1753 gnu_type = make_signed_type (esize);
1754 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1756 SET_TYPE_RM_MIN_VALUE
1758 convert (TREE_TYPE (gnu_type),
1759 elaborate_expression (Type_Low_Bound (gnat_entity),
1760 gnat_entity, get_identifier ("L"),
1762 Needs_Debug_Info (gnat_entity))));
1764 SET_TYPE_RM_MAX_VALUE
1766 convert (TREE_TYPE (gnu_type),
1767 elaborate_expression (Type_High_Bound (gnat_entity),
1768 gnat_entity, get_identifier ("U"),
1770 Needs_Debug_Info (gnat_entity))));
1772 /* One of the above calls might have caused us to be elaborated,
1773 so don't blow up if so. */
1774 if (present_gnu_tree (gnat_entity))
1776 maybe_present = true;
1780 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1781 = Has_Biased_Representation (gnat_entity);
1783 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1784 TYPE_STUB_DECL (gnu_type)
1785 = create_type_stub_decl (gnu_entity_name, gnu_type);
1787 /* Inherit our alias set from what we're a subtype of. Subtypes
1788 are not different types and a pointer can designate any instance
1789 within a subtype hierarchy. */
1790 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1792 /* For a packed array, make the original array type a parallel type. */
1794 && Is_Packed_Array_Type (gnat_entity)
1795 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1796 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1798 (Original_Array_Type (gnat_entity)));
1802 /* We have to handle clauses that under-align the type specially. */
1803 if ((Present (Alignment_Clause (gnat_entity))
1804 || (Is_Packed_Array_Type (gnat_entity)
1806 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1807 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1809 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1810 if (align >= TYPE_ALIGN (gnu_type))
1814 /* If the type we are dealing with represents a bit-packed array,
1815 we need to have the bits left justified on big-endian targets
1816 and right justified on little-endian targets. We also need to
1817 ensure that when the value is read (e.g. for comparison of two
1818 such values), we only get the good bits, since the unused bits
1819 are uninitialized. Both goals are accomplished by wrapping up
1820 the modular type in an enclosing record type. */
1821 if (Is_Packed_Array_Type (gnat_entity)
1822 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1824 tree gnu_field_type, gnu_field;
1826 /* Set the RM size before wrapping up the original type. */
1827 SET_TYPE_RM_SIZE (gnu_type,
1828 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1829 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1831 /* Create a stripped-down declaration, mainly for debugging. */
1832 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1833 debug_info_p, gnat_entity);
1835 /* Now save it and build the enclosing record type. */
1836 gnu_field_type = gnu_type;
1838 gnu_type = make_node (RECORD_TYPE);
1839 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1840 TYPE_PACKED (gnu_type) = 1;
1841 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1842 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1843 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1845 /* Propagate the alignment of the modular type to the record type,
1846 unless there is an alignment clause that under-aligns the type.
1847 This means that bit-packed arrays are given "ceil" alignment for
1848 their size by default, which may seem counter-intuitive but makes
1849 it possible to overlay them on modular types easily. */
1850 TYPE_ALIGN (gnu_type)
1851 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1853 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1855 /* Don't declare the field as addressable since we won't be taking
1856 its address and this would prevent create_field_decl from making
1859 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1860 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1862 /* Do not emit debug info until after the parallel type is added. */
1863 finish_record_type (gnu_type, gnu_field, 2, false);
1864 compute_record_mode (gnu_type);
1865 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1869 /* Make the original array type a parallel type. */
1870 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1871 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1873 (Original_Array_Type (gnat_entity)));
1875 rest_of_record_type_compilation (gnu_type);
1879 /* If the type we are dealing with has got a smaller alignment than the
1880 natural one, we need to wrap it up in a record type and under-align
1881 the latter. We reuse the padding machinery for this purpose. */
1884 tree gnu_field_type, gnu_field;
1886 /* Set the RM size before wrapping up the type. */
1887 SET_TYPE_RM_SIZE (gnu_type,
1888 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1890 /* Create a stripped-down declaration, mainly for debugging. */
1891 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1892 debug_info_p, gnat_entity);
1894 /* Now save it and build the enclosing record type. */
1895 gnu_field_type = gnu_type;
1897 gnu_type = make_node (RECORD_TYPE);
1898 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1899 TYPE_PACKED (gnu_type) = 1;
1900 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1901 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1902 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1903 TYPE_ALIGN (gnu_type) = align;
1904 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1906 /* Don't declare the field as addressable since we won't be taking
1907 its address and this would prevent create_field_decl from making
1910 = create_field_decl (get_identifier ("F"), gnu_field_type,
1911 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1913 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1914 compute_record_mode (gnu_type);
1915 TYPE_PADDING_P (gnu_type) = 1;
1920 case E_Floating_Point_Type:
1921 /* If this is a VAX floating-point type, use an integer of the proper
1922 size. All the operations will be handled with ASM statements. */
1923 if (Vax_Float (gnat_entity))
1925 gnu_type = make_signed_type (esize);
1926 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1927 SET_TYPE_DIGITS_VALUE (gnu_type,
1928 UI_To_gnu (Digits_Value (gnat_entity),
1933 /* The type of the Low and High bounds can be our type if this is
1934 a type from Standard, so set them at the end of the function. */
1935 gnu_type = make_node (REAL_TYPE);
1936 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1937 layout_type (gnu_type);
1940 case E_Floating_Point_Subtype:
1941 if (Vax_Float (gnat_entity))
1943 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1949 && Present (Ancestor_Subtype (gnat_entity))
1950 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1951 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1952 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1953 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1956 gnu_type = make_node (REAL_TYPE);
1957 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1958 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1959 TYPE_GCC_MIN_VALUE (gnu_type)
1960 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1961 TYPE_GCC_MAX_VALUE (gnu_type)
1962 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1963 layout_type (gnu_type);
1965 SET_TYPE_RM_MIN_VALUE
1967 convert (TREE_TYPE (gnu_type),
1968 elaborate_expression (Type_Low_Bound (gnat_entity),
1969 gnat_entity, get_identifier ("L"),
1971 Needs_Debug_Info (gnat_entity))));
1973 SET_TYPE_RM_MAX_VALUE
1975 convert (TREE_TYPE (gnu_type),
1976 elaborate_expression (Type_High_Bound (gnat_entity),
1977 gnat_entity, get_identifier ("U"),
1979 Needs_Debug_Info (gnat_entity))));
1981 /* One of the above calls might have caused us to be elaborated,
1982 so don't blow up if so. */
1983 if (present_gnu_tree (gnat_entity))
1985 maybe_present = true;
1989 /* Inherit our alias set from what we're a subtype of, as for
1990 integer subtypes. */
1991 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1995 /* Array and String Types and Subtypes
1997 Unconstrained array types are represented by E_Array_Type and
1998 constrained array types are represented by E_Array_Subtype. There
1999 are no actual objects of an unconstrained array type; all we have
2000 are pointers to that type.
2002 The following fields are defined on array types and subtypes:
2004 Component_Type Component type of the array.
2005 Number_Dimensions Number of dimensions (an int).
2006 First_Index Type of first index. */
2011 const bool convention_fortran_p
2012 = (Convention (gnat_entity) == Convention_Fortran);
2013 const int ndim = Number_Dimensions (gnat_entity);
2014 tree gnu_template_type;
2015 tree gnu_ptr_template;
2016 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
2017 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2018 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2019 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
2020 Entity_Id gnat_index, gnat_name;
2024 /* Create the type for the component now, as it simplifies breaking
2025 type reference loops. */
2027 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2028 if (present_gnu_tree (gnat_entity))
2030 /* As a side effect, the type may have been translated. */
2031 maybe_present = true;
2035 /* We complete an existing dummy fat pointer type in place. This both
2036 avoids further complex adjustments in update_pointer_to and yields
2037 better debugging information in DWARF by leveraging the support for
2038 incomplete declarations of "tagged" types in the DWARF back-end. */
2039 gnu_type = get_dummy_type (gnat_entity);
2040 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2042 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2043 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2044 /* Save the contents of the dummy type for update_pointer_to. */
2045 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2047 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2048 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2052 gnu_fat_type = make_node (RECORD_TYPE);
2053 gnu_template_type = make_node (RECORD_TYPE);
2054 gnu_ptr_template = build_pointer_type (gnu_template_type);
2057 /* Make a node for the array. If we are not defining the array
2058 suppress expanding incomplete types. */
2059 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2063 defer_incomplete_level++;
2064 this_deferred = true;
2067 /* Build the fat pointer type. Use a "void *" object instead of
2068 a pointer to the array type since we don't have the array type
2069 yet (it will reference the fat pointer via the bounds). */
2071 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
2072 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2074 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
2075 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2077 if (COMPLETE_TYPE_P (gnu_fat_type))
2079 /* We are going to lay it out again so reset the alias set. */
2080 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
2081 TYPE_ALIAS_SET (gnu_fat_type) = -1;
2082 finish_fat_pointer_type (gnu_fat_type, tem);
2083 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
2084 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2086 TYPE_FIELDS (t) = tem;
2087 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2092 finish_fat_pointer_type (gnu_fat_type, tem);
2093 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2096 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2097 is the fat pointer. This will be used to access the individual
2098 fields once we build them. */
2099 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2100 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2101 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
2102 gnu_template_reference
2103 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2104 TREE_READONLY (gnu_template_reference) = 1;
2105 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2107 /* Now create the GCC type for each index and add the fields for that
2108 index to the template. */
2109 for (index = (convention_fortran_p ? ndim - 1 : 0),
2110 gnat_index = First_Index (gnat_entity);
2111 0 <= index && index < ndim;
2112 index += (convention_fortran_p ? - 1 : 1),
2113 gnat_index = Next_Index (gnat_index))
2115 char field_name[16];
2116 tree gnu_index_base_type
2117 = get_unpadded_type (Base_Type (Etype (gnat_index)));
2118 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2119 tree gnu_min, gnu_max, gnu_high;
2121 /* Make the FIELD_DECLs for the low and high bounds of this
2122 type and then make extractions of these fields from the
2124 sprintf (field_name, "LB%d", index);
2125 gnu_lb_field = create_field_decl (get_identifier (field_name),
2126 gnu_index_base_type,
2127 gnu_template_type, NULL_TREE,
2129 Sloc_to_locus (Sloc (gnat_entity),
2130 &DECL_SOURCE_LOCATION (gnu_lb_field));
2132 field_name[0] = 'U';
2133 gnu_hb_field = create_field_decl (get_identifier (field_name),
2134 gnu_index_base_type,
2135 gnu_template_type, NULL_TREE,
2137 Sloc_to_locus (Sloc (gnat_entity),
2138 &DECL_SOURCE_LOCATION (gnu_hb_field));
2140 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2142 /* We can't use build_component_ref here since the template type
2143 isn't complete yet. */
2144 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2145 gnu_template_reference, gnu_lb_field,
2147 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2148 gnu_template_reference, gnu_hb_field,
2150 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2152 gnu_min = convert (sizetype, gnu_orig_min);
2153 gnu_max = convert (sizetype, gnu_orig_max);
2155 /* Compute the size of this dimension. See the E_Array_Subtype
2156 case below for the rationale. */
2158 = build3 (COND_EXPR, sizetype,
2159 build2 (GE_EXPR, boolean_type_node,
2160 gnu_orig_max, gnu_orig_min),
2162 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2164 /* Make a range type with the new range in the Ada base type.
2165 Then make an index type with the size range in sizetype. */
2166 gnu_index_types[index]
2167 = create_index_type (gnu_min, gnu_high,
2168 create_range_type (gnu_index_base_type,
2173 /* Update the maximum size of the array in elements. */
2176 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2178 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2180 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2182 = size_binop (MAX_EXPR,
2183 size_binop (PLUS_EXPR, size_one_node,
2184 size_binop (MINUS_EXPR,
2188 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2189 && TREE_OVERFLOW (gnu_this_max))
2190 gnu_max_size = NULL_TREE;
2193 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2196 TYPE_NAME (gnu_index_types[index])
2197 = create_concat_name (gnat_entity, field_name);
2200 /* Install all the fields into the template. */
2201 TYPE_NAME (gnu_template_type)
2202 = create_concat_name (gnat_entity, "XUB");
2203 gnu_template_fields = NULL_TREE;
2204 for (index = 0; index < ndim; index++)
2206 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2207 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2209 TYPE_READONLY (gnu_template_type) = 1;
2211 /* Now build the array type. */
2213 /* If Component_Size is not already specified, annotate it with the
2214 size of the component. */
2215 if (Unknown_Component_Size (gnat_entity))
2216 Set_Component_Size (gnat_entity,
2217 annotate_value (TYPE_SIZE (comp_type)));
2219 /* Compute the maximum size of the array in units and bits. */
2222 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2223 TYPE_SIZE_UNIT (comp_type));
2224 gnu_max_size = size_binop (MULT_EXPR,
2225 convert (bitsizetype, gnu_max_size),
2226 TYPE_SIZE (comp_type));
2229 gnu_max_size_unit = NULL_TREE;
2231 /* Now build the array type. */
2233 for (index = ndim - 1; index >= 0; index--)
2235 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2236 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2237 if (array_type_has_nonaliased_component (tem, gnat_entity))
2238 TYPE_NONALIASED_COMPONENT (tem) = 1;
2241 /* If an alignment is specified, use it if valid. But ignore it
2242 for the original type of packed array types. If the alignment
2243 was requested with an explicit alignment clause, state so. */
2244 if (No (Packed_Array_Type (gnat_entity))
2245 && Known_Alignment (gnat_entity))
2248 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2250 if (Present (Alignment_Clause (gnat_entity)))
2251 TYPE_USER_ALIGN (tem) = 1;
2254 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2256 /* Adjust the type of the pointer-to-array field of the fat pointer
2257 and record the aliasing relationships if necessary. */
2258 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2259 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2260 record_component_aliases (gnu_fat_type);
2262 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2263 corresponding fat pointer. */
2264 TREE_TYPE (gnu_type) = gnu_fat_type;
2265 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2266 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2267 SET_TYPE_MODE (gnu_type, BLKmode);
2268 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2270 /* If the maximum size doesn't overflow, use it. */
2272 && TREE_CODE (gnu_max_size) == INTEGER_CST
2273 && !TREE_OVERFLOW (gnu_max_size)
2274 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2275 && !TREE_OVERFLOW (gnu_max_size_unit))
2277 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2279 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2280 TYPE_SIZE_UNIT (tem));
2283 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2284 tem, NULL, !Comes_From_Source (gnat_entity),
2285 debug_info_p, gnat_entity);
2287 /* Give the fat pointer type a name. If this is a packed type, tell
2288 the debugger how to interpret the underlying bits. */
2289 if (Present (Packed_Array_Type (gnat_entity)))
2290 gnat_name = Packed_Array_Type (gnat_entity);
2292 gnat_name = gnat_entity;
2293 create_type_decl (create_concat_name (gnat_name, "XUP"),
2294 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2295 debug_info_p, gnat_entity);
2297 /* Create the type to be used as what a thin pointer designates:
2298 a record type for the object and its template with the fields
2299 shifted to have the template at a negative offset. */
2300 tem = build_unc_object_type (gnu_template_type, tem,
2301 create_concat_name (gnat_name, "XUT"),
2303 shift_unc_components_for_thin_pointers (tem);
2305 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2306 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2310 case E_String_Subtype:
2311 case E_Array_Subtype:
2313 /* This is the actual data type for array variables. Multidimensional
2314 arrays are implemented as arrays of arrays. Note that arrays which
2315 have sparse enumeration subtypes as index components create sparse
2316 arrays, which is obviously space inefficient but so much easier to
2319 Also note that the subtype never refers to the unconstrained array
2320 type, which is somewhat at variance with Ada semantics.
2322 First check to see if this is simply a renaming of the array type.
2323 If so, the result is the array type. */
2325 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2326 if (!Is_Constrained (gnat_entity))
2330 Entity_Id gnat_index, gnat_base_index;
2331 const bool convention_fortran_p
2332 = (Convention (gnat_entity) == Convention_Fortran);
2333 const int ndim = Number_Dimensions (gnat_entity);
2334 tree gnu_base_type = gnu_type;
2335 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2336 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2337 bool need_index_type_struct = false;
2340 /* First create the GCC type for each index and find out whether
2341 special types are needed for debugging information. */
2342 for (index = (convention_fortran_p ? ndim - 1 : 0),
2343 gnat_index = First_Index (gnat_entity),
2345 = First_Index (Implementation_Base_Type (gnat_entity));
2346 0 <= index && index < ndim;
2347 index += (convention_fortran_p ? - 1 : 1),
2348 gnat_index = Next_Index (gnat_index),
2349 gnat_base_index = Next_Index (gnat_base_index))
2351 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2352 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2353 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2354 tree gnu_min = convert (sizetype, gnu_orig_min);
2355 tree gnu_max = convert (sizetype, gnu_orig_max);
2356 tree gnu_base_index_type
2357 = get_unpadded_type (Etype (gnat_base_index));
2358 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2359 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2362 /* See if the base array type is already flat. If it is, we
2363 are probably compiling an ACATS test but it will cause the
2364 code below to malfunction if we don't handle it specially. */
2365 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2366 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2367 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2369 gnu_min = size_one_node;
2370 gnu_max = size_zero_node;
2374 /* Similarly, if one of the values overflows in sizetype and the
2375 range is null, use 1..0 for the sizetype bounds. */
2376 else if (TREE_CODE (gnu_min) == INTEGER_CST
2377 && TREE_CODE (gnu_max) == INTEGER_CST
2378 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2379 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2381 gnu_min = size_one_node;
2382 gnu_max = size_zero_node;
2386 /* If the minimum and maximum values both overflow in sizetype,
2387 but the difference in the original type does not overflow in
2388 sizetype, ignore the overflow indication. */
2389 else if (TREE_CODE (gnu_min) == INTEGER_CST
2390 && TREE_CODE (gnu_max) == INTEGER_CST
2391 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2394 fold_build2 (MINUS_EXPR, gnu_index_type,
2398 TREE_OVERFLOW (gnu_min) = 0;
2399 TREE_OVERFLOW (gnu_max) = 0;
2403 /* Compute the size of this dimension in the general case. We
2404 need to provide GCC with an upper bound to use but have to
2405 deal with the "superflat" case. There are three ways to do
2406 this. If we can prove that the array can never be superflat,
2407 we can just use the high bound of the index type. */
2408 else if ((Nkind (gnat_index) == N_Range
2409 && cannot_be_superflat_p (gnat_index))
2410 /* Packed Array Types are never superflat. */
2411 || Is_Packed_Array_Type (gnat_entity))
2414 /* Otherwise, if the high bound is constant but the low bound is
2415 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2416 lower bound. Note that the comparison must be done in the
2417 original type to avoid any overflow during the conversion. */
2418 else if (TREE_CODE (gnu_max) == INTEGER_CST
2419 && TREE_CODE (gnu_min) != INTEGER_CST)
2423 = build_cond_expr (sizetype,
2424 build_binary_op (GE_EXPR,
2429 size_binop (PLUS_EXPR, gnu_max,
2433 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2434 in all the other cases. Note that, here as well as above,
2435 the condition used in the comparison must be equivalent to
2436 the condition (length != 0). This is relied upon in order
2437 to optimize array comparisons in compare_arrays. */
2440 = build_cond_expr (sizetype,
2441 build_binary_op (GE_EXPR,
2446 size_binop (MINUS_EXPR, gnu_min,
2449 /* Reuse the index type for the range type. Then make an index
2450 type with the size range in sizetype. */
2451 gnu_index_types[index]
2452 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2455 /* Update the maximum size of the array in elements. Here we
2456 see if any constraint on the index type of the base type
2457 can be used in the case of self-referential bound on the
2458 index type of the subtype. We look for a non-"infinite"
2459 and non-self-referential bound from any type involved and
2460 handle each bound separately. */
2463 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2464 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2465 tree gnu_base_index_base_type
2466 = get_base_type (gnu_base_index_type);
2467 tree gnu_base_base_min
2468 = convert (sizetype,
2469 TYPE_MIN_VALUE (gnu_base_index_base_type));
2470 tree gnu_base_base_max
2471 = convert (sizetype,
2472 TYPE_MAX_VALUE (gnu_base_index_base_type));
2474 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2475 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2476 && !TREE_OVERFLOW (gnu_base_min)))
2477 gnu_base_min = gnu_min;
2479 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2480 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2481 && !TREE_OVERFLOW (gnu_base_max)))
2482 gnu_base_max = gnu_max;
2484 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2485 && TREE_OVERFLOW (gnu_base_min))
2486 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2487 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2488 && TREE_OVERFLOW (gnu_base_max))
2489 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2490 gnu_max_size = NULL_TREE;
2494 = size_binop (MAX_EXPR,
2495 size_binop (PLUS_EXPR, size_one_node,
2496 size_binop (MINUS_EXPR,
2501 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2502 && TREE_OVERFLOW (gnu_this_max))
2503 gnu_max_size = NULL_TREE;
2506 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2510 /* We need special types for debugging information to point to
2511 the index types if they have variable bounds, are not integer
2512 types, are biased or are wider than sizetype. */
2513 if (!integer_onep (gnu_orig_min)
2514 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2515 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2516 || (TREE_TYPE (gnu_index_type)
2517 && TREE_CODE (TREE_TYPE (gnu_index_type))
2519 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2520 || compare_tree_int (rm_size (gnu_index_type),
2521 TYPE_PRECISION (sizetype)) > 0)
2522 need_index_type_struct = true;
2525 /* Then flatten: create the array of arrays. For an array type
2526 used to implement a packed array, get the component type from
2527 the original array type since the representation clauses that
2528 can affect it are on the latter. */
2529 if (Is_Packed_Array_Type (gnat_entity)
2530 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2532 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2533 for (index = ndim - 1; index >= 0; index--)
2534 gnu_type = TREE_TYPE (gnu_type);
2536 /* One of the above calls might have caused us to be elaborated,
2537 so don't blow up if so. */
2538 if (present_gnu_tree (gnat_entity))
2540 maybe_present = true;
2546 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2549 /* One of the above calls might have caused us to be elaborated,
2550 so don't blow up if so. */
2551 if (present_gnu_tree (gnat_entity))
2553 maybe_present = true;
2558 /* Compute the maximum size of the array in units and bits. */
2561 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2562 TYPE_SIZE_UNIT (gnu_type));
2563 gnu_max_size = size_binop (MULT_EXPR,
2564 convert (bitsizetype, gnu_max_size),
2565 TYPE_SIZE (gnu_type));
2568 gnu_max_size_unit = NULL_TREE;
2570 /* Now build the array type. */
2571 for (index = ndim - 1; index >= 0; index --)
2573 gnu_type = build_nonshared_array_type (gnu_type,
2574 gnu_index_types[index]);
2575 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2576 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2577 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2580 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2581 TYPE_STUB_DECL (gnu_type)
2582 = create_type_stub_decl (gnu_entity_name, gnu_type);
2584 /* If we are at file level and this is a multi-dimensional array,
2585 we need to make a variable corresponding to the stride of the
2586 inner dimensions. */
2587 if (global_bindings_p () && ndim > 1)
2589 tree gnu_st_name = get_identifier ("ST");
2592 for (gnu_arr_type = TREE_TYPE (gnu_type);
2593 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2594 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2595 gnu_st_name = concat_name (gnu_st_name, "ST"))
2597 tree eltype = TREE_TYPE (gnu_arr_type);
2599 TYPE_SIZE (gnu_arr_type)
2600 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2601 gnat_entity, gnu_st_name,
2604 /* ??? For now, store the size as a multiple of the
2605 alignment of the element type in bytes so that we
2606 can see the alignment from the tree. */
2607 TYPE_SIZE_UNIT (gnu_arr_type)
2608 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2610 concat_name (gnu_st_name, "A_U"),
2612 TYPE_ALIGN (eltype));
2614 /* ??? create_type_decl is not invoked on the inner types so
2615 the MULT_EXPR node built above will never be marked. */
2616 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2620 /* If we need to write out a record type giving the names of the
2621 bounds for debugging purposes, do it now and make the record
2622 type a parallel type. This is not needed for a packed array
2623 since the bounds are conveyed by the original array type. */
2624 if (need_index_type_struct
2626 && !Is_Packed_Array_Type (gnat_entity))
2628 tree gnu_bound_rec = make_node (RECORD_TYPE);
2629 tree gnu_field_list = NULL_TREE;
2632 TYPE_NAME (gnu_bound_rec)
2633 = create_concat_name (gnat_entity, "XA");
2635 for (index = ndim - 1; index >= 0; index--)
2637 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2638 tree gnu_index_name = TYPE_NAME (gnu_index);
2640 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2641 gnu_index_name = DECL_NAME (gnu_index_name);
2643 /* Make sure to reference the types themselves, and not just
2644 their names, as the debugger may fall back on them. */
2645 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2646 gnu_bound_rec, NULL_TREE,
2648 DECL_CHAIN (gnu_field) = gnu_field_list;
2649 gnu_field_list = gnu_field;
2652 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2653 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2656 /* If this is a packed array type, make the original array type a
2657 parallel type. Otherwise, do it for the base array type if it
2658 isn't artificial to make sure it is kept in the debug info. */
2661 if (Is_Packed_Array_Type (gnat_entity)
2662 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2663 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2665 (Original_Array_Type (gnat_entity)));
2669 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2670 if (!DECL_ARTIFICIAL (gnu_base_decl))
2671 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2672 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2676 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2677 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2678 = (Is_Packed_Array_Type (gnat_entity)
2679 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2681 /* If the size is self-referential and the maximum size doesn't
2682 overflow, use it. */
2683 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2685 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2686 && TREE_OVERFLOW (gnu_max_size))
2687 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2688 && TREE_OVERFLOW (gnu_max_size_unit)))
2690 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2691 TYPE_SIZE (gnu_type));
2692 TYPE_SIZE_UNIT (gnu_type)
2693 = size_binop (MIN_EXPR, gnu_max_size_unit,
2694 TYPE_SIZE_UNIT (gnu_type));
2697 /* Set our alias set to that of our base type. This gives all
2698 array subtypes the same alias set. */
2699 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2701 /* If this is a packed type, make this type the same as the packed
2702 array type, but do some adjusting in the type first. */
2703 if (Present (Packed_Array_Type (gnat_entity)))
2705 Entity_Id gnat_index;
2708 /* First finish the type we had been making so that we output
2709 debugging information for it. */
2710 if (Treat_As_Volatile (gnat_entity))
2712 = build_qualified_type (gnu_type,
2713 TYPE_QUALS (gnu_type)
2714 | TYPE_QUAL_VOLATILE);
2716 /* Make it artificial only if the base type was artificial too.
2717 That's sort of "morally" true and will make it possible for
2718 the debugger to look it up by name in DWARF, which is needed
2719 in order to decode the packed array type. */
2721 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2722 !Comes_From_Source (Etype (gnat_entity))
2723 && !Comes_From_Source (gnat_entity),
2724 debug_info_p, gnat_entity);
2726 /* Save it as our equivalent in case the call below elaborates
2728 save_gnu_tree (gnat_entity, gnu_decl, false);
2730 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2732 this_made_decl = true;
2733 gnu_type = TREE_TYPE (gnu_decl);
2734 save_gnu_tree (gnat_entity, NULL_TREE, false);
2736 gnu_inner = gnu_type;
2737 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2738 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2739 || TYPE_PADDING_P (gnu_inner)))
2740 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2742 /* We need to attach the index type to the type we just made so
2743 that the actual bounds can later be put into a template. */
2744 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2745 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2746 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2747 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2749 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2751 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2752 TYPE_MODULUS for modular types so we make an extra
2753 subtype if necessary. */
2754 if (TYPE_MODULAR_P (gnu_inner))
2757 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2758 TREE_TYPE (gnu_subtype) = gnu_inner;
2759 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2760 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2761 TYPE_MIN_VALUE (gnu_inner));
2762 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2763 TYPE_MAX_VALUE (gnu_inner));
2764 gnu_inner = gnu_subtype;
2767 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2769 #ifdef ENABLE_CHECKING
2770 /* Check for other cases of overloading. */
2771 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2775 for (gnat_index = First_Index (gnat_entity);
2776 Present (gnat_index);
2777 gnat_index = Next_Index (gnat_index))
2778 SET_TYPE_ACTUAL_BOUNDS
2780 tree_cons (NULL_TREE,
2781 get_unpadded_type (Etype (gnat_index)),
2782 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2784 if (Convention (gnat_entity) != Convention_Fortran)
2785 SET_TYPE_ACTUAL_BOUNDS
2786 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2788 if (TREE_CODE (gnu_type) == RECORD_TYPE
2789 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2790 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2795 /* Abort if packed array with no Packed_Array_Type field set. */
2796 gcc_assert (!Is_Packed (gnat_entity));
2800 case E_String_Literal_Subtype:
2801 /* Create the type for a string literal. */
2803 Entity_Id gnat_full_type
2804 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2805 && Present (Full_View (Etype (gnat_entity)))
2806 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2807 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2808 tree gnu_string_array_type
2809 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2810 tree gnu_string_index_type
2811 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2812 (TYPE_DOMAIN (gnu_string_array_type))));
2813 tree gnu_lower_bound
2814 = convert (gnu_string_index_type,
2815 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2816 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2817 tree gnu_length = ssize_int (length - 1);
2818 tree gnu_upper_bound
2819 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2821 convert (gnu_string_index_type, gnu_length));
2823 = create_index_type (convert (sizetype, gnu_lower_bound),
2824 convert (sizetype, gnu_upper_bound),
2825 create_range_type (gnu_string_index_type,
2831 = build_nonshared_array_type (gnat_to_gnu_type
2832 (Component_Type (gnat_entity)),
2834 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2835 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2836 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2840 /* Record Types and Subtypes
2842 The following fields are defined on record types:
2844 Has_Discriminants True if the record has discriminants
2845 First_Discriminant Points to head of list of discriminants
2846 First_Entity Points to head of list of fields
2847 Is_Tagged_Type True if the record is tagged
2849 Implementation of Ada records and discriminated records:
2851 A record type definition is transformed into the equivalent of a C
2852 struct definition. The fields that are the discriminants which are
2853 found in the Full_Type_Declaration node and the elements of the
2854 Component_List found in the Record_Type_Definition node. The
2855 Component_List can be a recursive structure since each Variant of
2856 the Variant_Part of the Component_List has a Component_List.
2858 Processing of a record type definition comprises starting the list of
2859 field declarations here from the discriminants and the calling the
2860 function components_to_record to add the rest of the fields from the
2861 component list and return the gnu type node. The function
2862 components_to_record will call itself recursively as it traverses
2866 if (Has_Complex_Representation (gnat_entity))
2869 = build_complex_type
2871 (Etype (Defining_Entity
2872 (First (Component_Items
2875 (Declaration_Node (gnat_entity)))))))));
2881 Node_Id full_definition = Declaration_Node (gnat_entity);
2882 Node_Id record_definition = Type_Definition (full_definition);
2883 Entity_Id gnat_field;
2884 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2885 /* Set PACKED in keeping with gnat_to_gnu_field. */
2887 = Is_Packed (gnat_entity)
2889 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2891 : (Known_Alignment (gnat_entity)
2892 || (Strict_Alignment (gnat_entity)
2893 && Known_RM_Size (gnat_entity)))
2896 bool has_discr = Has_Discriminants (gnat_entity);
2897 bool has_rep = Has_Specified_Layout (gnat_entity);
2898 bool all_rep = has_rep;
2900 = (Is_Tagged_Type (gnat_entity)
2901 && Nkind (record_definition) == N_Derived_Type_Definition);
2902 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2904 /* See if all fields have a rep clause. Stop when we find one
2907 for (gnat_field = First_Entity (gnat_entity);
2908 Present (gnat_field);
2909 gnat_field = Next_Entity (gnat_field))
2910 if ((Ekind (gnat_field) == E_Component
2911 || Ekind (gnat_field) == E_Discriminant)
2912 && No (Component_Clause (gnat_field)))
2918 /* If this is a record extension, go a level further to find the
2919 record definition. Also, verify we have a Parent_Subtype. */
2922 if (!type_annotate_only
2923 || Present (Record_Extension_Part (record_definition)))
2924 record_definition = Record_Extension_Part (record_definition);
2926 gcc_assert (type_annotate_only
2927 || Present (Parent_Subtype (gnat_entity)));
2930 /* Make a node for the record. If we are not defining the record,
2931 suppress expanding incomplete types. */
2932 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2933 TYPE_NAME (gnu_type) = gnu_entity_name;
2934 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2938 defer_incomplete_level++;
2939 this_deferred = true;
2942 /* If both a size and rep clause was specified, put the size in
2943 the record type now so that it can get the proper mode. */
2944 if (has_rep && Known_RM_Size (gnat_entity))
2945 TYPE_SIZE (gnu_type)
2946 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2948 /* Always set the alignment here so that it can be used to
2949 set the mode, if it is making the alignment stricter. If
2950 it is invalid, it will be checked again below. If this is to
2951 be Atomic, choose a default alignment of a word unless we know
2952 the size and it's smaller. */
2953 if (Known_Alignment (gnat_entity))
2954 TYPE_ALIGN (gnu_type)
2955 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2956 else if (Is_Atomic (gnat_entity))
2957 TYPE_ALIGN (gnu_type)
2958 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2959 /* If a type needs strict alignment, the minimum size will be the
2960 type size instead of the RM size (see validate_size). Cap the
2961 alignment, lest it causes this type size to become too large. */
2962 else if (Strict_Alignment (gnat_entity)
2963 && Known_RM_Size (gnat_entity))
2965 unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity));
2966 unsigned int raw_align = raw_size & -raw_size;
2967 if (raw_align < BIGGEST_ALIGNMENT)
2968 TYPE_ALIGN (gnu_type) = raw_align;
2971 TYPE_ALIGN (gnu_type) = 0;
2973 /* If we have a Parent_Subtype, make a field for the parent. If
2974 this record has rep clauses, force the position to zero. */
2975 if (Present (Parent_Subtype (gnat_entity)))
2977 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2980 /* A major complexity here is that the parent subtype will
2981 reference our discriminants in its Discriminant_Constraint
2982 list. But those must reference the parent component of this
2983 record which is of the parent subtype we have not built yet!
2984 To break the circle we first build a dummy COMPONENT_REF which
2985 represents the "get to the parent" operation and initialize
2986 each of those discriminants to a COMPONENT_REF of the above
2987 dummy parent referencing the corresponding discriminant of the
2988 base type of the parent subtype. */
2989 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2990 build0 (PLACEHOLDER_EXPR, gnu_type),
2991 build_decl (input_location,
2992 FIELD_DECL, NULL_TREE,
2997 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2998 Present (gnat_field);
2999 gnat_field = Next_Stored_Discriminant (gnat_field))
3000 if (Present (Corresponding_Discriminant (gnat_field)))
3003 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3007 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3008 gnu_get_parent, gnu_field, NULL_TREE),
3012 /* Then we build the parent subtype. If it has discriminants but
3013 the type itself has unknown discriminants, this means that it
3014 doesn't contain information about how the discriminants are
3015 derived from those of the ancestor type, so it cannot be used
3016 directly. Instead it is built by cloning the parent subtype
3017 of the underlying record view of the type, for which the above
3018 derivation of discriminants has been made explicit. */
3019 if (Has_Discriminants (gnat_parent)
3020 && Has_Unknown_Discriminants (gnat_entity))
3022 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3024 /* If we are defining the type, the underlying record
3025 view must already have been elaborated at this point.
3026 Otherwise do it now as its parent subtype cannot be
3027 technically elaborated on its own. */
3029 gcc_assert (present_gnu_tree (gnat_uview));
3031 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
3033 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3035 /* Substitute the "get to the parent" of the type for that
3036 of its underlying record view in the cloned type. */
3037 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3038 Present (gnat_field);
3039 gnat_field = Next_Stored_Discriminant (gnat_field))
3040 if (Present (Corresponding_Discriminant (gnat_field)))
3042 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3044 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3045 gnu_get_parent, gnu_field, NULL_TREE);
3047 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3051 gnu_parent = gnat_to_gnu_type (gnat_parent);
3053 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3054 initially built. The discriminants must reference the fields
3055 of the parent subtype and not those of its base type for the
3056 placeholder machinery to properly work. */
3059 /* The actual parent subtype is the full view. */
3060 if (IN (Ekind (gnat_parent), Private_Kind))
3062 if (Present (Full_View (gnat_parent)))
3063 gnat_parent = Full_View (gnat_parent);
3065 gnat_parent = Underlying_Full_View (gnat_parent);
3068 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3069 Present (gnat_field);
3070 gnat_field = Next_Stored_Discriminant (gnat_field))
3071 if (Present (Corresponding_Discriminant (gnat_field)))
3073 Entity_Id field = Empty;
3074 for (field = First_Stored_Discriminant (gnat_parent);
3076 field = Next_Stored_Discriminant (field))
3077 if (same_discriminant_p (gnat_field, field))
3079 gcc_assert (Present (field));
3080 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3081 = gnat_to_gnu_field_decl (field);
3085 /* The "get to the parent" COMPONENT_REF must be given its
3087 TREE_TYPE (gnu_get_parent) = gnu_parent;
3089 /* ...and reference the _Parent field of this record. */
3091 = create_field_decl (parent_name_id,
3092 gnu_parent, gnu_type,
3094 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3096 ? bitsize_zero_node : NULL_TREE,
3098 DECL_INTERNAL_P (gnu_field) = 1;
3099 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3100 TYPE_FIELDS (gnu_type) = gnu_field;
3103 /* Make the fields for the discriminants and put them into the record
3104 unless it's an Unchecked_Union. */
3106 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3107 Present (gnat_field);
3108 gnat_field = Next_Stored_Discriminant (gnat_field))
3110 /* If this is a record extension and this discriminant is the
3111 renaming of another discriminant, we've handled it above. */
3112 if (Present (Parent_Subtype (gnat_entity))
3113 && Present (Corresponding_Discriminant (gnat_field)))
3117 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3120 /* Make an expression using a PLACEHOLDER_EXPR from the
3121 FIELD_DECL node just created and link that with the
3122 corresponding GNAT defining identifier. */
3123 save_gnu_tree (gnat_field,
3124 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3125 build0 (PLACEHOLDER_EXPR, gnu_type),
3126 gnu_field, NULL_TREE),
3129 if (!is_unchecked_union)
3131 DECL_CHAIN (gnu_field) = gnu_field_list;
3132 gnu_field_list = gnu_field;
3136 /* Add the fields into the record type and finish it up. */
3137 components_to_record (gnu_type, Component_List (record_definition),
3138 gnu_field_list, packed, definition, false,
3139 all_rep, is_unchecked_union,
3140 !Comes_From_Source (gnat_entity), debug_info_p,
3141 false, OK_To_Reorder_Components (gnat_entity),
3142 all_rep ? NULL_TREE : bitsize_zero_node, NULL);
3144 /* If it is passed by reference, force BLKmode to ensure that objects
3145 of this type will always be put in memory. */
3146 if (Is_By_Reference_Type (gnat_entity))
3147 SET_TYPE_MODE (gnu_type, BLKmode);
3149 /* We used to remove the associations of the discriminants and _Parent
3150 for validity checking but we may need them if there's a Freeze_Node
3151 for a subtype used in this record. */
3152 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3154 /* Fill in locations of fields. */
3155 annotate_rep (gnat_entity, gnu_type);
3157 /* If there are any entities in the chain corresponding to components
3158 that we did not elaborate, ensure we elaborate their types if they
3160 for (gnat_temp = First_Entity (gnat_entity);
3161 Present (gnat_temp);
3162 gnat_temp = Next_Entity (gnat_temp))
3163 if ((Ekind (gnat_temp) == E_Component
3164 || Ekind (gnat_temp) == E_Discriminant)
3165 && Is_Itype (Etype (gnat_temp))
3166 && !present_gnu_tree (gnat_temp))
3167 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3169 /* If this is a record type associated with an exception definition,
3170 equate its fields to those of the standard exception type. This
3171 will make it possible to convert between them. */
3172 if (gnu_entity_name == exception_data_name_id)
3175 for (gnu_field = TYPE_FIELDS (gnu_type),
3176 gnu_std_field = TYPE_FIELDS (except_type_node);
3178 gnu_field = DECL_CHAIN (gnu_field),
3179 gnu_std_field = DECL_CHAIN (gnu_std_field))
3180 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3181 gcc_assert (!gnu_std_field);
3186 case E_Class_Wide_Subtype:
3187 /* If an equivalent type is present, that is what we should use.
3188 Otherwise, fall through to handle this like a record subtype
3189 since it may have constraints. */
3190 if (gnat_equiv_type != gnat_entity)
3192 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3193 maybe_present = true;
3197 /* ... fall through ... */
3199 case E_Record_Subtype:
3200 /* If Cloned_Subtype is Present it means this record subtype has
3201 identical layout to that type or subtype and we should use
3202 that GCC type for this one. The front end guarantees that
3203 the component list is shared. */
3204 if (Present (Cloned_Subtype (gnat_entity)))
3206 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3208 maybe_present = true;
3212 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3213 changing the type, make a new type with each field having the type of
3214 the field in the new subtype but the position computed by transforming
3215 every discriminant reference according to the constraints. We don't
3216 see any difference between private and non-private type here since
3217 derivations from types should have been deferred until the completion
3218 of the private type. */
3221 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3226 defer_incomplete_level++;
3227 this_deferred = true;
3230 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
3232 if (present_gnu_tree (gnat_entity))
3234 maybe_present = true;
3238 /* If this is a record subtype associated with a dispatch table,
3239 strip the suffix. This is necessary to make sure 2 different
3240 subtypes associated with the imported and exported views of a
3241 dispatch table are properly merged in LTO mode. */
3242 if (Is_Dispatch_Table_Entity (gnat_entity))
3245 Get_Encoded_Name (gnat_entity);
3246 p = strchr (Name_Buffer, '_');
3248 strcpy (p+2, "dtS");
3249 gnu_entity_name = get_identifier (Name_Buffer);
3252 /* When the subtype has discriminants and these discriminants affect
3253 the initial shape it has inherited, factor them in. But for an
3254 Unchecked_Union (it must be an Itype), just return the type.
3255 We can't just test Is_Constrained because private subtypes without
3256 discriminants of types with discriminants with default expressions
3257 are Is_Constrained but aren't constrained! */
3258 if (IN (Ekind (gnat_base_type), Record_Kind)
3259 && !Is_Unchecked_Union (gnat_base_type)
3260 && !Is_For_Access_Subtype (gnat_entity)
3261 && Is_Constrained (gnat_entity)
3262 && Has_Discriminants (gnat_entity)
3263 && Present (Discriminant_Constraint (gnat_entity))
3264 && Stored_Constraint (gnat_entity) != No_Elist)
3266 VEC(subst_pair,heap) *gnu_subst_list
3267 = build_subst_list (gnat_entity, gnat_base_type, definition);
3268 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
3269 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3270 bool selected_variant = false;
3271 Entity_Id gnat_field;
3272 VEC(variant_desc,heap) *gnu_variant_list;
3274 gnu_type = make_node (RECORD_TYPE);
3275 TYPE_NAME (gnu_type) = gnu_entity_name;
3277 /* Set the size, alignment and alias set of the new type to
3278 match that of the old one, doing required substitutions. */
3279 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3282 if (TYPE_IS_PADDING_P (gnu_base_type))
3283 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3285 gnu_unpad_base_type = gnu_base_type;
3287 /* Look for a REP part in the base type. */
3288 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3290 /* Look for a variant part in the base type. */
3291 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3293 /* If there is a variant part, we must compute whether the
3294 constraints statically select a particular variant. If
3295 so, we simply drop the qualified union and flatten the
3296 list of fields. Otherwise we'll build a new qualified
3297 union for the variants that are still relevant. */
3298 if (gnu_variant_part)
3304 = build_variant_list (TREE_TYPE (gnu_variant_part),
3305 gnu_subst_list, NULL);
3307 /* If all the qualifiers are unconditionally true, the
3308 innermost variant is statically selected. */
3309 selected_variant = true;
3310 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3312 if (!integer_onep (v->qual))
3314 selected_variant = false;
3318 /* Otherwise, create the new variants. */
3319 if (!selected_variant)
3320 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3323 tree old_variant = v->type;
3324 tree new_variant = make_node (RECORD_TYPE);
3325 TYPE_NAME (new_variant)
3326 = DECL_NAME (TYPE_NAME (old_variant));
3327 copy_and_substitute_in_size (new_variant, old_variant,
3329 v->record = new_variant;
3334 gnu_variant_list = NULL;
3335 selected_variant = false;
3339 = build_position_list (gnu_unpad_base_type,
3340 gnu_variant_list && !selected_variant,
3341 size_zero_node, bitsize_zero_node,
3342 BIGGEST_ALIGNMENT, NULL_TREE);
3344 for (gnat_field = First_Entity (gnat_entity);
3345 Present (gnat_field);
3346 gnat_field = Next_Entity (gnat_field))
3347 if ((Ekind (gnat_field) == E_Component
3348 || Ekind (gnat_field) == E_Discriminant)
3349 && !(Present (Corresponding_Discriminant (gnat_field))
3350 && Is_Tagged_Type (gnat_base_type))
3351 && Underlying_Type (Scope (Original_Record_Component
3355 Name_Id gnat_name = Chars (gnat_field);
3356 Entity_Id gnat_old_field
3357 = Original_Record_Component (gnat_field);
3359 = gnat_to_gnu_field_decl (gnat_old_field);
3360 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3361 tree gnu_field, gnu_field_type, gnu_size;
3362 tree gnu_cont_type, gnu_last = NULL_TREE;
3364 /* If the type is the same, retrieve the GCC type from the
3365 old field to take into account possible adjustments. */
3366 if (Etype (gnat_field) == Etype (gnat_old_field))
3367 gnu_field_type = TREE_TYPE (gnu_old_field);
3369 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3371 /* If there was a component clause, the field types must be
3372 the same for the type and subtype, so copy the data from
3373 the old field to avoid recomputation here. Also if the
3374 field is justified modular and the optimization in
3375 gnat_to_gnu_field was applied. */
3376 if (Present (Component_Clause (gnat_old_field))
3377 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3378 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3379 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3380 == TREE_TYPE (gnu_old_field)))
3382 gnu_size = DECL_SIZE (gnu_old_field);
3383 gnu_field_type = TREE_TYPE (gnu_old_field);
3386 /* If the old field was packed and of constant size, we
3387 have to get the old size here, as it might differ from
3388 what the Etype conveys and the latter might overlap
3389 onto the following field. Try to arrange the type for
3390 possible better packing along the way. */
3391 else if (DECL_PACKED (gnu_old_field)
3392 && TREE_CODE (DECL_SIZE (gnu_old_field))
3395 gnu_size = DECL_SIZE (gnu_old_field);
3396 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
3397 && !TYPE_FAT_POINTER_P (gnu_field_type)
3398 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3400 = make_packable_type (gnu_field_type, true);
3404 gnu_size = TYPE_SIZE (gnu_field_type);
3406 /* If the context of the old field is the base type or its
3407 REP part (if any), put the field directly in the new
3408 type; otherwise look up the context in the variant list
3409 and put the field either in the new type if there is a
3410 selected variant or in one of the new variants. */
3411 if (gnu_context == gnu_unpad_base_type
3413 && gnu_context == TREE_TYPE (gnu_rep_part)))
3414 gnu_cont_type = gnu_type;
3421 FOR_EACH_VEC_ELT_REVERSE (variant_desc,
3422 gnu_variant_list, ix, v)
3423 if (v->type == gnu_context)
3430 if (selected_variant)
3431 gnu_cont_type = gnu_type;
3433 gnu_cont_type = v->record;
3436 /* The front-end may pass us "ghost" components if
3437 it fails to recognize that a constrained subtype
3438 is statically constrained. Discard them. */
3442 /* Now create the new field modeled on the old one. */
3444 = create_field_decl_from (gnu_old_field, gnu_field_type,
3445 gnu_cont_type, gnu_size,
3446 gnu_pos_list, gnu_subst_list);
3448 /* Put it in one of the new variants directly. */
3449 if (gnu_cont_type != gnu_type)
3451 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3452 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3455 /* To match the layout crafted in components_to_record,
3456 if this is the _Tag or _Parent field, put it before
3457 any other fields. */
3458 else if (gnat_name == Name_uTag
3459 || gnat_name == Name_uParent)
3460 gnu_field_list = chainon (gnu_field_list, gnu_field);
3462 /* Similarly, if this is the _Controller field, put
3463 it before the other fields except for the _Tag or
3465 else if (gnat_name == Name_uController && gnu_last)
3467 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3468 DECL_CHAIN (gnu_last) = gnu_field;
3471 /* Otherwise, if this is a regular field, put it after
3472 the other fields. */
3475 DECL_CHAIN (gnu_field) = gnu_field_list;
3476 gnu_field_list = gnu_field;
3478 gnu_last = gnu_field;
3481 save_gnu_tree (gnat_field, gnu_field, false);
3484 /* If there is a variant list and no selected variant, we need
3485 to create the nest of variant parts from the old nest. */
3486 if (gnu_variant_list && !selected_variant)
3488 tree new_variant_part
3489 = create_variant_part_from (gnu_variant_part,
3490 gnu_variant_list, gnu_type,
3491 gnu_pos_list, gnu_subst_list);
3492 DECL_CHAIN (new_variant_part) = gnu_field_list;
3493 gnu_field_list = new_variant_part;
3496 /* Now go through the entities again looking for Itypes that
3497 we have not elaborated but should (e.g., Etypes of fields
3498 that have Original_Components). */
3499 for (gnat_field = First_Entity (gnat_entity);
3500 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3501 if ((Ekind (gnat_field) == E_Discriminant
3502 || Ekind (gnat_field) == E_Component)
3503 && !present_gnu_tree (Etype (gnat_field)))
3504 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3506 /* Do not emit debug info for the type yet since we're going to
3508 gnu_field_list = nreverse (gnu_field_list);
3509 finish_record_type (gnu_type, gnu_field_list, 2, false);
3511 /* See the E_Record_Type case for the rationale. */
3512 if (Is_By_Reference_Type (gnat_entity))
3513 SET_TYPE_MODE (gnu_type, BLKmode);
3515 compute_record_mode (gnu_type);
3517 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3519 /* Fill in locations of fields. */
3520 annotate_rep (gnat_entity, gnu_type);
3522 /* If debugging information is being written for the type, write
3523 a record that shows what we are a subtype of and also make a
3524 variable that indicates our size, if still variable. */
3527 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3528 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3529 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3531 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3532 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3534 TYPE_NAME (gnu_subtype_marker)
3535 = create_concat_name (gnat_entity, "XVS");
3536 finish_record_type (gnu_subtype_marker,
3537 create_field_decl (gnu_unpad_base_name,
3538 build_reference_type
3539 (gnu_unpad_base_type),
3541 NULL_TREE, NULL_TREE,
3545 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3546 gnu_subtype_marker);
3549 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3550 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3551 TYPE_SIZE_UNIT (gnu_subtype_marker)
3552 = create_var_decl (create_concat_name (gnat_entity,
3554 NULL_TREE, sizetype, gnu_size_unit,
3555 false, false, false, false, NULL,
3559 VEC_free (variant_desc, heap, gnu_variant_list);
3560 VEC_free (subst_pair, heap, gnu_subst_list);
3562 /* Now we can finalize it. */
3563 rest_of_record_type_compilation (gnu_type);
3566 /* Otherwise, go down all the components in the new type and make
3567 them equivalent to those in the base type. */
3570 gnu_type = gnu_base_type;
3572 for (gnat_temp = First_Entity (gnat_entity);
3573 Present (gnat_temp);
3574 gnat_temp = Next_Entity (gnat_temp))
3575 if ((Ekind (gnat_temp) == E_Discriminant
3576 && !Is_Unchecked_Union (gnat_base_type))
3577 || Ekind (gnat_temp) == E_Component)
3578 save_gnu_tree (gnat_temp,
3579 gnat_to_gnu_field_decl
3580 (Original_Record_Component (gnat_temp)),
3586 case E_Access_Subprogram_Type:
3587 /* Use the special descriptor type for dispatch tables if needed,
3588 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3589 Note that we are only required to do so for static tables in
3590 order to be compatible with the C++ ABI, but Ada 2005 allows
3591 to extend library level tagged types at the local level so
3592 we do it in the non-static case as well. */
3593 if (TARGET_VTABLE_USES_DESCRIPTORS
3594 && Is_Dispatch_Table_Entity (gnat_entity))
3596 gnu_type = fdesc_type_node;
3597 gnu_size = TYPE_SIZE (gnu_type);
3601 /* ... fall through ... */
3603 case E_Anonymous_Access_Subprogram_Type:
3604 /* If we are not defining this entity, and we have incomplete
3605 entities being processed above us, make a dummy type and
3606 fill it in later. */
3607 if (!definition && defer_incomplete_level != 0)
3609 struct incomplete *p = XNEW (struct incomplete);
3612 = build_pointer_type
3613 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3614 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3615 !Comes_From_Source (gnat_entity),
3616 debug_info_p, gnat_entity);
3617 this_made_decl = true;
3618 gnu_type = TREE_TYPE (gnu_decl);
3619 save_gnu_tree (gnat_entity, gnu_decl, false);
3622 p->old_type = TREE_TYPE (gnu_type);
3623 p->full_type = Directly_Designated_Type (gnat_entity);
3624 p->next = defer_incomplete_list;
3625 defer_incomplete_list = p;
3629 /* ... fall through ... */
3631 case E_Allocator_Type:
3633 case E_Access_Attribute_Type:
3634 case E_Anonymous_Access_Type:
3635 case E_General_Access_Type:
3637 /* The designated type and its equivalent type for gigi. */
3638 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3639 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3640 /* Whether it comes from a limited with. */
3641 bool is_from_limited_with
3642 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3643 && From_With_Type (gnat_desig_equiv));
3644 /* The "full view" of the designated type. If this is an incomplete
3645 entity from a limited with, treat its non-limited view as the full
3646 view. Otherwise, if this is an incomplete or private type, use the
3647 full view. In the former case, we might point to a private type,
3648 in which case, we need its full view. Also, we want to look at the
3649 actual type used for the representation, so this takes a total of
3651 Entity_Id gnat_desig_full_direct_first
3652 = (is_from_limited_with
3653 ? Non_Limited_View (gnat_desig_equiv)
3654 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3655 ? Full_View (gnat_desig_equiv) : Empty));
3656 Entity_Id gnat_desig_full_direct
3657 = ((is_from_limited_with
3658 && Present (gnat_desig_full_direct_first)
3659 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3660 ? Full_View (gnat_desig_full_direct_first)
3661 : gnat_desig_full_direct_first);
3662 Entity_Id gnat_desig_full
3663 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3664 /* The type actually used to represent the designated type, either
3665 gnat_desig_full or gnat_desig_equiv. */
3666 Entity_Id gnat_desig_rep;
3667 /* True if this is a pointer to an unconstrained array. */
3668 bool is_unconstrained_array;
3669 /* We want to know if we'll be seeing the freeze node for any
3670 incomplete type we may be pointing to. */
3672 = (Present (gnat_desig_full)
3673 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3674 : In_Extended_Main_Code_Unit (gnat_desig_type));
3675 /* True if we make a dummy type here. */
3676 bool made_dummy = false;
3677 /* The mode to be used for the pointer type. */
3678 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3679 /* The GCC type used for the designated type. */
3680 tree gnu_desig_type = NULL_TREE;
3682 if (!targetm.valid_pointer_mode (p_mode))
3685 /* If either the designated type or its full view is an unconstrained
3686 array subtype, replace it with the type it's a subtype of. This
3687 avoids problems with multiple copies of unconstrained array types.
3688 Likewise, if the designated type is a subtype of an incomplete
3689 record type, use the parent type to avoid order of elaboration
3690 issues. This can lose some code efficiency, but there is no
3692 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3693 && !Is_Constrained (gnat_desig_equiv))
3694 gnat_desig_equiv = Etype (gnat_desig_equiv);
3695 if (Present (gnat_desig_full)
3696 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3697 && !Is_Constrained (gnat_desig_full))
3698 || (Ekind (gnat_desig_full) == E_Record_Subtype
3699 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3700 gnat_desig_full = Etype (gnat_desig_full);
3702 /* Set the type that's actually the representation of the designated
3703 type and also flag whether we have a unconstrained array. */
3705 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3706 is_unconstrained_array
3707 = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
3709 /* If we are pointing to an incomplete type whose completion is an
3710 unconstrained array, make dummy fat and thin pointer types to it.
3711 Likewise if the type itself is dummy or an unconstrained array. */
3712 if (is_unconstrained_array
3713 && (Present (gnat_desig_full)
3714 || (present_gnu_tree (gnat_desig_equiv)
3716 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
3718 && defer_incomplete_level != 0
3719 && !present_gnu_tree (gnat_desig_equiv))
3721 && is_from_limited_with
3722 && Present (Freeze_Node (gnat_desig_equiv)))))
3724 if (present_gnu_tree (gnat_desig_rep))
3725 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3728 gnu_desig_type = make_dummy_type (gnat_desig_rep);
3732 /* If the call above got something that has a pointer, the pointer
3733 is our type. This could have happened either because the type
3734 was elaborated or because somebody else executed the code. */
3735 if (!TYPE_POINTER_TO (gnu_desig_type))
3736 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3737 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3740 /* If we already know what the full type is, use it. */
3741 else if (Present (gnat_desig_full)
3742 && present_gnu_tree (gnat_desig_full))
3743 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3745 /* Get the type of the thing we are to point to and build a pointer to
3746 it. If it is a reference to an incomplete or private type with a
3747 full view that is a record, make a dummy type node and get the
3748 actual type later when we have verified it is safe. */
3749 else if ((!in_main_unit
3750 && !present_gnu_tree (gnat_desig_equiv)
3751 && Present (gnat_desig_full)
3752 && !present_gnu_tree (gnat_desig_full)
3753 && Is_Record_Type (gnat_desig_full))
3754 /* Likewise if we are pointing to a record or array and we are
3755 to defer elaborating incomplete types. We do this as this
3756 access type may be the full view of a private type. Note
3757 that the unconstrained array case is handled above. */
3758 || ((!in_main_unit || imported_p)
3759 && defer_incomplete_level != 0
3760 && !present_gnu_tree (gnat_desig_equiv)
3761 && (Is_Record_Type (gnat_desig_rep)
3762 || Is_Array_Type (gnat_desig_rep)))
3763 /* If this is a reference from a limited_with type back to our
3764 main unit and there's a freeze node for it, either we have
3765 already processed the declaration and made the dummy type,
3766 in which case we just reuse the latter, or we have not yet,
3767 in which case we make the dummy type and it will be reused
3768 when the declaration is finally processed. In both cases,
3769 the pointer eventually created below will be automatically
3770 adjusted when the freeze node is processed. Note that the
3771 unconstrained array case is handled above. */
3773 && is_from_limited_with
3774 && Present (Freeze_Node (gnat_desig_rep))))
3776 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3780 /* Otherwise handle the case of a pointer to itself. */
3781 else if (gnat_desig_equiv == gnat_entity)
3784 = build_pointer_type_for_mode (void_type_node, p_mode,
3785 No_Strict_Aliasing (gnat_entity));
3786 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3789 /* If expansion is disabled, the equivalent type of a concurrent type
3790 is absent, so build a dummy pointer type. */
3791 else if (type_annotate_only && No (gnat_desig_equiv))
3792 gnu_type = ptr_void_type_node;
3794 /* Finally, handle the default case where we can just elaborate our
3797 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3799 /* It is possible that a call to gnat_to_gnu_type above resolved our
3800 type. If so, just return it. */
3801 if (present_gnu_tree (gnat_entity))
3803 maybe_present = true;
3807 /* If we haven't done it yet, build the pointer type the usual way. */
3810 /* Modify the designated type if we are pointing only to constant
3811 objects, but don't do it for unconstrained arrays. */
3812 if (Is_Access_Constant (gnat_entity)
3813 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3816 = build_qualified_type
3818 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3820 /* Some extra processing is required if we are building a
3821 pointer to an incomplete type (in the GCC sense). We might
3822 have such a type if we just made a dummy, or directly out
3823 of the call to gnat_to_gnu_type above if we are processing
3824 an access type for a record component designating the
3825 record type itself. */
3826 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3828 /* We must ensure that the pointer to variant we make will
3829 be processed by update_pointer_to when the initial type
3830 is completed. Pretend we made a dummy and let further
3831 processing act as usual. */
3834 /* We must ensure that update_pointer_to will not retrieve
3835 the dummy variant when building a properly qualified
3836 version of the complete type. We take advantage of the
3837 fact that get_qualified_type is requiring TYPE_NAMEs to
3838 match to influence build_qualified_type and then also
3839 update_pointer_to here. */
3840 TYPE_NAME (gnu_desig_type)
3841 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3846 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3847 No_Strict_Aliasing (gnat_entity));
3850 /* If we are not defining this object and we have made a dummy pointer,
3851 save our current definition, evaluate the actual type, and replace
3852 the tentative type we made with the actual one. If we are to defer
3853 actually looking up the actual type, make an entry in the deferred
3854 list. If this is from a limited with, we may have to defer to the
3855 end of the current unit. */
3856 if ((!in_main_unit || is_from_limited_with) && made_dummy)
3858 tree gnu_old_desig_type;
3860 if (TYPE_IS_FAT_POINTER_P (gnu_type))
3862 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
3863 if (esize == POINTER_SIZE)
3864 gnu_type = build_pointer_type
3865 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
3868 gnu_old_desig_type = TREE_TYPE (gnu_type);
3870 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3871 !Comes_From_Source (gnat_entity),
3872 debug_info_p, gnat_entity);
3873 this_made_decl = true;
3874 gnu_type = TREE_TYPE (gnu_decl);
3875 save_gnu_tree (gnat_entity, gnu_decl, false);
3878 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3879 update gnu_old_desig_type directly, in which case it will not be
3880 a dummy type any more when we get into update_pointer_to.
3882 This can happen e.g. when the designated type is a record type,
3883 because their elaboration starts with an initial node from
3884 make_dummy_type, which may be the same node as the one we got.
3886 Besides, variants of this non-dummy type might have been created
3887 along the way. update_pointer_to is expected to properly take
3888 care of those situations. */
3889 if (defer_incomplete_level == 0 && !is_from_limited_with)
3891 defer_finalize_level++;
3892 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
3893 gnat_to_gnu_type (gnat_desig_equiv));
3894 defer_finalize_level--;
3898 struct incomplete *p = XNEW (struct incomplete);
3899 struct incomplete **head
3900 = (is_from_limited_with
3901 ? &defer_limited_with : &defer_incomplete_list);
3902 p->old_type = gnu_old_desig_type;
3903 p->full_type = gnat_desig_equiv;
3911 case E_Access_Protected_Subprogram_Type:
3912 case E_Anonymous_Access_Protected_Subprogram_Type:
3913 if (type_annotate_only && No (gnat_equiv_type))
3914 gnu_type = ptr_void_type_node;
3917 /* The run-time representation is the equivalent type. */
3918 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3919 maybe_present = true;
3922 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3923 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3924 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3925 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3926 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3931 case E_Access_Subtype:
3933 /* We treat this as identical to its base type; any constraint is
3934 meaningful only to the front-end.
3936 The designated type must be elaborated as well, if it does
3937 not have its own freeze node. Designated (sub)types created
3938 for constrained components of records with discriminants are
3939 not frozen by the front-end and thus not elaborated by gigi,
3940 because their use may appear before the base type is frozen,
3941 and because it is not clear that they are needed anywhere in
3942 gigi. With the current model, there is no correct place where
3943 they could be elaborated. */
3945 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3946 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3947 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3948 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3949 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3951 /* If we are not defining this entity, and we have incomplete
3952 entities being processed above us, make a dummy type and
3953 elaborate it later. */
3954 if (!definition && defer_incomplete_level != 0)
3956 struct incomplete *p = XNEW (struct incomplete);
3959 = make_dummy_type (Directly_Designated_Type (gnat_entity));
3960 p->full_type = Directly_Designated_Type (gnat_entity);
3961 p->next = defer_incomplete_list;
3962 defer_incomplete_list = p;
3964 else if (!IN (Ekind (Base_Type
3965 (Directly_Designated_Type (gnat_entity))),
3966 Incomplete_Or_Private_Kind))
3967 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3971 maybe_present = true;
3974 /* Subprogram Entities
3976 The following access functions are defined for subprograms:
3978 Etype Return type or Standard_Void_Type.
3979 First_Formal The first formal parameter.
3980 Is_Imported Indicates that the subprogram has appeared in
3981 an INTERFACE or IMPORT pragma. For now we
3982 assume that the external language is C.
3983 Is_Exported Likewise but for an EXPORT pragma.
3984 Is_Inlined True if the subprogram is to be inlined.
3986 Each parameter is first checked by calling must_pass_by_ref on its
3987 type to determine if it is passed by reference. For parameters which
3988 are copied in, if they are Ada In Out or Out parameters, their return
3989 value becomes part of a record which becomes the return type of the
3990 function (C function - note that this applies only to Ada procedures
3991 so there is no Ada return type). Additional code to store back the
3992 parameters will be generated on the caller side. This transformation
3993 is done here, not in the front-end.
3995 The intended result of the transformation can be seen from the
3996 equivalent source rewritings that follow:
3998 struct temp {int a,b};
3999 procedure P (A,B: In Out ...) is temp P (int A,B)
4002 end P; return {A,B};
4009 For subprogram types we need to perform mainly the same conversions to
4010 GCC form that are needed for procedures and function declarations. The
4011 only difference is that at the end, we make a type declaration instead
4012 of a function declaration. */
4014 case E_Subprogram_Type:
4018 /* The type returned by a function or else Standard_Void_Type for a
4020 Entity_Id gnat_return_type = Etype (gnat_entity);
4021 tree gnu_return_type;
4022 /* The first GCC parameter declaration (a PARM_DECL node). The
4023 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
4024 actually is the head of this parameter list. */
4025 tree gnu_param_list = NULL_TREE;
4026 /* Likewise for the stub associated with an exported procedure. */
4027 tree gnu_stub_param_list = NULL_TREE;
4028 /* Non-null for subprograms containing parameters passed by copy-in
4029 copy-out (Ada In Out or Out parameters not passed by reference),
4030 in which case it is the list of nodes used to specify the values
4031 of the In Out/Out parameters that are returned as a record upon
4032 procedure return. The TREE_PURPOSE of an element of this list is
4033 a field of the record and the TREE_VALUE is the PARM_DECL
4034 corresponding to that field. This list will be saved in the
4035 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
4036 tree gnu_cico_list = NULL_TREE;
4037 /* List of fields in return type of procedure with copy-in copy-out
4039 tree gnu_field_list = NULL_TREE;
4040 /* If an import pragma asks to map this subprogram to a GCC builtin,
4041 this is the builtin DECL node. */
4042 tree gnu_builtin_decl = NULL_TREE;
4043 /* For the stub associated with an exported procedure. */
4044 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
4045 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
4046 Entity_Id gnat_param;
4047 bool inline_flag = Is_Inlined (gnat_entity);
4048 bool public_flag = Is_Public (gnat_entity) || imported_p;
4050 = (Is_Public (gnat_entity) && !definition) || imported_p;
4051 bool artificial_flag = !Comes_From_Source (gnat_entity);
4052 /* The semantics of "pure" in Ada essentially matches that of "const"
4053 in the back-end. In particular, both properties are orthogonal to
4054 the "nothrow" property if the EH circuitry is explicit in the
4055 internal representation of the back-end. If we are to completely
4056 hide the EH circuitry from it, we need to declare that calls to pure
4057 Ada subprograms that can throw have side effects since they can
4058 trigger an "abnormal" transfer of control flow; thus they can be
4059 neither "const" nor "pure" in the back-end sense. */
4061 = (Exception_Mechanism == Back_End_Exceptions
4062 && Is_Pure (gnat_entity));
4063 bool volatile_flag = No_Return (gnat_entity);
4064 bool return_by_direct_ref_p = false;
4065 bool return_by_invisi_ref_p = false;
4066 bool return_unconstrained_p = false;
4067 bool has_stub = false;
4070 /* A parameter may refer to this type, so defer completion of any
4071 incomplete types. */
4072 if (kind == E_Subprogram_Type && !definition)
4074 defer_incomplete_level++;
4075 this_deferred = true;
4078 /* If the subprogram has an alias, it is probably inherited, so
4079 we can use the original one. If the original "subprogram"
4080 is actually an enumeration literal, it may be the first use
4081 of its type, so we must elaborate that type now. */
4082 if (Present (Alias (gnat_entity)))
4084 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
4085 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
4087 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
4089 /* Elaborate any Itypes in the parameters of this entity. */
4090 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
4091 Present (gnat_temp);
4092 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4093 if (Is_Itype (Etype (gnat_temp)))
4094 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
4099 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4100 corresponding DECL node. Proper generation of calls later on need
4101 proper parameter associations so we don't "break;" here. */
4102 if (Convention (gnat_entity) == Convention_Intrinsic
4103 && Present (Interface_Name (gnat_entity)))
4105 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
4107 /* Inability to find the builtin decl most often indicates a
4108 genuine mistake, but imports of unregistered intrinsics are
4109 sometimes issued on purpose to allow hooking in alternate
4110 bodies. We post a warning conditioned on Wshadow in this case,
4111 to let developers be notified on demand without risking false
4112 positives with common default sets of options. */
4114 if (gnu_builtin_decl == NULL_TREE && warn_shadow)
4115 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4118 /* ??? What if we don't find the builtin node above ? warn ? err ?
4119 In the current state we neither warn nor err, and calls will just
4120 be handled as for regular subprograms. */
4122 /* Look into the return type and get its associated GCC tree. If it
4123 is not void, compute various flags for the subprogram type. */
4124 if (Ekind (gnat_return_type) == E_Void)
4125 gnu_return_type = void_type_node;
4128 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4130 /* If this function returns by reference, make the actual return
4131 type the pointer type and make a note of that. */
4132 if (Returns_By_Ref (gnat_entity))
4134 gnu_return_type = build_pointer_type (gnu_return_type);
4135 return_by_direct_ref_p = true;
4138 /* If we are supposed to return an unconstrained array type, make
4139 the actual return type the fat pointer type. */
4140 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4142 gnu_return_type = TREE_TYPE (gnu_return_type);
4143 return_unconstrained_p = true;
4146 /* Likewise, if the return type requires a transient scope, the
4147 return value will be allocated on the secondary stack so the
4148 actual return type is the pointer type. */
4149 else if (Requires_Transient_Scope (gnat_return_type))
4151 gnu_return_type = build_pointer_type (gnu_return_type);
4152 return_unconstrained_p = true;
4155 /* If the Mechanism is By_Reference, ensure this function uses the
4156 target's by-invisible-reference mechanism, which may not be the
4157 same as above (e.g. it might be passing an extra parameter). */
4158 else if (kind == E_Function
4159 && Mechanism (gnat_entity) == By_Reference)
4160 return_by_invisi_ref_p = true;
4162 /* Likewise, if the return type is itself By_Reference. */
4163 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
4164 return_by_invisi_ref_p = true;
4166 /* If the type is a padded type and the underlying type would not
4167 be passed by reference or the function has a foreign convention,
4168 return the underlying type. */
4169 else if (TYPE_IS_PADDING_P (gnu_return_type)
4170 && (!default_pass_by_ref
4171 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4172 || Has_Foreign_Convention (gnat_entity)))
4173 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4175 /* If the return type is unconstrained, that means it must have a
4176 maximum size. Use the padded type as the effective return type.
4177 And ensure the function uses the target's by-invisible-reference
4178 mechanism to avoid copying too much data when it returns. */
4179 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4182 = maybe_pad_type (gnu_return_type,
4183 max_size (TYPE_SIZE (gnu_return_type),
4185 0, gnat_entity, false, false, false, true);
4187 /* Declare it now since it will never be declared otherwise.
4188 This is necessary to ensure that its subtrees are properly
4190 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
4191 NULL, true, debug_info_p, gnat_entity);
4193 return_by_invisi_ref_p = true;
4196 /* If the return type has a size that overflows, we cannot have
4197 a function that returns that type. This usage doesn't make
4198 sense anyway, so give an error here. */
4199 if (TYPE_SIZE_UNIT (gnu_return_type)
4200 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
4201 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
4203 post_error ("cannot return type whose size overflows",
4205 gnu_return_type = copy_node (gnu_return_type);
4206 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4207 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4208 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4209 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4213 /* Loop over the parameters and get their associated GCC tree. While
4214 doing this, build a copy-in copy-out structure if we need one. */
4215 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4216 Present (gnat_param);
4217 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4219 tree gnu_param_name = get_entity_name (gnat_param);
4220 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4221 tree gnu_param, gnu_field;
4222 bool copy_in_copy_out = false;
4223 Mechanism_Type mech = Mechanism (gnat_param);
4225 /* Builtins are expanded inline and there is no real call sequence
4226 involved. So the type expected by the underlying expander is
4227 always the type of each argument "as is". */
4228 if (gnu_builtin_decl)
4230 /* Handle the first parameter of a valued procedure specially. */
4231 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4232 mech = By_Copy_Return;
4233 /* Otherwise, see if a Mechanism was supplied that forced this
4234 parameter to be passed one way or another. */
4235 else if (mech == Default
4236 || mech == By_Copy || mech == By_Reference)
4238 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4239 mech = By_Descriptor;
4241 else if (By_Short_Descriptor_Last <= mech &&
4242 mech <= By_Short_Descriptor)
4243 mech = By_Short_Descriptor;
4247 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4248 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4249 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4251 mech = By_Reference;
4257 post_error ("unsupported mechanism for&", gnat_param);
4262 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4263 Has_Foreign_Convention (gnat_entity),
4266 /* We are returned either a PARM_DECL or a type if no parameter
4267 needs to be passed; in either case, adjust the type. */
4268 if (DECL_P (gnu_param))
4269 gnu_param_type = TREE_TYPE (gnu_param);
4272 gnu_param_type = gnu_param;
4273 gnu_param = NULL_TREE;
4276 /* The failure of this assertion will very likely come from an
4277 order of elaboration issue for the type of the parameter. */
4278 gcc_assert (kind == E_Subprogram_Type
4279 || !TYPE_IS_DUMMY_P (gnu_param_type)
4280 || type_annotate_only);
4284 /* If it's an exported subprogram, we build a parameter list
4285 in parallel, in case we need to emit a stub for it. */
4286 if (Is_Exported (gnat_entity))
4289 = chainon (gnu_param, gnu_stub_param_list);
4290 /* Change By_Descriptor parameter to By_Reference for
4291 the internal version of an exported subprogram. */
4292 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4295 = gnat_to_gnu_param (gnat_param, By_Reference,
4301 gnu_param = copy_node (gnu_param);
4304 gnu_param_list = chainon (gnu_param, gnu_param_list);
4305 Sloc_to_locus (Sloc (gnat_param),
4306 &DECL_SOURCE_LOCATION (gnu_param));
4307 save_gnu_tree (gnat_param, gnu_param, false);
4309 /* If a parameter is a pointer, this function may modify
4310 memory through it and thus shouldn't be considered
4311 a const function. Also, the memory may be modified
4312 between two calls, so they can't be CSE'ed. The latter
4313 case also handles by-ref parameters. */
4314 if (POINTER_TYPE_P (gnu_param_type)
4315 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4319 if (copy_in_copy_out)
4323 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4325 /* If this is a function, we also need a field for the
4326 return value to be placed. */
4327 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4330 = create_field_decl (get_identifier ("RETVAL"),
4332 gnu_new_ret_type, NULL_TREE,
4334 Sloc_to_locus (Sloc (gnat_entity),
4335 &DECL_SOURCE_LOCATION (gnu_field));
4336 gnu_field_list = gnu_field;
4338 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4341 gnu_return_type = gnu_new_ret_type;
4342 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4343 /* Set a default alignment to speed up accesses. But we
4344 shouldn't increase the size of the structure too much,
4345 lest it doesn't fit in return registers anymore. */
4346 TYPE_ALIGN (gnu_return_type)
4347 = get_mode_alignment (ptr_mode);
4351 = create_field_decl (gnu_param_name, gnu_param_type,
4352 gnu_return_type, NULL_TREE, NULL_TREE,
4354 Sloc_to_locus (Sloc (gnat_param),
4355 &DECL_SOURCE_LOCATION (gnu_field));
4356 DECL_CHAIN (gnu_field) = gnu_field_list;
4357 gnu_field_list = gnu_field;
4359 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4365 /* If we have a CICO list but it has only one entry, we convert
4366 this function into a function that returns this object. */
4367 if (list_length (gnu_cico_list) == 1)
4368 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4370 /* Do not finalize the return type if the subprogram is stubbed
4371 since structures are incomplete for the back-end. */
4372 else if (Convention (gnat_entity) != Convention_Stubbed)
4374 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4377 /* Try to promote the mode of the return type if it is passed
4378 in registers, again to speed up accesses. */
4379 if (TYPE_MODE (gnu_return_type) == BLKmode
4380 && !targetm.calls.return_in_memory (gnu_return_type,
4384 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4385 unsigned int i = BITS_PER_UNIT;
4386 enum machine_mode mode;
4390 mode = mode_for_size (i, MODE_INT, 0);
4391 if (mode != BLKmode)
4393 SET_TYPE_MODE (gnu_return_type, mode);
4394 TYPE_ALIGN (gnu_return_type)
4395 = GET_MODE_ALIGNMENT (mode);
4396 TYPE_SIZE (gnu_return_type)
4397 = bitsize_int (GET_MODE_BITSIZE (mode));
4398 TYPE_SIZE_UNIT (gnu_return_type)
4399 = size_int (GET_MODE_SIZE (mode));
4404 rest_of_record_type_compilation (gnu_return_type);
4408 if (Has_Stdcall_Convention (gnat_entity))
4409 prepend_one_attribute_to
4410 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4411 get_identifier ("stdcall"), NULL_TREE,
4414 /* If we should request stack realignment for a foreign convention
4415 subprogram, do so. Note that this applies to task entry points in
4417 if (FOREIGN_FORCE_REALIGN_STACK
4418 && Has_Foreign_Convention (gnat_entity))
4419 prepend_one_attribute_to
4420 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4421 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4424 /* The lists have been built in reverse. */
4425 gnu_param_list = nreverse (gnu_param_list);
4427 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4428 gnu_cico_list = nreverse (gnu_cico_list);
4430 if (kind == E_Function)
4431 Set_Mechanism (gnat_entity, return_unconstrained_p
4432 || return_by_direct_ref_p
4433 || return_by_invisi_ref_p
4434 ? By_Reference : By_Copy);
4436 = create_subprog_type (gnu_return_type, gnu_param_list,
4437 gnu_cico_list, return_unconstrained_p,
4438 return_by_direct_ref_p,
4439 return_by_invisi_ref_p);
4443 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4444 gnu_cico_list, return_unconstrained_p,
4445 return_by_direct_ref_p,
4446 return_by_invisi_ref_p);
4448 /* A subprogram (something that doesn't return anything) shouldn't
4449 be considered const since there would be no reason for such a
4450 subprogram. Note that procedures with Out (or In Out) parameters
4451 have already been converted into a function with a return type. */
4452 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4456 = build_qualified_type (gnu_type,
4457 TYPE_QUALS (gnu_type)
4458 | (TYPE_QUAL_CONST * const_flag)
4459 | (TYPE_QUAL_VOLATILE * volatile_flag));
4463 = build_qualified_type (gnu_stub_type,
4464 TYPE_QUALS (gnu_stub_type)
4465 | (TYPE_QUAL_CONST * const_flag)
4466 | (TYPE_QUAL_VOLATILE * volatile_flag));
4468 /* If we have a builtin decl for that function, use it. Check if the
4469 profiles are compatible and warn if they are not. The checker is
4470 expected to post extra diagnostics in this case. */
4471 if (gnu_builtin_decl)
4473 intrin_binding_t inb;
4475 inb.gnat_entity = gnat_entity;
4476 inb.ada_fntype = gnu_type;
4477 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4479 if (!intrin_profiles_compatible_p (&inb))
4481 ("?profile of& doesn''t match the builtin it binds!",
4484 gnu_decl = gnu_builtin_decl;
4485 gnu_type = TREE_TYPE (gnu_builtin_decl);
4489 /* If there was no specified Interface_Name and the external and
4490 internal names of the subprogram are the same, only use the
4491 internal name to allow disambiguation of nested subprograms. */
4492 if (No (Interface_Name (gnat_entity))
4493 && gnu_ext_name == gnu_entity_name)
4494 gnu_ext_name = NULL_TREE;
4496 /* If we are defining the subprogram and it has an Address clause
4497 we must get the address expression from the saved GCC tree for the
4498 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4499 the address expression here since the front-end has guaranteed
4500 in that case that the elaboration has no effects. If there is
4501 an Address clause and we are not defining the object, just
4502 make it a constant. */
4503 if (Present (Address_Clause (gnat_entity)))
4505 tree gnu_address = NULL_TREE;
4509 = (present_gnu_tree (gnat_entity)
4510 ? get_gnu_tree (gnat_entity)
4511 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4513 save_gnu_tree (gnat_entity, NULL_TREE, false);
4515 /* Convert the type of the object to a reference type that can
4516 alias everything as per 13.3(19). */
4518 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4520 gnu_address = convert (gnu_type, gnu_address);
4523 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4524 gnu_address, false, Is_Public (gnat_entity),
4525 extern_flag, false, NULL, gnat_entity);
4526 DECL_BY_REF_P (gnu_decl) = 1;
4529 else if (kind == E_Subprogram_Type)
4531 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4532 artificial_flag, debug_info_p, gnat_entity);
4537 gnu_stub_name = gnu_ext_name;
4538 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4539 public_flag = false;
4540 artificial_flag = true;
4544 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4545 gnu_param_list, inline_flag, public_flag,
4546 extern_flag, artificial_flag, attr_list,
4551 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4552 gnu_stub_type, gnu_stub_param_list,
4553 inline_flag, true, extern_flag,
4554 false, attr_list, gnat_entity);
4555 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4558 /* This is unrelated to the stub built right above. */
4559 DECL_STUBBED_P (gnu_decl)
4560 = Convention (gnat_entity) == Convention_Stubbed;
4565 case E_Incomplete_Type:
4566 case E_Incomplete_Subtype:
4567 case E_Private_Type:
4568 case E_Private_Subtype:
4569 case E_Limited_Private_Type:
4570 case E_Limited_Private_Subtype:
4571 case E_Record_Type_With_Private:
4572 case E_Record_Subtype_With_Private:
4574 /* Get the "full view" of this entity. If this is an incomplete
4575 entity from a limited with, treat its non-limited view as the
4576 full view. Otherwise, use either the full view or the underlying
4577 full view, whichever is present. This is used in all the tests
4580 = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity))
4581 ? Non_Limited_View (gnat_entity)
4582 : Present (Full_View (gnat_entity))
4583 ? Full_View (gnat_entity)
4584 : Underlying_Full_View (gnat_entity);
4586 /* If this is an incomplete type with no full view, it must be a Taft
4587 Amendment type, in which case we return a dummy type. Otherwise,
4588 just get the type from its Etype. */
4591 if (kind == E_Incomplete_Type)
4593 gnu_type = make_dummy_type (gnat_entity);
4594 gnu_decl = TYPE_STUB_DECL (gnu_type);
4598 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4600 maybe_present = true;
4605 /* If we already made a type for the full view, reuse it. */
4606 else if (present_gnu_tree (full_view))
4608 gnu_decl = get_gnu_tree (full_view);
4612 /* Otherwise, if we are not defining the type now, get the type
4613 from the full view. But always get the type from the full view
4614 for define on use types, since otherwise we won't see them! */
4615 else if (!definition
4616 || (Is_Itype (full_view)
4617 && No (Freeze_Node (gnat_entity)))
4618 || (Is_Itype (gnat_entity)
4619 && No (Freeze_Node (full_view))))
4621 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4622 maybe_present = true;
4626 /* For incomplete types, make a dummy type entry which will be
4627 replaced later. Save it as the full declaration's type so
4628 we can do any needed updates when we see it. */
4629 gnu_type = make_dummy_type (gnat_entity);
4630 gnu_decl = TYPE_STUB_DECL (gnu_type);
4631 if (Has_Completion_In_Body (gnat_entity))
4632 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4633 save_gnu_tree (full_view, gnu_decl, 0);
4637 case E_Class_Wide_Type:
4638 /* Class-wide types are always transformed into their root type. */
4639 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4640 maybe_present = true;
4644 case E_Task_Subtype:
4645 case E_Protected_Type:
4646 case E_Protected_Subtype:
4647 /* Concurrent types are always transformed into their record type. */
4648 if (type_annotate_only && No (gnat_equiv_type))
4649 gnu_type = void_type_node;
4651 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4652 maybe_present = true;
4656 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4661 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4662 we've already saved it, so we don't try to. */
4663 gnu_decl = error_mark_node;
4671 /* If we had a case where we evaluated another type and it might have
4672 defined this one, handle it here. */
4673 if (maybe_present && present_gnu_tree (gnat_entity))
4675 gnu_decl = get_gnu_tree (gnat_entity);
4679 /* If we are processing a type and there is either no decl for it or
4680 we just made one, do some common processing for the type, such as
4681 handling alignment and possible padding. */
4682 if (is_type && (!gnu_decl || this_made_decl))
4684 /* Tell the middle-end that objects of tagged types are guaranteed to
4685 be properly aligned. This is necessary because conversions to the
4686 class-wide type are translated into conversions to the root type,
4687 which can be less aligned than some of its derived types. */
4688 if (Is_Tagged_Type (gnat_entity)
4689 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4690 TYPE_ALIGN_OK (gnu_type) = 1;
4692 /* Record whether the type is passed by reference. */
4693 if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4694 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4696 /* ??? Don't set the size for a String_Literal since it is either
4697 confirming or we don't handle it properly (if the low bound is
4699 if (!gnu_size && kind != E_String_Literal_Subtype)
4701 Uint gnat_size = Known_Esize (gnat_entity)
4702 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4704 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4705 false, Has_Size_Clause (gnat_entity));
4708 /* If a size was specified, see if we can make a new type of that size
4709 by rearranging the type, for example from a fat to a thin pointer. */
4713 = make_type_from_size (gnu_type, gnu_size,
4714 Has_Biased_Representation (gnat_entity));
4716 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4717 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4721 /* If the alignment hasn't already been processed and this is
4722 not an unconstrained array, see if an alignment is specified.
4723 If not, we pick a default alignment for atomic objects. */
4724 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4726 else if (Known_Alignment (gnat_entity))
4728 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4729 TYPE_ALIGN (gnu_type));
4731 /* Warn on suspiciously large alignments. This should catch
4732 errors about the (alignment,byte)/(size,bit) discrepancy. */
4733 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4737 /* If a size was specified, take it into account. Otherwise
4738 use the RM size for records or unions as the type size has
4739 already been adjusted to the alignment. */
4742 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
4743 && !TYPE_FAT_POINTER_P (gnu_type))
4744 size = rm_size (gnu_type);
4746 size = TYPE_SIZE (gnu_type);
4748 /* Consider an alignment as suspicious if the alignment/size
4749 ratio is greater or equal to the byte/bit ratio. */
4750 if (host_integerp (size, 1)
4751 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4752 post_error_ne ("?suspiciously large alignment specified for&",
4753 Expression (Alignment_Clause (gnat_entity)),
4757 else if (Is_Atomic (gnat_entity) && !gnu_size
4758 && host_integerp (TYPE_SIZE (gnu_type), 1)
4759 && integer_pow2p (TYPE_SIZE (gnu_type)))
4760 align = MIN (BIGGEST_ALIGNMENT,
4761 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4762 else if (Is_Atomic (gnat_entity) && gnu_size
4763 && host_integerp (gnu_size, 1)
4764 && integer_pow2p (gnu_size))
4765 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4767 /* See if we need to pad the type. If we did, and made a record,
4768 the name of the new type may be changed. So get it back for
4769 us when we make the new TYPE_DECL below. */
4770 if (gnu_size || align > 0)
4771 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4772 false, !gnu_decl, definition, false);
4774 if (TYPE_IS_PADDING_P (gnu_type))
4776 gnu_entity_name = TYPE_NAME (gnu_type);
4777 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4778 gnu_entity_name = DECL_NAME (gnu_entity_name);
4781 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4783 /* If we are at global level, GCC will have applied variable_size to
4784 the type, but that won't have done anything. So, if it's not
4785 a constant or self-referential, call elaborate_expression_1 to
4786 make a variable for the size rather than calculating it each time.
4787 Handle both the RM size and the actual size. */
4788 if (global_bindings_p ()
4789 && TYPE_SIZE (gnu_type)
4790 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4791 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4793 tree size = TYPE_SIZE (gnu_type);
4795 TYPE_SIZE (gnu_type)
4796 = elaborate_expression_1 (size, gnat_entity,
4797 get_identifier ("SIZE"),
4800 /* ??? For now, store the size as a multiple of the alignment in
4801 bytes so that we can see the alignment from the tree. */
4802 TYPE_SIZE_UNIT (gnu_type)
4803 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4804 get_identifier ("SIZE_A_UNIT"),
4806 TYPE_ALIGN (gnu_type));
4808 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4809 may not be marked by the call to create_type_decl below. */
4810 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4812 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4814 tree variant_part = get_variant_part (gnu_type);
4815 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4819 tree union_type = TREE_TYPE (variant_part);
4820 tree offset = DECL_FIELD_OFFSET (variant_part);
4822 /* If the position of the variant part is constant, subtract
4823 it from the size of the type of the parent to get the new
4824 size. This manual CSE reduces the data size. */
4825 if (TREE_CODE (offset) == INTEGER_CST)
4827 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4828 TYPE_SIZE (union_type)
4829 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4830 bit_from_pos (offset, bitpos));
4831 TYPE_SIZE_UNIT (union_type)
4832 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4833 byte_from_pos (offset, bitpos));
4837 TYPE_SIZE (union_type)
4838 = elaborate_expression_1 (TYPE_SIZE (union_type),
4840 get_identifier ("VSIZE"),
4843 /* ??? For now, store the size as a multiple of the
4844 alignment in bytes so that we can see the alignment
4846 TYPE_SIZE_UNIT (union_type)
4847 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4852 TYPE_ALIGN (union_type));
4854 /* ??? For now, store the offset as a multiple of the
4855 alignment in bytes so that we can see the alignment
4857 DECL_FIELD_OFFSET (variant_part)
4858 = elaborate_expression_2 (offset,
4860 get_identifier ("VOFFSET"),
4866 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4867 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4870 if (operand_equal_p (ada_size, size, 0))
4871 ada_size = TYPE_SIZE (gnu_type);
4874 = elaborate_expression_1 (ada_size, gnat_entity,
4875 get_identifier ("RM_SIZE"),
4877 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4881 /* If this is a record type or subtype, call elaborate_expression_1 on
4882 any field position. Do this for both global and local types.
4883 Skip any fields that we haven't made trees for to avoid problems with
4884 class wide types. */
4885 if (IN (kind, Record_Kind))
4886 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4887 gnat_temp = Next_Entity (gnat_temp))
4888 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4890 tree gnu_field = get_gnu_tree (gnat_temp);
4892 /* ??? For now, store the offset as a multiple of the alignment
4893 in bytes so that we can see the alignment from the tree. */
4894 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4896 DECL_FIELD_OFFSET (gnu_field)
4897 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4899 get_identifier ("OFFSET"),
4901 DECL_OFFSET_ALIGN (gnu_field));
4903 /* ??? The context of gnu_field is not necessarily gnu_type
4904 so the MULT_EXPR node built above may not be marked by
4905 the call to create_type_decl below. */
4906 if (global_bindings_p ())
4907 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4911 if (Treat_As_Volatile (gnat_entity))
4913 = build_qualified_type (gnu_type,
4914 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4916 if (Is_Atomic (gnat_entity))
4917 check_ok_for_atomic (gnu_type, gnat_entity, false);
4919 if (Present (Alignment_Clause (gnat_entity)))
4920 TYPE_USER_ALIGN (gnu_type) = 1;
4922 if (Universal_Aliasing (gnat_entity))
4923 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4926 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4927 !Comes_From_Source (gnat_entity),
4928 debug_info_p, gnat_entity);
4931 TREE_TYPE (gnu_decl) = gnu_type;
4932 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4936 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4938 gnu_type = TREE_TYPE (gnu_decl);
4940 /* If this is a derived type, relate its alias set to that of its parent
4941 to avoid troubles when a call to an inherited primitive is inlined in
4942 a context where a derived object is accessed. The inlined code works
4943 on the parent view so the resulting code may access the same object
4944 using both the parent and the derived alias sets, which thus have to
4945 conflict. As the same issue arises with component references, the
4946 parent alias set also has to conflict with composite types enclosing
4947 derived components. For instance, if we have:
4954 we want T to conflict with both D and R, in addition to R being a
4955 superset of D by record/component construction.
4957 One way to achieve this is to perform an alias set copy from the
4958 parent to the derived type. This is not quite appropriate, though,
4959 as we don't want separate derived types to conflict with each other:
4961 type I1 is new Integer;
4962 type I2 is new Integer;
4964 We want I1 and I2 to both conflict with Integer but we do not want
4965 I1 to conflict with I2, and an alias set copy on derivation would
4968 The option chosen is to make the alias set of the derived type a
4969 superset of that of its parent type. It trivially fulfills the
4970 simple requirement for the Integer derivation example above, and
4971 the component case as well by superset transitivity:
4974 R ----------> D ----------> T
4976 However, for composite types, conversions between derived types are
4977 translated into VIEW_CONVERT_EXPRs so a sequence like:
4979 type Comp1 is new Comp;
4980 type Comp2 is new Comp;
4981 procedure Proc (C : Comp1);
4989 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4991 and gimplified into:
4998 i.e. generates code involving type punning. Therefore, Comp1 needs
4999 to conflict with Comp2 and an alias set copy is required.
5001 The language rules ensure the parent type is already frozen here. */
5002 if (Is_Derived_Type (gnat_entity))
5004 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
5005 relate_alias_sets (gnu_type, gnu_parent_type,
5006 Is_Composite_Type (gnat_entity)
5007 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
5010 /* Back-annotate the Alignment of the type if not already in the
5011 tree. Likewise for sizes. */
5012 if (Unknown_Alignment (gnat_entity))
5014 unsigned int double_align, align;
5015 bool is_capped_double, align_clause;
5017 /* If the default alignment of "double" or larger scalar types is
5018 specifically capped and this is not an array with an alignment
5019 clause on the component type, return the cap. */
5020 if ((double_align = double_float_alignment) > 0)
5022 = is_double_float_or_array (gnat_entity, &align_clause);
5023 else if ((double_align = double_scalar_alignment) > 0)
5025 = is_double_scalar_or_array (gnat_entity, &align_clause);
5027 is_capped_double = align_clause = false;
5029 if (is_capped_double && !align_clause)
5030 align = double_align;
5032 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
5034 Set_Alignment (gnat_entity, UI_From_Int (align));
5037 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
5039 tree gnu_size = TYPE_SIZE (gnu_type);
5041 /* If the size is self-referential, annotate the maximum value. */
5042 if (CONTAINS_PLACEHOLDER_P (gnu_size))
5043 gnu_size = max_size (gnu_size, true);
5045 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
5047 /* In this mode, the tag and the parent components are not
5048 generated by the front-end so the sizes must be adjusted. */
5049 tree pointer_size = bitsize_int (POINTER_SIZE), offset;
5052 if (Is_Derived_Type (gnat_entity))
5054 offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
5056 Set_Alignment (gnat_entity,
5057 Alignment (Etype (Base_Type (gnat_entity))));
5060 offset = pointer_size;
5062 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
5063 gnu_size = size_binop (MULT_EXPR, pointer_size,
5064 size_binop (CEIL_DIV_EXPR,
5067 uint_size = annotate_value (gnu_size);
5068 Set_Esize (gnat_entity, uint_size);
5069 Set_RM_Size (gnat_entity, uint_size);
5072 Set_Esize (gnat_entity, annotate_value (gnu_size));
5075 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
5076 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
5079 /* If we really have a ..._DECL node, set a couple of flags on it. But we
5080 cannot do so if we are reusing the ..._DECL node made for an alias or a
5081 renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
5082 if (DECL_P (gnu_decl)
5083 && !Present (Alias (gnat_entity))
5084 && !(Present (Renamed_Object (gnat_entity)) && saved))
5086 if (!Comes_From_Source (gnat_entity))
5087 DECL_ARTIFICIAL (gnu_decl) = 1;
5090 DECL_IGNORED_P (gnu_decl) = 1;
5093 /* If we haven't already, associate the ..._DECL node that we just made with
5094 the input GNAT entity node. */
5096 save_gnu_tree (gnat_entity, gnu_decl, false);
5098 /* If this is an enumeration or floating-point type, we were not able to set
5099 the bounds since they refer to the type. These are always static. */
5100 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
5101 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
5103 tree gnu_scalar_type = gnu_type;
5104 tree gnu_low_bound, gnu_high_bound;
5106 /* If this is a padded type, we need to use the underlying type. */
5107 if (TYPE_IS_PADDING_P (gnu_scalar_type))
5108 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
5110 /* If this is a floating point type and we haven't set a floating
5111 point type yet, use this in the evaluation of the bounds. */
5112 if (!longest_float_type_node && kind == E_Floating_Point_Type)
5113 longest_float_type_node = gnu_scalar_type;
5115 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5116 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5118 if (kind == E_Enumeration_Type)
5120 /* Enumeration types have specific RM bounds. */
5121 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5122 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5124 /* Write full debugging information. */
5125 rest_of_type_decl_compilation (gnu_decl);
5130 /* Floating-point types don't have specific RM bounds. */
5131 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5132 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5136 /* If we deferred processing of incomplete types, re-enable it. If there
5137 were no other disables and we have deferred types to process, do so. */
5139 && --defer_incomplete_level == 0
5140 && defer_incomplete_list)
5142 struct incomplete *p, *next;
5144 /* We are back to level 0 for the deferring of incomplete types.
5145 But processing these incomplete types below may itself require
5146 deferring, so preserve what we have and restart from scratch. */
5147 p = defer_incomplete_list;
5148 defer_incomplete_list = NULL;
5150 /* For finalization, however, all types must be complete so we
5151 cannot do the same because deferred incomplete types may end up
5152 referencing each other. Process them all recursively first. */
5153 defer_finalize_level++;
5160 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5161 gnat_to_gnu_type (p->full_type));
5165 defer_finalize_level--;
5168 /* If all the deferred incomplete types have been processed, we can proceed
5169 with the finalization of the deferred types. */
5170 if (defer_incomplete_level == 0
5171 && defer_finalize_level == 0
5172 && defer_finalize_list)
5177 FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t)
5178 rest_of_type_decl_compilation_no_defer (t);
5180 VEC_free (tree, heap, defer_finalize_list);
5183 /* If we are not defining this type, see if it's on one of the lists of
5184 incomplete types. If so, handle the list entry now. */
5185 if (is_type && !definition)
5187 struct incomplete *p;
5189 for (p = defer_incomplete_list; p; p = p->next)
5190 if (p->old_type && p->full_type == gnat_entity)
5192 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5193 TREE_TYPE (gnu_decl));
5194 p->old_type = NULL_TREE;
5197 for (p = defer_limited_with; p; p = p->next)
5198 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5200 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5201 TREE_TYPE (gnu_decl));
5202 p->old_type = NULL_TREE;
5209 /* If this is a packed array type whose original array type is itself
5210 an Itype without freeze node, make sure the latter is processed. */
5211 if (Is_Packed_Array_Type (gnat_entity)
5212 && Is_Itype (Original_Array_Type (gnat_entity))
5213 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5214 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5215 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5220 /* Similar, but if the returned value is a COMPONENT_REF, return the
5224 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5226 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5228 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5229 gnu_field = TREE_OPERAND (gnu_field, 1);
5234 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5235 the GCC type corresponding to that entity. */
5238 gnat_to_gnu_type (Entity_Id gnat_entity)
5242 /* The back end never attempts to annotate generic types. */
5243 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5244 return void_type_node;
5246 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5247 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5249 return TREE_TYPE (gnu_decl);
5252 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5253 the unpadded version of the GCC type corresponding to that entity. */
5256 get_unpadded_type (Entity_Id gnat_entity)
5258 tree type = gnat_to_gnu_type (gnat_entity);
5260 if (TYPE_IS_PADDING_P (type))
5261 type = TREE_TYPE (TYPE_FIELDS (type));
5266 /* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
5267 type has been changed to that of the parameterless procedure, except if an
5268 alias is already present, in which case it is returned instead. */
5271 get_minimal_subprog_decl (Entity_Id gnat_entity)
5273 tree gnu_entity_name, gnu_ext_name;
5274 struct attrib *attr_list = NULL;
5276 /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
5277 of the handling applied here. */
5279 while (Present (Alias (gnat_entity)))
5281 gnat_entity = Alias (gnat_entity);
5282 if (present_gnu_tree (gnat_entity))
5283 return get_gnu_tree (gnat_entity);
5286 gnu_entity_name = get_entity_name (gnat_entity);
5287 gnu_ext_name = create_concat_name (gnat_entity, NULL);
5289 if (Has_Stdcall_Convention (gnat_entity))
5290 prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
5291 get_identifier ("stdcall"), NULL_TREE,
5294 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
5295 gnu_ext_name = NULL_TREE;
5298 create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
5299 false, true, true, true, attr_list, gnat_entity);
5302 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
5303 Every TYPE_DECL generated for a type definition must be passed
5304 to this function once everything else has been done for it. */
5307 rest_of_type_decl_compilation (tree decl)
5309 /* We need to defer finalizing the type if incomplete types
5310 are being deferred or if they are being processed. */
5311 if (defer_incomplete_level != 0 || defer_finalize_level != 0)
5312 VEC_safe_push (tree, heap, defer_finalize_list, decl);
5314 rest_of_type_decl_compilation_no_defer (decl);
5317 /* Same as above but without deferring the compilation. This
5318 function should not be invoked directly on a TYPE_DECL. */
5321 rest_of_type_decl_compilation_no_defer (tree decl)
5323 const int toplev = global_bindings_p ();
5324 tree t = TREE_TYPE (decl);
5326 rest_of_decl_compilation (decl, toplev, 0);
5328 /* Now process all the variants. This is needed for STABS. */
5329 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
5331 if (t == TREE_TYPE (decl))
5334 if (!TYPE_STUB_DECL (t))
5335 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
5337 rest_of_type_compilation (t, toplev);
5341 /* Finalize the processing of From_With_Type incomplete types. */
5344 finalize_from_with_types (void)
5346 struct incomplete *p, *next;
5348 p = defer_limited_with;
5349 defer_limited_with = NULL;
5356 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5357 gnat_to_gnu_type (p->full_type));
5362 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5363 kind of type (such E_Task_Type) that has a different type which Gigi
5364 uses for its representation. If the type does not have a special type
5365 for its representation, return GNAT_ENTITY. If a type is supposed to
5366 exist, but does not, abort unless annotating types, in which case
5367 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5370 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5372 Entity_Id gnat_equiv = gnat_entity;
5374 if (No (gnat_entity))
5377 switch (Ekind (gnat_entity))
5379 case E_Class_Wide_Subtype:
5380 if (Present (Equivalent_Type (gnat_entity)))
5381 gnat_equiv = Equivalent_Type (gnat_entity);
5384 case E_Access_Protected_Subprogram_Type:
5385 case E_Anonymous_Access_Protected_Subprogram_Type:
5386 gnat_equiv = Equivalent_Type (gnat_entity);
5389 case E_Class_Wide_Type:
5390 gnat_equiv = Root_Type (gnat_entity);
5394 case E_Task_Subtype:
5395 case E_Protected_Type:
5396 case E_Protected_Subtype:
5397 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5404 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5409 /* Return a GCC tree for a type corresponding to the component type of the
5410 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5411 is for an array being defined. DEBUG_INFO_P is true if we need to write
5412 debug information for other types that we may create in the process. */
5415 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5418 const Entity_Id gnat_type = Component_Type (gnat_array);
5419 tree gnu_type = gnat_to_gnu_type (gnat_type);
5422 /* Try to get a smaller form of the component if needed. */
5423 if ((Is_Packed (gnat_array)
5424 || Has_Component_Size_Clause (gnat_array))
5425 && !Is_Bit_Packed_Array (gnat_array)
5426 && !Has_Aliased_Components (gnat_array)
5427 && !Strict_Alignment (gnat_type)
5428 && RECORD_OR_UNION_TYPE_P (gnu_type)
5429 && !TYPE_FAT_POINTER_P (gnu_type)
5430 && host_integerp (TYPE_SIZE (gnu_type), 1))
5431 gnu_type = make_packable_type (gnu_type, false);
5433 if (Has_Atomic_Components (gnat_array))
5434 check_ok_for_atomic (gnu_type, gnat_array, true);
5436 /* Get and validate any specified Component_Size. */
5438 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5439 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5440 true, Has_Component_Size_Clause (gnat_array));
5442 /* If the array has aliased components and the component size can be zero,
5443 force at least unit size to ensure that the components have distinct
5446 && Has_Aliased_Components (gnat_array)
5447 && (integer_zerop (TYPE_SIZE (gnu_type))
5448 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5449 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5451 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5453 /* If the component type is a RECORD_TYPE that has a self-referential size,
5454 then use the maximum size for the component size. */
5456 && TREE_CODE (gnu_type) == RECORD_TYPE
5457 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5458 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5460 /* Honor the component size. This is not needed for bit-packed arrays. */
5461 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5463 tree orig_type = gnu_type;
5464 unsigned int max_align;
5466 /* If an alignment is specified, use it as a cap on the component type
5467 so that it can be honored for the whole type. But ignore it for the
5468 original type of packed array types. */
5469 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5470 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5474 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5475 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5476 gnu_type = orig_type;
5478 orig_type = gnu_type;
5480 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5481 true, false, definition, true);
5483 /* If a padding record was made, declare it now since it will never be
5484 declared otherwise. This is necessary to ensure that its subtrees
5485 are properly marked. */
5486 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5487 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5488 debug_info_p, gnat_array);
5491 if (Has_Volatile_Components (gnat_array))
5493 = build_qualified_type (gnu_type,
5494 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5499 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5500 using MECH as its passing mechanism, to be placed in the parameter
5501 list built for GNAT_SUBPROG. Assume a foreign convention for the
5502 latter if FOREIGN is true. Also set CICO to true if the parameter
5503 must use the copy-in copy-out implementation mechanism.
5505 The returned tree is a PARM_DECL, except for those cases where no
5506 parameter needs to be actually passed to the subprogram; the type
5507 of this "shadow" parameter is then returned instead. */
5510 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5511 Entity_Id gnat_subprog, bool foreign, bool *cico)
5513 tree gnu_param_name = get_entity_name (gnat_param);
5514 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5515 tree gnu_param_type_alt = NULL_TREE;
5516 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5517 /* The parameter can be indirectly modified if its address is taken. */
5518 bool ro_param = in_param && !Address_Taken (gnat_param);
5519 bool by_return = false, by_component_ptr = false;
5520 bool by_ref = false, by_double_ref = false;
5523 /* Copy-return is used only for the first parameter of a valued procedure.
5524 It's a copy mechanism for which a parameter is never allocated. */
5525 if (mech == By_Copy_Return)
5527 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5532 /* If this is either a foreign function or if the underlying type won't
5533 be passed by reference, strip off possible padding type. */
5534 if (TYPE_IS_PADDING_P (gnu_param_type))
5536 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5538 if (mech == By_Reference
5540 || (!must_pass_by_ref (unpadded_type)
5541 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5542 gnu_param_type = unpadded_type;
5545 /* If this is a read-only parameter, make a variant of the type that is
5546 read-only. ??? However, if this is an unconstrained array, that type
5547 can be very complex, so skip it for now. Likewise for any other
5548 self-referential type. */
5550 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5551 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5552 gnu_param_type = build_qualified_type (gnu_param_type,
5553 (TYPE_QUALS (gnu_param_type)
5554 | TYPE_QUAL_CONST));
5556 /* For foreign conventions, pass arrays as pointers to the element type.
5557 First check for unconstrained array and get the underlying array. */
5558 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5560 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5562 /* For GCC builtins, pass Address integer types as (void *) */
5563 if (Convention (gnat_subprog) == Convention_Intrinsic
5564 && Present (Interface_Name (gnat_subprog))
5565 && Is_Descendent_Of_Address (Etype (gnat_param)))
5566 gnu_param_type = ptr_void_type_node;
5568 /* VMS descriptors are themselves passed by reference. */
5569 if (mech == By_Short_Descriptor ||
5570 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5572 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5573 Mechanism (gnat_param),
5575 else if (mech == By_Descriptor)
5577 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5578 chosen in fill_vms_descriptor. */
5580 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5581 Mechanism (gnat_param),
5584 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5585 Mechanism (gnat_param),
5589 /* Arrays are passed as pointers to element type for foreign conventions. */
5592 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5594 /* Strip off any multi-dimensional entries, then strip
5595 off the last array to get the component type. */
5596 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5597 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5598 gnu_param_type = TREE_TYPE (gnu_param_type);
5600 by_component_ptr = true;
5601 gnu_param_type = TREE_TYPE (gnu_param_type);
5604 gnu_param_type = build_qualified_type (gnu_param_type,
5605 (TYPE_QUALS (gnu_param_type)
5606 | TYPE_QUAL_CONST));
5608 gnu_param_type = build_pointer_type (gnu_param_type);
5611 /* Fat pointers are passed as thin pointers for foreign conventions. */
5612 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5614 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5616 /* If we must pass or were requested to pass by reference, do so.
5617 If we were requested to pass by copy, do so.
5618 Otherwise, for foreign conventions, pass In Out or Out parameters
5619 or aggregates by reference. For COBOL and Fortran, pass all
5620 integer and FP types that way too. For Convention Ada, use
5621 the standard Ada default. */
5622 else if (must_pass_by_ref (gnu_param_type)
5623 || mech == By_Reference
5626 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5628 && (Convention (gnat_subprog) == Convention_Fortran
5629 || Convention (gnat_subprog) == Convention_COBOL)
5630 && (INTEGRAL_TYPE_P (gnu_param_type)
5631 || FLOAT_TYPE_P (gnu_param_type)))
5633 && default_pass_by_ref (gnu_param_type)))))
5635 /* We take advantage of 6.2(12) by considering that references built for
5636 parameters whose type isn't by-ref and for which the mechanism hasn't
5637 been forced to by-ref are restrict-qualified in the C sense. */
5639 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5640 gnu_param_type = build_reference_type (gnu_param_type);
5643 = build_qualified_type (gnu_param_type, TYPE_QUAL_RESTRICT);
5646 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5647 passed by reference. Pass them by explicit reference, this will
5648 generate more debuggable code at -O0. */
5649 if (TYPE_IS_FAT_POINTER_P (gnu_param_type)
5650 && targetm.calls.pass_by_reference (pack_cumulative_args (NULL),
5651 TYPE_MODE (gnu_param_type),
5655 gnu_param_type = build_reference_type (gnu_param_type);
5656 by_double_ref = true;
5660 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5664 if (mech == By_Copy && (by_ref || by_component_ptr))
5665 post_error ("?cannot pass & by copy", gnat_param);
5667 /* If this is an Out parameter that isn't passed by reference and isn't
5668 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5669 it will be a VAR_DECL created when we process the procedure, so just
5670 return its type. For the special parameter of a valued procedure,
5673 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5674 Out parameters with discriminants or implicit initial values to be
5675 handled like In Out parameters. These type are normally built as
5676 aggregates, hence passed by reference, except for some packed arrays
5677 which end up encoded in special integer types.
5679 The exception we need to make is then for packed arrays of records
5680 with discriminants or implicit initial values. We have no light/easy
5681 way to check for the latter case, so we merely check for packed arrays
5682 of records. This may lead to useless copy-in operations, but in very
5683 rare cases only, as these would be exceptions in a set of already
5684 exceptional situations. */
5685 if (Ekind (gnat_param) == E_Out_Parameter
5688 || (mech != By_Descriptor
5689 && mech != By_Short_Descriptor
5690 && !POINTER_TYPE_P (gnu_param_type)
5691 && !AGGREGATE_TYPE_P (gnu_param_type)))
5692 && !(Is_Array_Type (Etype (gnat_param))
5693 && Is_Packed (Etype (gnat_param))
5694 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5695 return gnu_param_type;
5697 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5698 ro_param || by_ref || by_component_ptr);
5699 DECL_BY_REF_P (gnu_param) = by_ref;
5700 DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref;
5701 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5702 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5703 mech == By_Short_Descriptor);
5704 /* Note that, in case of a parameter passed by double reference, the
5705 DECL_POINTS_TO_READONLY_P flag is meant for the second reference.
5706 The first reference always points to read-only, as it points to
5707 the second reference, i.e. the reference to the actual parameter. */
5708 DECL_POINTS_TO_READONLY_P (gnu_param)
5709 = (ro_param && (by_ref || by_component_ptr));
5710 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5712 /* Save the alternate descriptor type, if any. */
5713 if (gnu_param_type_alt)
5714 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5716 /* If no Mechanism was specified, indicate what we're using, then
5717 back-annotate it. */
5718 if (mech == Default)
5719 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5721 Set_Mechanism (gnat_param, mech);
5725 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5728 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5730 while (Present (Corresponding_Discriminant (discr1)))
5731 discr1 = Corresponding_Discriminant (discr1);
5733 while (Present (Corresponding_Discriminant (discr2)))
5734 discr2 = Corresponding_Discriminant (discr2);
5737 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5740 /* Return true if the array type GNU_TYPE, which represents a dimension of
5741 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5744 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5746 /* If the array type is not the innermost dimension of the GNAT type,
5747 then it has a non-aliased component. */
5748 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5749 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5752 /* If the array type has an aliased component in the front-end sense,
5753 then it also has an aliased component in the back-end sense. */
5754 if (Has_Aliased_Components (gnat_type))
5757 /* If this is a derived type, then it has a non-aliased component if
5758 and only if its parent type also has one. */
5759 if (Is_Derived_Type (gnat_type))
5761 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5763 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5765 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5766 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5767 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5768 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5771 /* Otherwise, rely exclusively on properties of the element type. */
5772 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5775 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5778 compile_time_known_address_p (Node_Id gnat_address)
5780 /* Catch System'To_Address. */
5781 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5782 gnat_address = Expression (gnat_address);
5784 return Compile_Time_Known_Value (gnat_address);
5787 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5788 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5791 cannot_be_superflat_p (Node_Id gnat_range)
5793 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5794 Node_Id scalar_range;
5795 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5797 /* If the low bound is not constant, try to find an upper bound. */
5798 while (Nkind (gnat_lb) != N_Integer_Literal
5799 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5800 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5801 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5802 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5803 || Nkind (scalar_range) == N_Range))
5804 gnat_lb = High_Bound (scalar_range);
5806 /* If the high bound is not constant, try to find a lower bound. */
5807 while (Nkind (gnat_hb) != N_Integer_Literal
5808 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5809 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5810 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5811 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5812 || Nkind (scalar_range) == N_Range))
5813 gnat_hb = Low_Bound (scalar_range);
5815 /* If we have failed to find constant bounds, punt. */
5816 if (Nkind (gnat_lb) != N_Integer_Literal
5817 || Nkind (gnat_hb) != N_Integer_Literal)
5820 /* We need at least a signed 64-bit type to catch most cases. */
5821 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5822 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5823 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5826 /* If the low bound is the smallest integer, nothing can be smaller. */
5827 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5828 if (TREE_OVERFLOW (gnu_lb_minus_one))
5831 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5834 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5837 constructor_address_p (tree gnu_expr)
5839 while (TREE_CODE (gnu_expr) == NOP_EXPR
5840 || TREE_CODE (gnu_expr) == CONVERT_EXPR
5841 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5842 gnu_expr = TREE_OPERAND (gnu_expr, 0);
5844 return (TREE_CODE (gnu_expr) == ADDR_EXPR
5845 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5848 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5849 be elaborated at the point of its definition, but do nothing else. */
5852 elaborate_entity (Entity_Id gnat_entity)
5854 switch (Ekind (gnat_entity))
5856 case E_Signed_Integer_Subtype:
5857 case E_Modular_Integer_Subtype:
5858 case E_Enumeration_Subtype:
5859 case E_Ordinary_Fixed_Point_Subtype:
5860 case E_Decimal_Fixed_Point_Subtype:
5861 case E_Floating_Point_Subtype:
5863 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5864 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5866 /* ??? Tests to avoid Constraint_Error in static expressions
5867 are needed until after the front stops generating bogus
5868 conversions on bounds of real types. */
5869 if (!Raises_Constraint_Error (gnat_lb))
5870 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5871 true, false, Needs_Debug_Info (gnat_entity));
5872 if (!Raises_Constraint_Error (gnat_hb))
5873 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5874 true, false, Needs_Debug_Info (gnat_entity));
5880 Node_Id full_definition = Declaration_Node (gnat_entity);
5881 Node_Id record_definition = Type_Definition (full_definition);
5883 /* If this is a record extension, go a level further to find the
5884 record definition. */
5885 if (Nkind (record_definition) == N_Derived_Type_Definition)
5886 record_definition = Record_Extension_Part (record_definition);
5890 case E_Record_Subtype:
5891 case E_Private_Subtype:
5892 case E_Limited_Private_Subtype:
5893 case E_Record_Subtype_With_Private:
5894 if (Is_Constrained (gnat_entity)
5895 && Has_Discriminants (gnat_entity)
5896 && Present (Discriminant_Constraint (gnat_entity)))
5898 Node_Id gnat_discriminant_expr;
5899 Entity_Id gnat_field;
5902 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5903 gnat_discriminant_expr
5904 = First_Elmt (Discriminant_Constraint (gnat_entity));
5905 Present (gnat_field);
5906 gnat_field = Next_Discriminant (gnat_field),
5907 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5908 /* ??? For now, ignore access discriminants. */
5909 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5910 elaborate_expression (Node (gnat_discriminant_expr),
5911 gnat_entity, get_entity_name (gnat_field),
5912 true, false, false);
5919 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5920 any entities on its entity chain similarly. */
5923 mark_out_of_scope (Entity_Id gnat_entity)
5925 Entity_Id gnat_sub_entity;
5926 unsigned int kind = Ekind (gnat_entity);
5928 /* If this has an entity list, process all in the list. */
5929 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5930 || IN (kind, Private_Kind)
5931 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5932 || kind == E_Function || kind == E_Generic_Function
5933 || kind == E_Generic_Package || kind == E_Generic_Procedure
5934 || kind == E_Loop || kind == E_Operator || kind == E_Package
5935 || kind == E_Package_Body || kind == E_Procedure
5936 || kind == E_Record_Type || kind == E_Record_Subtype
5937 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5938 for (gnat_sub_entity = First_Entity (gnat_entity);
5939 Present (gnat_sub_entity);
5940 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5941 if (Scope (gnat_sub_entity) == gnat_entity
5942 && gnat_sub_entity != gnat_entity)
5943 mark_out_of_scope (gnat_sub_entity);
5945 /* Now clear this if it has been defined, but only do so if it isn't
5946 a subprogram or parameter. We could refine this, but it isn't
5947 worth it. If this is statically allocated, it is supposed to
5948 hang around out of cope. */
5949 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5950 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5952 save_gnu_tree (gnat_entity, NULL_TREE, true);
5953 save_gnu_tree (gnat_entity, error_mark_node, true);
5957 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5958 If this is a multi-dimensional array type, do this recursively.
5961 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5962 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5963 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5966 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5968 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5969 of a one-dimensional array, since the padding has the same alias set
5970 as the field type, but if it's a multi-dimensional array, we need to
5971 see the inner types. */
5972 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5973 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5974 || TYPE_PADDING_P (gnu_old_type)))
5975 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5977 /* Unconstrained array types are deemed incomplete and would thus be given
5978 alias set 0. Retrieve the underlying array type. */
5979 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5981 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5982 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5984 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5986 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5987 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5988 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5989 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5993 case ALIAS_SET_COPY:
5994 /* The alias set shouldn't be copied between array types with different
5995 aliasing settings because this can break the aliasing relationship
5996 between the array type and its element type. */
5997 #ifndef ENABLE_CHECKING
5998 if (flag_strict_aliasing)
6000 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
6001 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
6002 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
6003 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
6005 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
6008 case ALIAS_SET_SUBSET:
6009 case ALIAS_SET_SUPERSET:
6011 alias_set_type old_set = get_alias_set (gnu_old_type);
6012 alias_set_type new_set = get_alias_set (gnu_new_type);
6014 /* Do nothing if the alias sets conflict. This ensures that we
6015 never call record_alias_subset several times for the same pair
6016 or at all for alias set 0. */
6017 if (!alias_sets_conflict_p (old_set, new_set))
6019 if (op == ALIAS_SET_SUBSET)
6020 record_alias_subset (old_set, new_set);
6022 record_alias_subset (new_set, old_set);
6031 record_component_aliases (gnu_new_type);
6034 /* Return true if the size represented by GNU_SIZE can be handled by an
6035 allocation. If STATIC_P is true, consider only what can be done with a
6036 static allocation. */
6039 allocatable_size_p (tree gnu_size, bool static_p)
6041 HOST_WIDE_INT our_size;
6043 /* If this is not a static allocation, the only case we want to forbid
6044 is an overflowing size. That will be converted into a raise a
6047 return !(TREE_CODE (gnu_size) == INTEGER_CST
6048 && TREE_OVERFLOW (gnu_size));
6050 /* Otherwise, we need to deal with both variable sizes and constant
6051 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
6052 since assemblers may not like very large sizes. */
6053 if (!host_integerp (gnu_size, 1))
6056 our_size = tree_low_cst (gnu_size, 1);
6057 return (int) our_size == our_size;
6060 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6061 NAME, ARGS and ERROR_POINT. */
6064 prepend_one_attribute_to (struct attrib ** attr_list,
6065 enum attr_type attr_type,
6068 Node_Id attr_error_point)
6070 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
6072 attr->type = attr_type;
6073 attr->name = attr_name;
6074 attr->args = attr_args;
6075 attr->error_point = attr_error_point;
6077 attr->next = *attr_list;
6081 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6084 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
6088 /* Attributes are stored as Representation Item pragmas. */
6090 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
6091 gnat_temp = Next_Rep_Item (gnat_temp))
6092 if (Nkind (gnat_temp) == N_Pragma)
6094 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
6095 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
6096 enum attr_type etype;
6098 /* Map the kind of pragma at hand. Skip if this is not one
6099 we know how to handle. */
6101 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
6103 case Pragma_Machine_Attribute:
6104 etype = ATTR_MACHINE_ATTRIBUTE;
6107 case Pragma_Linker_Alias:
6108 etype = ATTR_LINK_ALIAS;
6111 case Pragma_Linker_Section:
6112 etype = ATTR_LINK_SECTION;
6115 case Pragma_Linker_Constructor:
6116 etype = ATTR_LINK_CONSTRUCTOR;
6119 case Pragma_Linker_Destructor:
6120 etype = ATTR_LINK_DESTRUCTOR;
6123 case Pragma_Weak_External:
6124 etype = ATTR_WEAK_EXTERNAL;
6127 case Pragma_Thread_Local_Storage:
6128 etype = ATTR_THREAD_LOCAL_STORAGE;
6135 /* See what arguments we have and turn them into GCC trees for
6136 attribute handlers. These expect identifier for strings. We
6137 handle at most two arguments, static expressions only. */
6139 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
6141 Node_Id gnat_arg0 = Next (First (gnat_assoc));
6142 Node_Id gnat_arg1 = Empty;
6144 if (Present (gnat_arg0)
6145 && Is_Static_Expression (Expression (gnat_arg0)))
6147 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
6149 if (TREE_CODE (gnu_arg0) == STRING_CST)
6150 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6152 gnat_arg1 = Next (gnat_arg0);
6155 if (Present (gnat_arg1)
6156 && Is_Static_Expression (Expression (gnat_arg1)))
6158 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6160 if (TREE_CODE (gnu_arg1) == STRING_CST)
6161 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6165 /* Prepend to the list now. Make a list of the argument we might
6166 have, as GCC expects it. */
6167 prepend_one_attribute_to
6170 (gnu_arg1 != NULL_TREE)
6171 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6172 Present (Next (First (gnat_assoc)))
6173 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
6177 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6178 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6179 return the GCC tree to use for that expression. GNU_NAME is the suffix
6180 to use if a variable needs to be created and DEFINITION is true if this
6181 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6182 otherwise, we are just elaborating the expression for side-effects. If
6183 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6184 isn't needed for code generation. */
6187 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
6188 bool definition, bool need_value, bool need_debug)
6192 /* If we already elaborated this expression (e.g. it was involved
6193 in the definition of a private type), use the old value. */
6194 if (present_gnu_tree (gnat_expr))
6195 return get_gnu_tree (gnat_expr);
6197 /* If we don't need a value and this is static or a discriminant,
6198 we don't need to do anything. */
6200 && (Is_OK_Static_Expression (gnat_expr)
6201 || (Nkind (gnat_expr) == N_Identifier
6202 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6205 /* If it's a static expression, we don't need a variable for debugging. */
6206 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6209 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6210 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
6211 gnu_name, definition, need_debug);
6213 /* Save the expression in case we try to elaborate this entity again. Since
6214 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6215 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6216 save_gnu_tree (gnat_expr, gnu_expr, true);
6218 return need_value ? gnu_expr : error_mark_node;
6221 /* Similar, but take a GNU expression and always return a result. */
6224 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6225 bool definition, bool need_debug)
6227 const bool expr_public_p = Is_Public (gnat_entity);
6228 const bool expr_global_p = expr_public_p || global_bindings_p ();
6229 bool expr_variable_p, use_variable;
6231 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6232 reference will have been replaced with a COMPONENT_REF when the type
6233 is being elaborated. However, there are some cases involving child
6234 types where we will. So convert it to a COMPONENT_REF. We hope it
6235 will be at the highest level of the expression in these cases. */
6236 if (TREE_CODE (gnu_expr) == FIELD_DECL)
6237 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
6238 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
6239 gnu_expr, NULL_TREE);
6241 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6242 that an expression cannot contain both a discriminant and a variable. */
6243 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6246 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6247 a variable that is initialized to contain the expression when the package
6248 containing the definition is elaborated. If this entity is defined at top
6249 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6250 if this is necessary. */
6251 if (CONSTANT_CLASS_P (gnu_expr))
6252 expr_variable_p = false;
6255 /* Skip any conversions and simple arithmetics to see if the expression
6256 is based on a read-only variable.
6257 ??? This really should remain read-only, but we have to think about
6258 the typing of the tree here. */
6260 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
6262 if (handled_component_p (inner))
6264 HOST_WIDE_INT bitsize, bitpos;
6266 enum machine_mode mode;
6267 int unsignedp, volatilep;
6269 inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
6270 &mode, &unsignedp, &volatilep, false);
6271 /* If the offset is variable, err on the side of caution. */
6278 && TREE_CODE (inner) == VAR_DECL
6279 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6282 /* We only need to use the variable if we are in a global context since GCC
6283 can do the right thing in the local case. However, when not optimizing,
6284 use it for bounds of loop iteration scheme to avoid code duplication. */
6285 use_variable = expr_variable_p
6288 && Is_Itype (gnat_entity)
6289 && Nkind (Associated_Node_For_Itype (gnat_entity))
6290 == N_Loop_Parameter_Specification));
6292 /* Now create it, possibly only for debugging purposes. */
6293 if (use_variable || need_debug)
6297 (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)),
6298 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p,
6299 !definition, expr_global_p, !need_debug, NULL, gnat_entity);
6305 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6308 /* Similar, but take an alignment factor and make it explicit in the tree. */
6311 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6312 bool definition, bool need_debug, unsigned int align)
6314 tree unit_align = size_int (align / BITS_PER_UNIT);
6316 size_binop (MULT_EXPR,
6317 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6320 gnat_entity, gnu_name, definition,
6325 /* Create a record type that contains a SIZE bytes long field of TYPE with a
6326 starting bit position so that it is aligned to ALIGN bits, and leaving at
6327 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
6328 record is guaranteed to get. */
6331 make_aligning_type (tree type, unsigned int align, tree size,
6332 unsigned int base_align, int room)
6334 /* We will be crafting a record type with one field at a position set to be
6335 the next multiple of ALIGN past record'address + room bytes. We use a
6336 record placeholder to express record'address. */
6337 tree record_type = make_node (RECORD_TYPE);
6338 tree record = build0 (PLACEHOLDER_EXPR, record_type);
6341 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
6343 /* The diagram below summarizes the shape of what we manipulate:
6345 <--------- pos ---------->
6346 { +------------+-------------+-----------------+
6347 record =>{ |############| ... | field (type) |
6348 { +------------+-------------+-----------------+
6349 |<-- room -->|<- voffset ->|<---- size ----->|
6352 record_addr vblock_addr
6354 Every length is in sizetype bytes there, except "pos" which has to be
6355 set as a bit position in the GCC tree for the record. */
6356 tree room_st = size_int (room);
6357 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
6358 tree voffset_st, pos, field;
6360 tree name = TYPE_NAME (type);
6362 if (TREE_CODE (name) == TYPE_DECL)
6363 name = DECL_NAME (name);
6364 name = concat_name (name, "ALIGN");
6365 TYPE_NAME (record_type) = name;
6367 /* Compute VOFFSET and then POS. The next byte position multiple of some
6368 alignment after some address is obtained by "and"ing the alignment minus
6369 1 with the two's complement of the address. */
6370 voffset_st = size_binop (BIT_AND_EXPR,
6371 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
6372 size_int ((align / BITS_PER_UNIT) - 1));
6374 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
6375 pos = size_binop (MULT_EXPR,
6376 convert (bitsizetype,
6377 size_binop (PLUS_EXPR, room_st, voffset_st)),
6380 /* Craft the GCC record representation. We exceptionally do everything
6381 manually here because 1) our generic circuitry is not quite ready to
6382 handle the complex position/size expressions we are setting up, 2) we
6383 have a strong simplifying factor at hand: we know the maximum possible
6384 value of voffset, and 3) we have to set/reset at least the sizes in
6385 accordance with this maximum value anyway, as we need them to convey
6386 what should be "alloc"ated for this type.
6388 Use -1 as the 'addressable' indication for the field to prevent the
6389 creation of a bitfield. We don't need one, it would have damaging
6390 consequences on the alignment computation, and create_field_decl would
6391 make one without this special argument, for instance because of the
6392 complex position expression. */
6393 field = create_field_decl (get_identifier ("F"), type, record_type, size,
6395 TYPE_FIELDS (record_type) = field;
6397 TYPE_ALIGN (record_type) = base_align;
6398 TYPE_USER_ALIGN (record_type) = 1;
6400 TYPE_SIZE (record_type)
6401 = size_binop (PLUS_EXPR,
6402 size_binop (MULT_EXPR, convert (bitsizetype, size),
6404 bitsize_int (align + room * BITS_PER_UNIT));
6405 TYPE_SIZE_UNIT (record_type)
6406 = size_binop (PLUS_EXPR, size,
6407 size_int (room + align / BITS_PER_UNIT));
6409 SET_TYPE_MODE (record_type, BLKmode);
6410 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
6412 /* Declare it now since it will never be declared otherwise. This is
6413 necessary to ensure that its subtrees are properly marked. */
6414 create_type_decl (name, record_type, NULL, true, false, Empty);
6419 /* Return the result of rounding T up to ALIGN. */
6421 static inline unsigned HOST_WIDE_INT
6422 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
6430 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
6431 as the field type of a packed record if IN_RECORD is true, or as the
6432 component type of a packed array if IN_RECORD is false. See if we can
6433 rewrite it either as a type that has a non-BLKmode, which we can pack
6434 tighter in the packed record case, or as a smaller type. If so, return
6435 the new type. If not, return the original type. */
6438 make_packable_type (tree type, bool in_record)
6440 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
6441 unsigned HOST_WIDE_INT new_size;
6442 tree new_type, old_field, field_list = NULL_TREE;
6444 /* No point in doing anything if the size is zero. */
6448 new_type = make_node (TREE_CODE (type));
6450 /* Copy the name and flags from the old type to that of the new.
6451 Note that we rely on the pointer equality created here for
6452 TYPE_NAME to look through conversions in various places. */
6453 TYPE_NAME (new_type) = TYPE_NAME (type);
6454 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
6455 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
6456 if (TREE_CODE (type) == RECORD_TYPE)
6457 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
6459 /* If we are in a record and have a small size, set the alignment to
6460 try for an integral mode. Otherwise set it to try for a smaller
6461 type with BLKmode. */
6462 if (in_record && size <= MAX_FIXED_MODE_SIZE)
6464 TYPE_ALIGN (new_type) = ceil_alignment (size);
6465 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
6469 unsigned HOST_WIDE_INT align;
6471 /* Do not try to shrink the size if the RM size is not constant. */
6472 if (TYPE_CONTAINS_TEMPLATE_P (type)
6473 || !host_integerp (TYPE_ADA_SIZE (type), 1))
6476 /* Round the RM size up to a unit boundary to get the minimal size
6477 for a BLKmode record. Give up if it's already the size. */
6478 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
6479 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
6480 if (new_size == size)
6483 align = new_size & -new_size;
6484 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
6487 TYPE_USER_ALIGN (new_type) = 1;
6489 /* Now copy the fields, keeping the position and size as we don't want
6490 to change the layout by propagating the packedness downwards. */
6491 for (old_field = TYPE_FIELDS (type); old_field;
6492 old_field = DECL_CHAIN (old_field))
6494 tree new_field_type = TREE_TYPE (old_field);
6495 tree new_field, new_size;
6497 if (RECORD_OR_UNION_TYPE_P (new_field_type)
6498 && !TYPE_FAT_POINTER_P (new_field_type)
6499 && host_integerp (TYPE_SIZE (new_field_type), 1))
6500 new_field_type = make_packable_type (new_field_type, true);
6502 /* However, for the last field in a not already packed record type
6503 that is of an aggregate type, we need to use the RM size in the
6504 packable version of the record type, see finish_record_type. */
6505 if (!DECL_CHAIN (old_field)
6506 && !TYPE_PACKED (type)
6507 && RECORD_OR_UNION_TYPE_P (new_field_type)
6508 && !TYPE_FAT_POINTER_P (new_field_type)
6509 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6510 && TYPE_ADA_SIZE (new_field_type))
6511 new_size = TYPE_ADA_SIZE (new_field_type);
6513 new_size = DECL_SIZE (old_field);
6516 = create_field_decl (DECL_NAME (old_field), new_field_type, new_type,
6517 new_size, bit_position (old_field),
6519 !DECL_NONADDRESSABLE_P (old_field));
6521 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6522 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
6523 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6524 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6526 DECL_CHAIN (new_field) = field_list;
6527 field_list = new_field;
6530 finish_record_type (new_type, nreverse (field_list), 2, false);
6531 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6532 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
6533 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
6535 /* If this is a padding record, we never want to make the size smaller
6536 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6537 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6539 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6540 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6545 TYPE_SIZE (new_type) = bitsize_int (new_size);
6546 TYPE_SIZE_UNIT (new_type)
6547 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6550 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6551 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6553 compute_record_mode (new_type);
6555 /* Try harder to get a packable type if necessary, for example
6556 in case the record itself contains a BLKmode field. */
6557 if (in_record && TYPE_MODE (new_type) == BLKmode)
6558 SET_TYPE_MODE (new_type,
6559 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6561 /* If neither the mode nor the size has shrunk, return the old type. */
6562 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6568 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6569 if needed. We have already verified that SIZE and TYPE are large enough.
6570 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6571 IS_COMPONENT_TYPE is true if this is being done for the component type
6572 of an array. IS_USER_TYPE is true if we must complete the original type.
6573 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6574 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6575 it's set to the RM size of the original type. */
6578 maybe_pad_type (tree type, tree size, unsigned int align,
6579 Entity_Id gnat_entity, bool is_component_type,
6580 bool is_user_type, bool definition, bool same_rm_size)
6582 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6583 tree orig_size = TYPE_SIZE (type);
6586 /* If TYPE is a padded type, see if it agrees with any size and alignment
6587 we were given. If so, return the original type. Otherwise, strip
6588 off the padding, since we will either be returning the inner type
6589 or repadding it. If no size or alignment is specified, use that of
6590 the original padded type. */
6591 if (TYPE_IS_PADDING_P (type))
6594 || operand_equal_p (round_up (size,
6595 MAX (align, TYPE_ALIGN (type))),
6596 round_up (TYPE_SIZE (type),
6597 MAX (align, TYPE_ALIGN (type))),
6599 && (align == 0 || align == TYPE_ALIGN (type)))
6603 size = TYPE_SIZE (type);
6605 align = TYPE_ALIGN (type);
6607 type = TREE_TYPE (TYPE_FIELDS (type));
6608 orig_size = TYPE_SIZE (type);
6611 /* If the size is either not being changed or is being made smaller (which
6612 is not done here and is only valid for bitfields anyway), show the size
6613 isn't changing. Likewise, clear the alignment if it isn't being
6614 changed. Then return if we aren't doing anything. */
6616 && (operand_equal_p (size, orig_size, 0)
6617 || (TREE_CODE (orig_size) == INTEGER_CST
6618 && tree_int_cst_lt (size, orig_size))))
6621 if (align == TYPE_ALIGN (type))
6624 if (align == 0 && !size)
6627 /* If requested, complete the original type and give it a name. */
6629 create_type_decl (get_entity_name (gnat_entity), type,
6630 NULL, !Comes_From_Source (gnat_entity),
6632 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6633 && DECL_IGNORED_P (TYPE_NAME (type))),
6636 /* We used to modify the record in place in some cases, but that could
6637 generate incorrect debugging information. So make a new record
6639 record = make_node (RECORD_TYPE);
6640 TYPE_PADDING_P (record) = 1;
6642 if (Present (gnat_entity))
6643 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6645 TYPE_VOLATILE (record)
6646 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6648 TYPE_ALIGN (record) = align;
6649 TYPE_SIZE (record) = size ? size : orig_size;
6650 TYPE_SIZE_UNIT (record)
6651 = convert (sizetype,
6652 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6653 bitsize_unit_node));
6655 /* If we are changing the alignment and the input type is a record with
6656 BLKmode and a small constant size, try to make a form that has an
6657 integral mode. This might allow the padding record to also have an
6658 integral mode, which will be much more efficient. There is no point
6659 in doing so if a size is specified unless it is also a small constant
6660 size and it is incorrect to do so if we cannot guarantee that the mode
6661 will be naturally aligned since the field must always be addressable.
6663 ??? This might not always be a win when done for a stand-alone object:
6664 since the nominal and the effective type of the object will now have
6665 different modes, a VIEW_CONVERT_EXPR will be required for converting
6666 between them and it might be hard to overcome afterwards, including
6667 at the RTL level when the stand-alone object is accessed as a whole. */
6669 && RECORD_OR_UNION_TYPE_P (type)
6670 && TYPE_MODE (type) == BLKmode
6671 && !TYPE_BY_REFERENCE_P (type)
6672 && TREE_CODE (orig_size) == INTEGER_CST
6673 && !TREE_OVERFLOW (orig_size)
6674 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6676 || (TREE_CODE (size) == INTEGER_CST
6677 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6679 tree packable_type = make_packable_type (type, true);
6680 if (TYPE_MODE (packable_type) != BLKmode
6681 && align >= TYPE_ALIGN (packable_type))
6682 type = packable_type;
6685 /* Now create the field with the original size. */
6686 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
6687 bitsize_zero_node, 0, 1);
6688 DECL_INTERNAL_P (field) = 1;
6690 /* Do not emit debug info until after the auxiliary record is built. */
6691 finish_record_type (record, field, 1, false);
6693 /* Set the same size for its RM size if requested; otherwise reuse
6694 the RM size of the original type. */
6695 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6697 /* Unless debugging information isn't being written for the input type,
6698 write a record that shows what we are a subtype of and also make a
6699 variable that indicates our size, if still variable. */
6700 if (TREE_CODE (orig_size) != INTEGER_CST
6701 && TYPE_NAME (record)
6703 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6704 && DECL_IGNORED_P (TYPE_NAME (type))))
6706 tree marker = make_node (RECORD_TYPE);
6707 tree name = TYPE_NAME (record);
6708 tree orig_name = TYPE_NAME (type);
6710 if (TREE_CODE (name) == TYPE_DECL)
6711 name = DECL_NAME (name);
6713 if (TREE_CODE (orig_name) == TYPE_DECL)
6714 orig_name = DECL_NAME (orig_name);
6716 TYPE_NAME (marker) = concat_name (name, "XVS");
6717 finish_record_type (marker,
6718 create_field_decl (orig_name,
6719 build_reference_type (type),
6720 marker, NULL_TREE, NULL_TREE,
6724 add_parallel_type (TYPE_STUB_DECL (record), marker);
6726 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6727 TYPE_SIZE_UNIT (marker)
6728 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6729 TYPE_SIZE_UNIT (record), false, false, false,
6730 false, NULL, gnat_entity);
6733 rest_of_record_type_compilation (record);
6735 /* If the size was widened explicitly, maybe give a warning. Take the
6736 original size as the maximum size of the input if there was an
6737 unconstrained record involved and round it up to the specified alignment,
6738 if one was specified. */
6739 if (CONTAINS_PLACEHOLDER_P (orig_size))
6740 orig_size = max_size (orig_size, true);
6743 orig_size = round_up (orig_size, align);
6745 if (Present (gnat_entity)
6747 && TREE_CODE (size) != MAX_EXPR
6748 && TREE_CODE (size) != COND_EXPR
6749 && !operand_equal_p (size, orig_size, 0)
6750 && !(TREE_CODE (size) == INTEGER_CST
6751 && TREE_CODE (orig_size) == INTEGER_CST
6752 && (TREE_OVERFLOW (size)
6753 || TREE_OVERFLOW (orig_size)
6754 || tree_int_cst_lt (size, orig_size))))
6756 Node_Id gnat_error_node = Empty;
6758 if (Is_Packed_Array_Type (gnat_entity))
6759 gnat_entity = Original_Array_Type (gnat_entity);
6761 if ((Ekind (gnat_entity) == E_Component
6762 || Ekind (gnat_entity) == E_Discriminant)
6763 && Present (Component_Clause (gnat_entity)))
6764 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6765 else if (Present (Size_Clause (gnat_entity)))
6766 gnat_error_node = Expression (Size_Clause (gnat_entity));
6768 /* Generate message only for entities that come from source, since
6769 if we have an entity created by expansion, the message will be
6770 generated for some other corresponding source entity. */
6771 if (Comes_From_Source (gnat_entity))
6773 if (Present (gnat_error_node))
6774 post_error_ne_tree ("{^ }bits of & unused?",
6775 gnat_error_node, gnat_entity,
6776 size_diffop (size, orig_size));
6777 else if (is_component_type)
6778 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6779 gnat_entity, gnat_entity,
6780 size_diffop (size, orig_size));
6787 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6788 the value passed against the list of choices. */
6791 choices_to_gnu (tree operand, Node_Id choices)
6795 tree result = boolean_false_node;
6796 tree this_test, low = 0, high = 0, single = 0;
6798 for (choice = First (choices); Present (choice); choice = Next (choice))
6800 switch (Nkind (choice))
6803 low = gnat_to_gnu (Low_Bound (choice));
6804 high = gnat_to_gnu (High_Bound (choice));
6807 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6808 build_binary_op (GE_EXPR, boolean_type_node,
6810 build_binary_op (LE_EXPR, boolean_type_node,
6815 case N_Subtype_Indication:
6816 gnat_temp = Range_Expression (Constraint (choice));
6817 low = gnat_to_gnu (Low_Bound (gnat_temp));
6818 high = gnat_to_gnu (High_Bound (gnat_temp));
6821 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6822 build_binary_op (GE_EXPR, boolean_type_node,
6824 build_binary_op (LE_EXPR, boolean_type_node,
6829 case N_Expanded_Name:
6830 /* This represents either a subtype range, an enumeration
6831 literal, or a constant Ekind says which. If an enumeration
6832 literal or constant, fall through to the next case. */
6833 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6834 && Ekind (Entity (choice)) != E_Constant)
6836 tree type = gnat_to_gnu_type (Entity (choice));
6838 low = TYPE_MIN_VALUE (type);
6839 high = TYPE_MAX_VALUE (type);
6842 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6843 build_binary_op (GE_EXPR, boolean_type_node,
6845 build_binary_op (LE_EXPR, boolean_type_node,
6850 /* ... fall through ... */
6852 case N_Character_Literal:
6853 case N_Integer_Literal:
6854 single = gnat_to_gnu (choice);
6855 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6859 case N_Others_Choice:
6860 this_test = boolean_true_node;
6867 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6874 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6875 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6878 adjust_packed (tree field_type, tree record_type, int packed)
6880 /* If the field contains an item of variable size, we cannot pack it
6881 because we cannot create temporaries of non-fixed size in case
6882 we need to take the address of the field. See addressable_p and
6883 the notes on the addressability issues for further details. */
6884 if (type_has_variable_size (field_type))
6887 /* If the alignment of the record is specified and the field type
6888 is over-aligned, request Storage_Unit alignment for the field. */
6891 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6900 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6901 placed in GNU_RECORD_TYPE.
6903 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6904 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6905 record has a specified alignment.
6907 DEFINITION is true if this field is for a record being defined.
6909 DEBUG_INFO_P is true if we need to write debug information for types
6910 that we may create in the process. */
6913 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6914 bool definition, bool debug_info_p)
6916 const Entity_Id gnat_field_type = Etype (gnat_field);
6917 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6918 tree gnu_field_id = get_entity_name (gnat_field);
6919 tree gnu_field, gnu_size, gnu_pos;
6921 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6922 bool needs_strict_alignment
6924 || Is_Aliased (gnat_field)
6925 || Strict_Alignment (gnat_field_type));
6927 /* If this field requires strict alignment, we cannot pack it because
6928 it would very likely be under-aligned in the record. */
6929 if (needs_strict_alignment)
6932 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6934 /* If a size is specified, use it. Otherwise, if the record type is packed,
6935 use the official RM size. See "Handling of Type'Size Values" in Einfo
6936 for further details. */
6937 if (Known_Esize (gnat_field))
6938 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6939 gnat_field, FIELD_DECL, false, true);
6940 else if (packed == 1)
6941 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6942 gnat_field, FIELD_DECL, false, true);
6944 gnu_size = NULL_TREE;
6946 /* If we have a specified size that is smaller than that of the field's type,
6947 or a position is specified, and the field's type is a record that doesn't
6948 require strict alignment, see if we can get either an integral mode form
6949 of the type or a smaller form. If we can, show a size was specified for
6950 the field if there wasn't one already, so we know to make this a bitfield
6951 and avoid making things wider.
6953 Changing to an integral mode form is useful when the record is packed as
6954 we can then place the field at a non-byte-aligned position and so achieve
6955 tighter packing. This is in addition required if the field shares a byte
6956 with another field and the front-end lets the back-end handle the access
6957 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6959 Changing to a smaller form is required if the specified size is smaller
6960 than that of the field's type and the type contains sub-fields that are
6961 padded, in order to avoid generating accesses to these sub-fields that
6962 are wider than the field.
6964 We avoid the transformation if it is not required or potentially useful,
6965 as it might entail an increase of the field's alignment and have ripple
6966 effects on the outer record type. A typical case is a field known to be
6967 byte-aligned and not to share a byte with another field. */
6968 if (!needs_strict_alignment
6969 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
6970 && !TYPE_FAT_POINTER_P (gnu_field_type)
6971 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6974 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6975 || (Present (Component_Clause (gnat_field))
6976 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6977 % BITS_PER_UNIT == 0
6978 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6980 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6981 if (gnu_packable_type != gnu_field_type)
6983 gnu_field_type = gnu_packable_type;
6985 gnu_size = rm_size (gnu_field_type);
6989 if (Is_Atomic (gnat_field))
6990 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6992 if (Present (Component_Clause (gnat_field)))
6994 Entity_Id gnat_parent
6995 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6997 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6998 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6999 gnat_field, FIELD_DECL, false, true);
7001 /* Ensure the position does not overlap with the parent subtype, if there
7002 is one. This test is omitted if the parent of the tagged type has a
7003 full rep clause since, in this case, component clauses are allowed to
7004 overlay the space allocated for the parent type and the front-end has
7005 checked that there are no overlapping components. */
7006 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
7008 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
7010 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
7011 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
7014 ("offset of& must be beyond parent{, minimum allowed is ^}",
7015 First_Bit (Component_Clause (gnat_field)), gnat_field,
7016 TYPE_SIZE_UNIT (gnu_parent));
7020 /* If this field needs strict alignment, ensure the record is
7021 sufficiently aligned and that that position and size are
7022 consistent with the alignment. */
7023 if (needs_strict_alignment)
7025 TYPE_ALIGN (gnu_record_type)
7026 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
7029 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
7031 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
7033 ("atomic field& must be natural size of type{ (^)}",
7034 Last_Bit (Component_Clause (gnat_field)), gnat_field,
7035 TYPE_SIZE (gnu_field_type));
7037 else if (Is_Aliased (gnat_field))
7039 ("size of aliased field& must be ^ bits",
7040 Last_Bit (Component_Clause (gnat_field)), gnat_field,
7041 TYPE_SIZE (gnu_field_type));
7043 else if (Strict_Alignment (gnat_field_type))
7045 ("size of & with aliased or tagged components not ^ bits",
7046 Last_Bit (Component_Clause (gnat_field)), gnat_field,
7047 TYPE_SIZE (gnu_field_type));
7049 gnu_size = NULL_TREE;
7052 if (!integer_zerop (size_binop
7053 (TRUNC_MOD_EXPR, gnu_pos,
7054 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
7058 ("position of volatile field& must be multiple of ^ bits",
7059 First_Bit (Component_Clause (gnat_field)), gnat_field,
7060 TYPE_ALIGN (gnu_field_type));
7062 else if (Is_Aliased (gnat_field))
7064 ("position of aliased field& must be multiple of ^ bits",
7065 First_Bit (Component_Clause (gnat_field)), gnat_field,
7066 TYPE_ALIGN (gnu_field_type));
7068 else if (Strict_Alignment (gnat_field_type))
7070 ("position of & is not compatible with alignment required "
7071 "by its components",
7072 First_Bit (Component_Clause (gnat_field)), gnat_field);
7077 gnu_pos = NULL_TREE;
7082 /* If the record has rep clauses and this is the tag field, make a rep
7083 clause for it as well. */
7084 else if (Has_Specified_Layout (Scope (gnat_field))
7085 && Chars (gnat_field) == Name_uTag)
7087 gnu_pos = bitsize_zero_node;
7088 gnu_size = TYPE_SIZE (gnu_field_type);
7093 gnu_pos = NULL_TREE;
7095 /* If we are packing the record and the field is BLKmode, round the
7096 size up to a byte boundary. */
7097 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
7098 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
7101 /* We need to make the size the maximum for the type if it is
7102 self-referential and an unconstrained type. In that case, we can't
7103 pack the field since we can't make a copy to align it. */
7104 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
7106 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
7107 && !Is_Constrained (Underlying_Type (gnat_field_type)))
7109 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
7113 /* If a size is specified, adjust the field's type to it. */
7116 tree orig_field_type;
7118 /* If the field's type is justified modular, we would need to remove
7119 the wrapper to (better) meet the layout requirements. However we
7120 can do so only if the field is not aliased to preserve the unique
7121 layout and if the prescribed size is not greater than that of the
7122 packed array to preserve the justification. */
7123 if (!needs_strict_alignment
7124 && TREE_CODE (gnu_field_type) == RECORD_TYPE
7125 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
7126 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
7128 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7131 = make_type_from_size (gnu_field_type, gnu_size,
7132 Has_Biased_Representation (gnat_field));
7134 orig_field_type = gnu_field_type;
7135 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
7136 false, false, definition, true);
7138 /* If a padding record was made, declare it now since it will never be
7139 declared otherwise. This is necessary to ensure that its subtrees
7140 are properly marked. */
7141 if (gnu_field_type != orig_field_type
7142 && !DECL_P (TYPE_NAME (gnu_field_type)))
7143 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
7144 true, debug_info_p, gnat_field);
7147 /* Otherwise (or if there was an error), don't specify a position. */
7149 gnu_pos = NULL_TREE;
7151 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
7152 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
7154 /* Now create the decl for the field. */
7156 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
7157 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
7158 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
7159 DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field);
7160 TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
7162 if (Ekind (gnat_field) == E_Discriminant)
7163 DECL_DISCRIMINANT_NUMBER (gnu_field)
7164 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7169 /* Return true if TYPE is a type with variable size or a padding type with a
7170 field of variable size or a record that has a field with such a type. */
7173 type_has_variable_size (tree type)
7177 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7180 if (TYPE_IS_PADDING_P (type)
7181 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7184 if (!RECORD_OR_UNION_TYPE_P (type))
7187 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7188 if (type_has_variable_size (TREE_TYPE (field)))
7194 /* Return true if FIELD is an artificial field. */
7197 field_is_artificial (tree field)
7199 /* These fields are generated by the front-end proper. */
7200 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
7203 /* These fields are generated by gigi. */
7204 if (DECL_INTERNAL_P (field))
7210 /* Return true if FIELD is a non-artificial aliased field. */
7213 field_is_aliased (tree field)
7215 if (field_is_artificial (field))
7218 return DECL_ALIASED_P (field);
7221 /* Return true if FIELD is a non-artificial field with self-referential
7225 field_has_self_size (tree field)
7227 if (field_is_artificial (field))
7230 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7233 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
7236 /* Return true if FIELD is a non-artificial field with variable size. */
7239 field_has_variable_size (tree field)
7241 if (field_is_artificial (field))
7244 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7247 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
7250 /* qsort comparer for the bit positions of two record components. */
7253 compare_field_bitpos (const PTR rt1, const PTR rt2)
7255 const_tree const field1 = * (const_tree const *) rt1;
7256 const_tree const field2 = * (const_tree const *) rt2;
7258 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7260 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7263 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
7264 the result as the field list of GNU_RECORD_TYPE and finish it up. When
7265 called from gnat_to_gnu_entity during the processing of a record type
7266 definition, the GCC node for the parent, if any, will be the single field
7267 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7268 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7269 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7271 PACKED is 1 if this is for a packed record, -1 if this is for a record
7272 with Component_Alignment of Storage_Unit, -2 if this is for a record
7273 with a specified alignment.
7275 DEFINITION is true if we are defining this record type.
7277 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7278 out the record. This means the alignment only serves to force fields to
7279 be bitfields, but not to require the record to be that aligned. This is
7282 ALL_REP is true if a rep clause is present for all the fields.
7284 UNCHECKED_UNION is true if we are building this type for a record with a
7285 Pragma Unchecked_Union.
7287 ARTIFICIAL is true if this is a type that was generated by the compiler.
7289 DEBUG_INFO is true if we need to write debug information about the type.
7291 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7292 mean that its contents may be unused as well, only the container itself.
7294 REORDER is true if we are permitted to reorder components of this type.
7296 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
7297 the outer record type down to this variant level. It is nonzero only if
7298 all the fields down to this level have a rep clause and ALL_REP is false.
7300 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7301 with a rep clause is to be added; in this case, that is all that should
7302 be done with such fields. */
7305 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
7306 tree gnu_field_list, int packed, bool definition,
7307 bool cancel_alignment, bool all_rep,
7308 bool unchecked_union, bool artificial,
7309 bool debug_info, bool maybe_unused, bool reorder,
7310 tree first_free_pos, tree *p_gnu_rep_list)
7312 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7313 bool layout_with_rep = false;
7314 bool has_self_field = false;
7315 bool has_aliased_after_self_field = false;
7316 Node_Id component_decl, variant_part;
7317 tree gnu_field, gnu_next, gnu_last;
7318 tree gnu_rep_part = NULL_TREE;
7319 tree gnu_variant_part = NULL_TREE;
7320 tree gnu_rep_list = NULL_TREE;
7321 tree gnu_var_list = NULL_TREE;
7322 tree gnu_self_list = NULL_TREE;
7324 /* For each component referenced in a component declaration create a GCC
7325 field and add it to the list, skipping pragmas in the GNAT list. */
7326 gnu_last = tree_last (gnu_field_list);
7327 if (Present (Component_Items (gnat_component_list)))
7329 = First_Non_Pragma (Component_Items (gnat_component_list));
7330 Present (component_decl);
7331 component_decl = Next_Non_Pragma (component_decl))
7333 Entity_Id gnat_field = Defining_Entity (component_decl);
7334 Name_Id gnat_name = Chars (gnat_field);
7336 /* If present, the _Parent field must have been created as the single
7337 field of the record type. Put it before any other fields. */
7338 if (gnat_name == Name_uParent)
7340 gnu_field = TYPE_FIELDS (gnu_record_type);
7341 gnu_field_list = chainon (gnu_field_list, gnu_field);
7345 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7346 definition, debug_info);
7348 /* If this is the _Tag field, put it before any other fields. */
7349 if (gnat_name == Name_uTag)
7350 gnu_field_list = chainon (gnu_field_list, gnu_field);
7352 /* If this is the _Controller field, put it before the other
7353 fields except for the _Tag or _Parent field. */
7354 else if (gnat_name == Name_uController && gnu_last)
7356 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7357 DECL_CHAIN (gnu_last) = gnu_field;
7360 /* If this is a regular field, put it after the other fields. */
7363 DECL_CHAIN (gnu_field) = gnu_field_list;
7364 gnu_field_list = gnu_field;
7366 gnu_last = gnu_field;
7368 /* And record information for the final layout. */
7369 if (field_has_self_size (gnu_field))
7370 has_self_field = true;
7371 else if (has_self_field && field_is_aliased (gnu_field))
7372 has_aliased_after_self_field = true;
7376 save_gnu_tree (gnat_field, gnu_field, false);
7379 /* At the end of the component list there may be a variant part. */
7380 variant_part = Variant_Part (gnat_component_list);
7382 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7383 mutually exclusive and should go in the same memory. To do this we need
7384 to treat each variant as a record whose elements are created from the
7385 component list for the variant. So here we create the records from the
7386 lists for the variants and put them all into the QUAL_UNION_TYPE.
7387 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7388 use GNU_RECORD_TYPE if there are no fields so far. */
7389 if (Present (variant_part))
7391 Node_Id gnat_discr = Name (variant_part), variant;
7392 tree gnu_discr = gnat_to_gnu (gnat_discr);
7393 tree gnu_name = TYPE_NAME (gnu_record_type);
7395 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7397 tree gnu_union_type, gnu_union_name;
7398 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
7400 if (TREE_CODE (gnu_name) == TYPE_DECL)
7401 gnu_name = DECL_NAME (gnu_name);
7404 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7406 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7407 are all in the variant part, to match the layout of C unions. There
7408 is an associated check below. */
7409 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
7410 gnu_union_type = gnu_record_type;
7414 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7416 TYPE_NAME (gnu_union_type) = gnu_union_name;
7417 TYPE_ALIGN (gnu_union_type) = 0;
7418 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7421 /* If all the fields down to this level have a rep clause, find out
7422 whether all the fields at this level also have one. If so, then
7423 compute the new first free position to be passed downward. */
7424 this_first_free_pos = first_free_pos;
7425 if (this_first_free_pos)
7427 for (gnu_field = gnu_field_list;
7429 gnu_field = DECL_CHAIN (gnu_field))
7430 if (DECL_FIELD_OFFSET (gnu_field))
7432 tree pos = bit_position (gnu_field);
7433 if (!tree_int_cst_lt (pos, this_first_free_pos))
7435 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
7439 this_first_free_pos = NULL_TREE;
7444 for (variant = First_Non_Pragma (Variants (variant_part));
7446 variant = Next_Non_Pragma (variant))
7448 tree gnu_variant_type = make_node (RECORD_TYPE);
7449 tree gnu_inner_name;
7452 Get_Variant_Encoding (variant);
7453 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7454 TYPE_NAME (gnu_variant_type)
7455 = concat_name (gnu_union_name,
7456 IDENTIFIER_POINTER (gnu_inner_name));
7458 /* Set the alignment of the inner type in case we need to make
7459 inner objects into bitfields, but then clear it out so the
7460 record actually gets only the alignment required. */
7461 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
7462 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7464 /* Similarly, if the outer record has a size specified and all
7465 the fields have a rep clause, we can propagate the size. */
7466 if (all_rep_and_size)
7468 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7469 TYPE_SIZE_UNIT (gnu_variant_type)
7470 = TYPE_SIZE_UNIT (gnu_record_type);
7473 /* Add the fields into the record type for the variant. Note that
7474 we aren't sure to really use it at this point, see below. */
7475 components_to_record (gnu_variant_type, Component_List (variant),
7476 NULL_TREE, packed, definition,
7477 !all_rep_and_size, all_rep, unchecked_union,
7478 true, debug_info, true, reorder,
7479 this_first_free_pos,
7480 all_rep || this_first_free_pos
7481 ? NULL : &gnu_rep_list);
7483 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7484 Set_Present_Expr (variant, annotate_value (gnu_qual));
7486 /* If this is an Unchecked_Union whose fields are all in the variant
7487 part and we have a single field with no representation clause or
7488 placed at offset zero, use the field directly to match the layout
7490 if (TREE_CODE (gnu_record_type) == UNION_TYPE
7491 && (gnu_field = TYPE_FIELDS (gnu_variant_type)) != NULL_TREE
7492 && !DECL_CHAIN (gnu_field)
7493 && (!DECL_FIELD_OFFSET (gnu_field)
7494 || integer_zerop (bit_position (gnu_field))))
7495 DECL_CONTEXT (gnu_field) = gnu_union_type;
7498 /* Deal with packedness like in gnat_to_gnu_field. */
7500 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7502 /* Finalize the record type now. We used to throw away
7503 empty records but we no longer do that because we need
7504 them to generate complete debug info for the variant;
7505 otherwise, the union type definition will be lacking
7506 the fields associated with these empty variants. */
7507 rest_of_record_type_compilation (gnu_variant_type);
7508 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7509 NULL, true, debug_info, gnat_component_list);
7512 = create_field_decl (gnu_inner_name, gnu_variant_type,
7515 ? TYPE_SIZE (gnu_variant_type) : 0,
7517 ? bitsize_zero_node : 0,
7520 DECL_INTERNAL_P (gnu_field) = 1;
7522 if (!unchecked_union)
7523 DECL_QUALIFIER (gnu_field) = gnu_qual;
7526 DECL_CHAIN (gnu_field) = gnu_variant_list;
7527 gnu_variant_list = gnu_field;
7530 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7531 if (gnu_variant_list)
7533 int union_field_packed;
7535 if (all_rep_and_size)
7537 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7538 TYPE_SIZE_UNIT (gnu_union_type)
7539 = TYPE_SIZE_UNIT (gnu_record_type);
7542 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7543 all_rep_and_size ? 1 : 0, debug_info);
7545 /* If GNU_UNION_TYPE is our record type, it means we must have an
7546 Unchecked_Union with no fields. Verify that and, if so, just
7548 if (gnu_union_type == gnu_record_type)
7550 gcc_assert (unchecked_union
7556 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
7557 NULL, true, debug_info, gnat_component_list);
7559 /* Deal with packedness like in gnat_to_gnu_field. */
7561 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7564 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7565 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
7566 all_rep || this_first_free_pos
7567 ? bitsize_zero_node : 0,
7568 union_field_packed, 0);
7570 DECL_INTERNAL_P (gnu_variant_part) = 1;
7574 /* From now on, a zero FIRST_FREE_POS is totally useless. */
7575 if (first_free_pos && integer_zerop (first_free_pos))
7576 first_free_pos = NULL_TREE;
7578 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7579 permitted to reorder components, self-referential sizes or variable sizes.
7580 If they do, pull them out and put them onto the appropriate list. We have
7581 to do this in a separate pass since we want to handle the discriminants
7582 but can't play with them until we've used them in debugging data above.
7584 ??? If we reorder them, debugging information will be wrong but there is
7585 nothing that can be done about this at the moment. */
7586 gnu_last = NULL_TREE;
7588 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7591 DECL_CHAIN (gnu_last) = gnu_next; \
7593 gnu_field_list = gnu_next; \
7595 DECL_CHAIN (gnu_field) = (LIST); \
7596 (LIST) = gnu_field; \
7599 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7601 gnu_next = DECL_CHAIN (gnu_field);
7603 if (DECL_FIELD_OFFSET (gnu_field))
7605 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7609 if ((reorder || has_aliased_after_self_field)
7610 && field_has_self_size (gnu_field))
7612 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7616 if (reorder && field_has_variable_size (gnu_field))
7618 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7622 gnu_last = gnu_field;
7625 #undef MOVE_FROM_FIELD_LIST_TO
7627 /* If permitted, we reorder the fields as follows:
7629 1) all fixed length fields,
7630 2) all fields whose length doesn't depend on discriminants,
7631 3) all fields whose length depends on discriminants,
7632 4) the variant part,
7634 within the record and within each variant recursively. */
7637 = chainon (nreverse (gnu_self_list),
7638 chainon (nreverse (gnu_var_list), gnu_field_list));
7640 /* Otherwise, if there is an aliased field placed after a field whose length
7641 depends on discriminants, we put all the fields of the latter sort, last.
7642 We need to do this in case an object of this record type is mutable. */
7643 else if (has_aliased_after_self_field)
7644 gnu_field_list = chainon (nreverse (gnu_self_list), gnu_field_list);
7646 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7647 in our REP list to the previous level because this level needs them in
7648 order to do a correct layout, i.e. avoid having overlapping fields. */
7649 if (p_gnu_rep_list && gnu_rep_list)
7650 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7652 /* Otherwise, sort the fields by bit position and put them into their own
7653 record, before the others, if we also have fields without rep clause. */
7654 else if (gnu_rep_list)
7657 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7658 int i, len = list_length (gnu_rep_list);
7659 tree *gnu_arr = XALLOCAVEC (tree, len);
7661 for (gnu_field = gnu_rep_list, i = 0;
7663 gnu_field = DECL_CHAIN (gnu_field), i++)
7664 gnu_arr[i] = gnu_field;
7666 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7668 /* Put the fields in the list in order of increasing position, which
7669 means we start from the end. */
7670 gnu_rep_list = NULL_TREE;
7671 for (i = len - 1; i >= 0; i--)
7673 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7674 gnu_rep_list = gnu_arr[i];
7675 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7680 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7682 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
7683 without rep clause are laid out starting from this position.
7684 Therefore, we force it as a minimal size on the REP part. */
7686 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
7690 layout_with_rep = true;
7691 gnu_field_list = nreverse (gnu_rep_list);
7695 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields without
7696 rep clause are laid out starting from this position. Therefore, if we
7697 have not already done so, we create a fake REP part with this size. */
7698 if (first_free_pos && !layout_with_rep && !gnu_rep_part)
7700 tree gnu_rep_type = make_node (RECORD_TYPE);
7701 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
7703 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
7706 /* Now chain the REP part at the end of the reversed field list. */
7708 gnu_field_list = chainon (gnu_field_list, gnu_rep_part);
7710 /* And the variant part at the beginning. */
7711 if (gnu_variant_part)
7713 DECL_CHAIN (gnu_variant_part) = gnu_field_list;
7714 gnu_field_list = gnu_variant_part;
7717 if (cancel_alignment)
7718 TYPE_ALIGN (gnu_record_type) = 0;
7720 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7721 layout_with_rep ? 1 : 0, false);
7722 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
7723 if (debug_info && !maybe_unused)
7724 rest_of_record_type_compilation (gnu_record_type);
7727 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7728 placed into an Esize, Component_Bit_Offset, or Component_Size value
7729 in the GNAT tree. */
7732 annotate_value (tree gnu_size)
7735 Node_Ref_Or_Val ops[3], ret;
7736 struct tree_int_map in;
7739 /* See if we've already saved the value for this node. */
7740 if (EXPR_P (gnu_size))
7742 struct tree_int_map *e;
7744 if (!annotate_value_cache)
7745 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7746 tree_int_map_eq, 0);
7747 in.base.from = gnu_size;
7748 e = (struct tree_int_map *)
7749 htab_find (annotate_value_cache, &in);
7752 return (Node_Ref_Or_Val) e->to;
7755 in.base.from = NULL_TREE;
7757 /* If we do not return inside this switch, TCODE will be set to the
7758 code to use for a Create_Node operand and LEN (set above) will be
7759 the number of recursive calls for us to make. */
7761 switch (TREE_CODE (gnu_size))
7764 if (TREE_OVERFLOW (gnu_size))
7767 /* This may come from a conversion from some smaller type, so ensure
7768 this is in bitsizetype. */
7769 gnu_size = convert (bitsizetype, gnu_size);
7771 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7772 appear in expressions containing aligning patterns. Note that, since
7773 sizetype is sign-extended but nonetheless unsigned, we don't directly
7774 use tree_int_cst_sgn. */
7775 if (TREE_INT_CST_HIGH (gnu_size) < 0)
7777 tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size);
7778 return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size));
7781 return UI_From_gnu (gnu_size);
7784 /* The only case we handle here is a simple discriminant reference. */
7785 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7786 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7787 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7788 return Create_Node (Discrim_Val,
7789 annotate_value (DECL_DISCRIMINANT_NUMBER
7790 (TREE_OPERAND (gnu_size, 1))),
7795 CASE_CONVERT: case NON_LVALUE_EXPR:
7796 return annotate_value (TREE_OPERAND (gnu_size, 0));
7798 /* Now just list the operations we handle. */
7799 case COND_EXPR: tcode = Cond_Expr; break;
7800 case PLUS_EXPR: tcode = Plus_Expr; break;
7801 case MINUS_EXPR: tcode = Minus_Expr; break;
7802 case MULT_EXPR: tcode = Mult_Expr; break;
7803 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7804 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7805 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7806 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7807 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7808 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7809 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7810 case NEGATE_EXPR: tcode = Negate_Expr; break;
7811 case MIN_EXPR: tcode = Min_Expr; break;
7812 case MAX_EXPR: tcode = Max_Expr; break;
7813 case ABS_EXPR: tcode = Abs_Expr; break;
7814 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7815 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7816 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7817 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7818 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7819 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7820 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7821 case LT_EXPR: tcode = Lt_Expr; break;
7822 case LE_EXPR: tcode = Le_Expr; break;
7823 case GT_EXPR: tcode = Gt_Expr; break;
7824 case GE_EXPR: tcode = Ge_Expr; break;
7825 case EQ_EXPR: tcode = Eq_Expr; break;
7826 case NE_EXPR: tcode = Ne_Expr; break;
7830 tree t = maybe_inline_call_in_expr (gnu_size);
7832 return annotate_value (t);
7835 /* Fall through... */
7841 /* Now get each of the operands that's relevant for this code. If any
7842 cannot be expressed as a repinfo node, say we can't. */
7843 for (i = 0; i < 3; i++)
7846 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7848 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7849 if (ops[i] == No_Uint)
7853 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7855 /* Save the result in the cache. */
7858 struct tree_int_map **h;
7859 /* We can't assume the hash table data hasn't moved since the
7860 initial look up, so we have to search again. Allocating and
7861 inserting an entry at that point would be an alternative, but
7862 then we'd better discard the entry if we decided not to cache
7864 h = (struct tree_int_map **)
7865 htab_find_slot (annotate_value_cache, &in, INSERT);
7867 *h = ggc_alloc_tree_int_map ();
7868 (*h)->base.from = gnu_size;
7875 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7876 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7877 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7878 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7879 true if the object is used by double reference. */
7882 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref,
7888 gnu_type = TREE_TYPE (gnu_type);
7890 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7891 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7893 gnu_type = TREE_TYPE (gnu_type);
7896 if (Unknown_Esize (gnat_entity))
7898 if (TREE_CODE (gnu_type) == RECORD_TYPE
7899 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7900 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7902 size = TYPE_SIZE (gnu_type);
7905 Set_Esize (gnat_entity, annotate_value (size));
7908 if (Unknown_Alignment (gnat_entity))
7909 Set_Alignment (gnat_entity,
7910 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7913 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7914 Return NULL_TREE if there is no such element in the list. */
7917 purpose_member_field (const_tree elem, tree list)
7921 tree field = TREE_PURPOSE (list);
7922 if (SAME_FIELD_P (field, elem))
7924 list = TREE_CHAIN (list);
7929 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7930 set Component_Bit_Offset and Esize of the components to the position and
7931 size used by Gigi. */
7934 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7936 Entity_Id gnat_field;
7939 /* We operate by first making a list of all fields and their position (we
7940 can get the size easily) and then update all the sizes in the tree. */
7942 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7943 BIGGEST_ALIGNMENT, NULL_TREE);
7945 for (gnat_field = First_Entity (gnat_entity);
7946 Present (gnat_field);
7947 gnat_field = Next_Entity (gnat_field))
7948 if (Ekind (gnat_field) == E_Component
7949 || (Ekind (gnat_field) == E_Discriminant
7950 && !Is_Unchecked_Union (Scope (gnat_field))))
7952 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7958 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7960 /* In this mode the tag and parent components are not
7961 generated, so we add the appropriate offset to each
7962 component. For a component appearing in the current
7963 extension, the offset is the size of the parent. */
7964 if (Is_Derived_Type (gnat_entity)
7965 && Original_Record_Component (gnat_field) == gnat_field)
7967 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7970 parent_offset = bitsize_int (POINTER_SIZE);
7973 parent_offset = bitsize_zero_node;
7975 Set_Component_Bit_Offset
7978 (size_binop (PLUS_EXPR,
7979 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7980 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7983 Set_Esize (gnat_field,
7984 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7986 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7988 /* If there is no entry, this is an inherited component whose
7989 position is the same as in the parent type. */
7990 Set_Component_Bit_Offset
7992 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7994 Set_Esize (gnat_field,
7995 Esize (Original_Record_Component (gnat_field)));
8000 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
8001 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
8002 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
8003 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
8004 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
8005 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
8006 pre-existing list to be chained to the newly created entries. */
8009 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
8010 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
8014 for (gnu_field = TYPE_FIELDS (gnu_type);
8016 gnu_field = DECL_CHAIN (gnu_field))
8018 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
8019 DECL_FIELD_BIT_OFFSET (gnu_field));
8020 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
8021 DECL_FIELD_OFFSET (gnu_field));
8022 unsigned int our_offset_align
8023 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
8024 tree v = make_tree_vec (3);
8026 TREE_VEC_ELT (v, 0) = gnu_our_offset;
8027 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
8028 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
8029 gnu_list = tree_cons (gnu_field, v, gnu_list);
8031 /* Recurse on internal fields, flattening the nested fields except for
8032 those in the variant part, if requested. */
8033 if (DECL_INTERNAL_P (gnu_field))
8035 tree gnu_field_type = TREE_TYPE (gnu_field);
8036 if (do_not_flatten_variant
8037 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
8039 = build_position_list (gnu_field_type, do_not_flatten_variant,
8040 size_zero_node, bitsize_zero_node,
8041 BIGGEST_ALIGNMENT, gnu_list);
8044 = build_position_list (gnu_field_type, do_not_flatten_variant,
8045 gnu_our_offset, gnu_our_bitpos,
8046 our_offset_align, gnu_list);
8053 /* Return a VEC describing the substitutions needed to reflect the
8054 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
8055 be in any order. The values in an element of the VEC are in the form
8056 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
8057 a definition of GNAT_SUBTYPE. */
8059 static VEC(subst_pair,heap) *
8060 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
8062 VEC(subst_pair,heap) *gnu_vec = NULL;
8063 Entity_Id gnat_discrim;
8066 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
8067 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
8068 Present (gnat_discrim);
8069 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
8070 gnat_value = Next_Elmt (gnat_value))
8071 /* Ignore access discriminants. */
8072 if (!Is_Access_Type (Etype (Node (gnat_value))))
8074 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
8075 tree replacement = convert (TREE_TYPE (gnu_field),
8076 elaborate_expression
8077 (Node (gnat_value), gnat_subtype,
8078 get_entity_name (gnat_discrim),
8079 definition, true, false));
8080 subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL);
8081 s->discriminant = gnu_field;
8082 s->replacement = replacement;
8088 /* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
8089 variants of QUAL_UNION_TYPE that are still relevant after applying
8090 the substitutions described in SUBST_LIST. VARIANT_LIST is a
8091 pre-existing VEC onto which newly created entries should be
8094 static VEC(variant_desc,heap) *
8095 build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list,
8096 VEC(variant_desc,heap) *variant_list)
8100 for (gnu_field = TYPE_FIELDS (qual_union_type);
8102 gnu_field = DECL_CHAIN (gnu_field))
8104 tree qual = DECL_QUALIFIER (gnu_field);
8108 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8109 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
8111 /* If the new qualifier is not unconditionally false, its variant may
8112 still be accessed. */
8113 if (!integer_zerop (qual))
8116 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
8118 v = VEC_safe_push (variant_desc, heap, variant_list, NULL);
8119 v->type = variant_type;
8120 v->field = gnu_field;
8122 v->record = NULL_TREE;
8124 /* Recurse on the variant subpart of the variant, if any. */
8125 variant_subpart = get_variant_part (variant_type);
8126 if (variant_subpart)
8127 variant_list = build_variant_list (TREE_TYPE (variant_subpart),
8128 subst_list, variant_list);
8130 /* If the new qualifier is unconditionally true, the subsequent
8131 variants cannot be accessed. */
8132 if (integer_onep (qual))
8137 return variant_list;
8140 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
8141 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
8142 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
8143 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
8144 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
8145 true if we are being called to process the Component_Size of GNAT_OBJECT;
8146 this is used only for error messages. ZERO_OK is true if a size of zero
8147 is permitted; if ZERO_OK is false, it means that a size of zero should be
8148 treated as an unspecified size. */
8151 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
8152 enum tree_code kind, bool component_p, bool zero_ok)
8154 Node_Id gnat_error_node;
8155 tree type_size, size;
8157 /* Return 0 if no size was specified. */
8158 if (uint_size == No_Uint)
8161 /* Ignore a negative size since that corresponds to our back-annotation. */
8162 if (UI_Lt (uint_size, Uint_0))
8165 /* Find the node to use for error messages. */
8166 if ((Ekind (gnat_object) == E_Component
8167 || Ekind (gnat_object) == E_Discriminant)
8168 && Present (Component_Clause (gnat_object)))
8169 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
8170 else if (Present (Size_Clause (gnat_object)))
8171 gnat_error_node = Expression (Size_Clause (gnat_object));
8173 gnat_error_node = gnat_object;
8175 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8176 but cannot be represented in bitsizetype. */
8177 size = UI_To_gnu (uint_size, bitsizetype);
8178 if (TREE_OVERFLOW (size))
8181 post_error_ne ("component size for& is too large", gnat_error_node,
8184 post_error_ne ("size for& is too large", gnat_error_node,
8189 /* Ignore a zero size if it is not permitted. */
8190 if (!zero_ok && integer_zerop (size))
8193 /* The size of objects is always a multiple of a byte. */
8194 if (kind == VAR_DECL
8195 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
8198 post_error_ne ("component size for& is not a multiple of Storage_Unit",
8199 gnat_error_node, gnat_object);
8201 post_error_ne ("size for& is not a multiple of Storage_Unit",
8202 gnat_error_node, gnat_object);
8206 /* If this is an integral type or a packed array type, the front-end has
8207 already verified the size, so we need not do it here (which would mean
8208 checking against the bounds). However, if this is an aliased object,
8209 it may not be smaller than the type of the object. */
8210 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
8211 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
8214 /* If the object is a record that contains a template, add the size of the
8215 template to the specified size. */
8216 if (TREE_CODE (gnu_type) == RECORD_TYPE
8217 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8218 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
8220 if (kind == VAR_DECL
8221 /* If a type needs strict alignment, a component of this type in
8222 a packed record cannot be packed and thus uses the type size. */
8223 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
8224 type_size = TYPE_SIZE (gnu_type);
8226 type_size = rm_size (gnu_type);
8228 /* Modify the size of a discriminated type to be the maximum size. */
8229 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
8230 type_size = max_size (type_size, true);
8232 /* If this is an access type or a fat pointer, the minimum size is that given
8233 by the smallest integral mode that's valid for pointers. */
8234 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
8236 enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
8237 while (!targetm.valid_pointer_mode (p_mode))
8238 p_mode = GET_MODE_WIDER_MODE (p_mode);
8239 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
8242 /* Issue an error either if the default size of the object isn't a constant
8243 or if the new size is smaller than it. */
8244 if (TREE_CODE (type_size) != INTEGER_CST
8245 || TREE_OVERFLOW (type_size)
8246 || tree_int_cst_lt (size, type_size))
8250 ("component size for& too small{, minimum allowed is ^}",
8251 gnat_error_node, gnat_object, type_size);
8254 ("size for& too small{, minimum allowed is ^}",
8255 gnat_error_node, gnat_object, type_size);
8262 /* Similarly, but both validate and process a value of RM size. This routine
8263 is only called for types. */
8266 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
8268 Node_Id gnat_attr_node;
8269 tree old_size, size;
8271 /* Do nothing if no size was specified. */
8272 if (uint_size == No_Uint)
8275 /* Ignore a negative size since that corresponds to our back-annotation. */
8276 if (UI_Lt (uint_size, Uint_0))
8279 /* Only issue an error if a Value_Size clause was explicitly given.
8280 Otherwise, we'd be duplicating an error on the Size clause. */
8282 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
8284 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8285 but cannot be represented in bitsizetype. */
8286 size = UI_To_gnu (uint_size, bitsizetype);
8287 if (TREE_OVERFLOW (size))
8289 if (Present (gnat_attr_node))
8290 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8295 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8296 exists, or this is an integer type, in which case the front-end will
8297 have always set it. */
8298 if (No (gnat_attr_node)
8299 && integer_zerop (size)
8300 && !Has_Size_Clause (gnat_entity)
8301 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8304 old_size = rm_size (gnu_type);
8306 /* If the old size is self-referential, get the maximum size. */
8307 if (CONTAINS_PLACEHOLDER_P (old_size))
8308 old_size = max_size (old_size, true);
8310 /* Issue an error either if the old size of the object isn't a constant or
8311 if the new size is smaller than it. The front-end has already verified
8312 this for scalar and packed array types. */
8313 if (TREE_CODE (old_size) != INTEGER_CST
8314 || TREE_OVERFLOW (old_size)
8315 || (AGGREGATE_TYPE_P (gnu_type)
8316 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8317 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8318 && !(TYPE_IS_PADDING_P (gnu_type)
8319 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8320 && TYPE_PACKED_ARRAY_TYPE_P
8321 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8322 && tree_int_cst_lt (size, old_size)))
8324 if (Present (gnat_attr_node))
8326 ("Value_Size for& too small{, minimum allowed is ^}",
8327 gnat_attr_node, gnat_entity, old_size);
8331 /* Otherwise, set the RM size proper for integral types... */
8332 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8333 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8334 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8335 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8336 SET_TYPE_RM_SIZE (gnu_type, size);
8338 /* ...or the Ada size for record and union types. */
8339 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
8340 && !TYPE_FAT_POINTER_P (gnu_type))
8341 SET_TYPE_ADA_SIZE (gnu_type, size);
8344 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
8345 If TYPE is the best type, return it. Otherwise, make a new type. We
8346 only support new integral and pointer types. FOR_BIASED is true if
8347 we are making a biased type. */
8350 make_type_from_size (tree type, tree size_tree, bool for_biased)
8352 unsigned HOST_WIDE_INT size;
8356 /* If size indicates an error, just return TYPE to avoid propagating
8357 the error. Likewise if it's too large to represent. */
8358 if (!size_tree || !host_integerp (size_tree, 1))
8361 size = tree_low_cst (size_tree, 1);
8363 switch (TREE_CODE (type))
8368 biased_p = (TREE_CODE (type) == INTEGER_TYPE
8369 && TYPE_BIASED_REPRESENTATION_P (type));
8371 /* Integer types with precision 0 are forbidden. */
8375 /* Only do something if the type is not a packed array type and
8376 doesn't already have the proper size. */
8377 if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
8378 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
8381 biased_p |= for_biased;
8382 if (size > LONG_LONG_TYPE_SIZE)
8383 size = LONG_LONG_TYPE_SIZE;
8385 if (TYPE_UNSIGNED (type) || biased_p)
8386 new_type = make_unsigned_type (size);
8388 new_type = make_signed_type (size);
8389 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
8390 SET_TYPE_RM_MIN_VALUE (new_type,
8391 convert (TREE_TYPE (new_type),
8392 TYPE_MIN_VALUE (type)));
8393 SET_TYPE_RM_MAX_VALUE (new_type,
8394 convert (TREE_TYPE (new_type),
8395 TYPE_MAX_VALUE (type)));
8396 /* Copy the name to show that it's essentially the same type and
8397 not a subrange type. */
8398 TYPE_NAME (new_type) = TYPE_NAME (type);
8399 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
8400 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
8404 /* Do something if this is a fat pointer, in which case we
8405 may need to return the thin pointer. */
8406 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
8408 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
8409 if (!targetm.valid_pointer_mode (p_mode))
8412 build_pointer_type_for_mode
8413 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
8419 /* Only do something if this is a thin pointer, in which case we
8420 may need to return the fat pointer. */
8421 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
8423 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
8433 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8434 a type or object whose present alignment is ALIGN. If this alignment is
8435 valid, return it. Otherwise, give an error and return ALIGN. */
8438 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8440 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8441 unsigned int new_align;
8442 Node_Id gnat_error_node;
8444 /* Don't worry about checking alignment if alignment was not specified
8445 by the source program and we already posted an error for this entity. */
8446 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8449 /* Post the error on the alignment clause if any. Note, for the implicit
8450 base type of an array type, the alignment clause is on the first
8452 if (Present (Alignment_Clause (gnat_entity)))
8453 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8455 else if (Is_Itype (gnat_entity)
8456 && Is_Array_Type (gnat_entity)
8457 && Etype (gnat_entity) == gnat_entity
8458 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8460 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8463 gnat_error_node = gnat_entity;
8465 /* Within GCC, an alignment is an integer, so we must make sure a value is
8466 specified that fits in that range. Also, there is an upper bound to
8467 alignments we can support/allow. */
8468 if (!UI_Is_In_Int_Range (alignment)
8469 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8470 post_error_ne_num ("largest supported alignment for& is ^",
8471 gnat_error_node, gnat_entity, max_allowed_alignment);
8472 else if (!(Present (Alignment_Clause (gnat_entity))
8473 && From_At_Mod (Alignment_Clause (gnat_entity)))
8474 && new_align * BITS_PER_UNIT < align)
8476 unsigned int double_align;
8477 bool is_capped_double, align_clause;
8479 /* If the default alignment of "double" or larger scalar types is
8480 specifically capped and the new alignment is above the cap, do
8481 not post an error and change the alignment only if there is an
8482 alignment clause; this makes it possible to have the associated
8483 GCC type overaligned by default for performance reasons. */
8484 if ((double_align = double_float_alignment) > 0)
8487 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8489 = is_double_float_or_array (gnat_type, &align_clause);
8491 else if ((double_align = double_scalar_alignment) > 0)
8494 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8496 = is_double_scalar_or_array (gnat_type, &align_clause);
8499 is_capped_double = align_clause = false;
8501 if (is_capped_double && new_align >= double_align)
8504 align = new_align * BITS_PER_UNIT;
8508 if (is_capped_double)
8509 align = double_align * BITS_PER_UNIT;
8511 post_error_ne_num ("alignment for& must be at least ^",
8512 gnat_error_node, gnat_entity,
8513 align / BITS_PER_UNIT);
8518 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8519 if (new_align > align)
8526 /* Return the smallest alignment not less than SIZE. */
8529 ceil_alignment (unsigned HOST_WIDE_INT size)
8531 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
8534 /* Verify that OBJECT, a type or decl, is something we can implement
8535 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8536 if we require atomic components. */
8539 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
8541 Node_Id gnat_error_point = gnat_entity;
8543 enum machine_mode mode;
8547 /* There are three case of what OBJECT can be. It can be a type, in which
8548 case we take the size, alignment and mode from the type. It can be a
8549 declaration that was indirect, in which case the relevant values are
8550 that of the type being pointed to, or it can be a normal declaration,
8551 in which case the values are of the decl. The code below assumes that
8552 OBJECT is either a type or a decl. */
8553 if (TYPE_P (object))
8555 /* If this is an anonymous base type, nothing to check. Error will be
8556 reported on the source type. */
8557 if (!Comes_From_Source (gnat_entity))
8560 mode = TYPE_MODE (object);
8561 align = TYPE_ALIGN (object);
8562 size = TYPE_SIZE (object);
8564 else if (DECL_BY_REF_P (object))
8566 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
8567 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
8568 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
8572 mode = DECL_MODE (object);
8573 align = DECL_ALIGN (object);
8574 size = DECL_SIZE (object);
8577 /* Consider all floating-point types atomic and any types that that are
8578 represented by integers no wider than a machine word. */
8579 if (GET_MODE_CLASS (mode) == MODE_FLOAT
8580 || ((GET_MODE_CLASS (mode) == MODE_INT
8581 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
8582 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8585 /* For the moment, also allow anything that has an alignment equal
8586 to its size and which is smaller than a word. */
8587 if (size && TREE_CODE (size) == INTEGER_CST
8588 && compare_tree_int (size, align) == 0
8589 && align <= BITS_PER_WORD)
8592 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
8593 gnat_node = Next_Rep_Item (gnat_node))
8595 if (!comp_p && Nkind (gnat_node) == N_Pragma
8596 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8598 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8599 else if (comp_p && Nkind (gnat_node) == N_Pragma
8600 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8601 == Pragma_Atomic_Components))
8602 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8606 post_error_ne ("atomic access to component of & cannot be guaranteed",
8607 gnat_error_point, gnat_entity);
8609 post_error_ne ("atomic access to & cannot be guaranteed",
8610 gnat_error_point, gnat_entity);
8614 /* Helper for the intrin compatibility checks family. Evaluate whether
8615 two types are definitely incompatible. */
8618 intrin_types_incompatible_p (tree t1, tree t2)
8620 enum tree_code code;
8622 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8625 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8628 if (TREE_CODE (t1) != TREE_CODE (t2))
8631 code = TREE_CODE (t1);
8637 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8640 case REFERENCE_TYPE:
8641 /* Assume designated types are ok. We'd need to account for char * and
8642 void * variants to do better, which could rapidly get messy and isn't
8643 clearly worth the effort. */
8653 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8654 on the Ada/builtin argument lists for the INB binding. */
8657 intrin_arglists_compatible_p (intrin_binding_t * inb)
8659 function_args_iterator ada_iter, btin_iter;
8661 function_args_iter_init (&ada_iter, inb->ada_fntype);
8662 function_args_iter_init (&btin_iter, inb->btin_fntype);
8664 /* Sequence position of the last argument we checked. */
8669 tree ada_type = function_args_iter_cond (&ada_iter);
8670 tree btin_type = function_args_iter_cond (&btin_iter);
8672 /* If we've exhausted both lists simultaneously, we're done. */
8673 if (ada_type == NULL_TREE && btin_type == NULL_TREE)
8676 /* If one list is shorter than the other, they fail to match. */
8677 if (ada_type == NULL_TREE || btin_type == NULL_TREE)
8680 /* If we're done with the Ada args and not with the internal builtin
8681 args, or the other way around, complain. */
8682 if (ada_type == void_type_node
8683 && btin_type != void_type_node)
8685 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8689 if (btin_type == void_type_node
8690 && ada_type != void_type_node)
8692 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8693 inb->gnat_entity, inb->gnat_entity, argpos);
8697 /* Otherwise, check that types match for the current argument. */
8699 if (intrin_types_incompatible_p (ada_type, btin_type))
8701 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8702 inb->gnat_entity, inb->gnat_entity, argpos);
8707 function_args_iter_next (&ada_iter);
8708 function_args_iter_next (&btin_iter);
8714 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8715 on the Ada/builtin return values for the INB binding. */
8718 intrin_return_compatible_p (intrin_binding_t * inb)
8720 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8721 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8723 /* Accept function imported as procedure, common and convenient. */
8724 if (VOID_TYPE_P (ada_return_type)
8725 && !VOID_TYPE_P (btin_return_type))
8728 /* Check return types compatibility otherwise. Note that this
8729 handles void/void as well. */
8730 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8732 post_error ("?intrinsic binding type mismatch on return value!",
8740 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8741 compatible. Issue relevant warnings when they are not.
8743 This is intended as a light check to diagnose the most obvious cases, not
8744 as a full fledged type compatibility predicate. It is the programmer's
8745 responsibility to ensure correctness of the Ada declarations in Imports,
8746 especially when binding straight to a compiler internal. */
8749 intrin_profiles_compatible_p (intrin_binding_t * inb)
8751 /* Check compatibility on return values and argument lists, each responsible
8752 for posting warnings as appropriate. Ensure use of the proper sloc for
8755 bool arglists_compatible_p, return_compatible_p;
8756 location_t saved_location = input_location;
8758 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8760 return_compatible_p = intrin_return_compatible_p (inb);
8761 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8763 input_location = saved_location;
8765 return return_compatible_p && arglists_compatible_p;
8768 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8769 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8770 specified size for this field. POS_LIST is a position list describing
8771 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8775 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8776 tree size, tree pos_list,
8777 VEC(subst_pair,heap) *subst_list)
8779 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8780 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8781 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
8782 tree new_pos, new_field;
8786 if (CONTAINS_PLACEHOLDER_P (pos))
8787 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8788 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8790 /* If the position is now a constant, we can set it as the position of the
8791 field when we make it. Otherwise, we need to deal with it specially. */
8792 if (TREE_CONSTANT (pos))
8793 new_pos = bit_from_pos (pos, bitpos);
8795 new_pos = NULL_TREE;
8798 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8799 size, new_pos, DECL_PACKED (old_field),
8800 !DECL_NONADDRESSABLE_P (old_field));
8804 normalize_offset (&pos, &bitpos, offset_align);
8805 DECL_FIELD_OFFSET (new_field) = pos;
8806 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8807 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8808 DECL_SIZE (new_field) = size;
8809 DECL_SIZE_UNIT (new_field)
8810 = convert (sizetype,
8811 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8812 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8815 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8816 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8817 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8818 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8823 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
8824 it is the minimal size the REP_PART must have. */
8827 create_rep_part (tree rep_type, tree record_type, tree min_size)
8831 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
8832 min_size = NULL_TREE;
8834 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
8835 min_size, bitsize_zero_node, 0, 1);
8836 DECL_INTERNAL_P (field) = 1;
8841 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8844 get_rep_part (tree record_type)
8846 tree field = TYPE_FIELDS (record_type);
8848 /* The REP part is the first field, internal, another record, and its name
8849 starts with an 'R'. */
8850 if (DECL_INTERNAL_P (field)
8851 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8852 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
8858 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8861 get_variant_part (tree record_type)
8865 /* The variant part is the only internal field that is a qualified union. */
8866 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8867 if (DECL_INTERNAL_P (field)
8868 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8874 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8875 the list of variants to be used and RECORD_TYPE is the type of the parent.
8876 POS_LIST is a position list describing the layout of fields present in
8877 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8881 create_variant_part_from (tree old_variant_part,
8882 VEC(variant_desc,heap) *variant_list,
8883 tree record_type, tree pos_list,
8884 VEC(subst_pair,heap) *subst_list)
8886 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8887 tree old_union_type = TREE_TYPE (old_variant_part);
8888 tree new_union_type, new_variant_part;
8889 tree union_field_list = NULL_TREE;
8893 /* First create the type of the variant part from that of the old one. */
8894 new_union_type = make_node (QUAL_UNION_TYPE);
8895 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8897 /* If the position of the variant part is constant, subtract it from the
8898 size of the type of the parent to get the new size. This manual CSE
8899 reduces the code size when not optimizing. */
8900 if (TREE_CODE (offset) == INTEGER_CST)
8902 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8903 tree first_bit = bit_from_pos (offset, bitpos);
8904 TYPE_SIZE (new_union_type)
8905 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8906 TYPE_SIZE_UNIT (new_union_type)
8907 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8908 byte_from_pos (offset, bitpos));
8909 SET_TYPE_ADA_SIZE (new_union_type,
8910 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8912 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8913 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8916 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8918 /* Now finish up the new variants and populate the union type. */
8919 FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v)
8921 tree old_field = v->field, new_field;
8922 tree old_variant, old_variant_subpart, new_variant, field_list;
8924 /* Skip variants that don't belong to this nesting level. */
8925 if (DECL_CONTEXT (old_field) != old_union_type)
8928 /* Retrieve the list of fields already added to the new variant. */
8929 new_variant = v->record;
8930 field_list = TYPE_FIELDS (new_variant);
8932 /* If the old variant had a variant subpart, we need to create a new
8933 variant subpart and add it to the field list. */
8934 old_variant = v->type;
8935 old_variant_subpart = get_variant_part (old_variant);
8936 if (old_variant_subpart)
8938 tree new_variant_subpart
8939 = create_variant_part_from (old_variant_subpart, variant_list,
8940 new_variant, pos_list, subst_list);
8941 DECL_CHAIN (new_variant_subpart) = field_list;
8942 field_list = new_variant_subpart;
8945 /* Finish up the new variant and create the field. No need for debug
8946 info thanks to the XVS type. */
8947 finish_record_type (new_variant, nreverse (field_list), 2, false);
8948 compute_record_mode (new_variant);
8949 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8950 true, false, Empty);
8953 = create_field_decl_from (old_field, new_variant, new_union_type,
8954 TYPE_SIZE (new_variant),
8955 pos_list, subst_list);
8956 DECL_QUALIFIER (new_field) = v->qual;
8957 DECL_INTERNAL_P (new_field) = 1;
8958 DECL_CHAIN (new_field) = union_field_list;
8959 union_field_list = new_field;
8962 /* Finish up the union type and create the variant part. No need for debug
8963 info thanks to the XVS type. */
8964 finish_record_type (new_union_type, union_field_list, 2, false);
8965 compute_record_mode (new_union_type);
8966 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8967 true, false, Empty);
8970 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8971 TYPE_SIZE (new_union_type),
8972 pos_list, subst_list);
8973 DECL_INTERNAL_P (new_variant_part) = 1;
8975 /* With multiple discriminants it is possible for an inner variant to be
8976 statically selected while outer ones are not; in this case, the list
8977 of fields of the inner variant is not flattened and we end up with a
8978 qualified union with a single member. Drop the useless container. */
8979 if (!DECL_CHAIN (union_field_list))
8981 DECL_CONTEXT (union_field_list) = record_type;
8982 DECL_FIELD_OFFSET (union_field_list)
8983 = DECL_FIELD_OFFSET (new_variant_part);
8984 DECL_FIELD_BIT_OFFSET (union_field_list)
8985 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8986 SET_DECL_OFFSET_ALIGN (union_field_list,
8987 DECL_OFFSET_ALIGN (new_variant_part));
8988 new_variant_part = union_field_list;
8991 return new_variant_part;
8994 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8995 which are both RECORD_TYPE, after applying the substitutions described
8999 copy_and_substitute_in_size (tree new_type, tree old_type,
9000 VEC(subst_pair,heap) *subst_list)
9005 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
9006 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
9007 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
9008 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
9009 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
9011 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
9012 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
9013 TYPE_SIZE (new_type)
9014 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
9015 s->discriminant, s->replacement);
9017 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
9018 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
9019 TYPE_SIZE_UNIT (new_type)
9020 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
9021 s->discriminant, s->replacement);
9023 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
9024 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
9026 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
9027 s->discriminant, s->replacement));
9029 /* Finalize the size. */
9030 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
9031 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
9034 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
9035 type with all size expressions that contain F in a PLACEHOLDER_EXPR
9036 updated by replacing F with R.
9038 The function doesn't update the layout of the type, i.e. it assumes
9039 that the substitution is purely formal. That's why the replacement
9040 value R must itself contain a PLACEHOLDER_EXPR. */
9043 substitute_in_type (tree t, tree f, tree r)
9047 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
9049 switch (TREE_CODE (t))
9056 /* First the domain types of arrays. */
9057 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
9058 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
9060 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
9061 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
9063 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
9067 TYPE_GCC_MIN_VALUE (nt) = low;
9068 TYPE_GCC_MAX_VALUE (nt) = high;
9070 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
9072 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
9077 /* Then the subtypes. */
9078 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
9079 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
9081 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
9082 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
9084 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
9088 SET_TYPE_RM_MIN_VALUE (nt, low);
9089 SET_TYPE_RM_MAX_VALUE (nt, high);
9097 nt = substitute_in_type (TREE_TYPE (t), f, r);
9098 if (nt == TREE_TYPE (t))
9101 return build_complex_type (nt);
9104 /* These should never show up here. */
9109 tree component = substitute_in_type (TREE_TYPE (t), f, r);
9110 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
9112 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
9115 nt = build_nonshared_array_type (component, domain);
9116 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
9117 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
9118 SET_TYPE_MODE (nt, TYPE_MODE (t));
9119 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9120 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9121 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
9122 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
9123 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
9129 case QUAL_UNION_TYPE:
9131 bool changed_field = false;
9134 /* Start out with no fields, make new fields, and chain them
9135 in. If we haven't actually changed the type of any field,
9136 discard everything we've done and return the old type. */
9138 TYPE_FIELDS (nt) = NULL_TREE;
9140 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
9142 tree new_field = copy_node (field), new_n;
9144 new_n = substitute_in_type (TREE_TYPE (field), f, r);
9145 if (new_n != TREE_TYPE (field))
9147 TREE_TYPE (new_field) = new_n;
9148 changed_field = true;
9151 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
9152 if (new_n != DECL_FIELD_OFFSET (field))
9154 DECL_FIELD_OFFSET (new_field) = new_n;
9155 changed_field = true;
9158 /* Do the substitution inside the qualifier, if any. */
9159 if (TREE_CODE (t) == QUAL_UNION_TYPE)
9161 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
9162 if (new_n != DECL_QUALIFIER (field))
9164 DECL_QUALIFIER (new_field) = new_n;
9165 changed_field = true;
9169 DECL_CONTEXT (new_field) = nt;
9170 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
9172 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
9173 TYPE_FIELDS (nt) = new_field;
9179 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
9180 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9181 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9182 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
9191 /* Return the RM size of GNU_TYPE. This is the actual number of bits
9192 needed to represent the object. */
9195 rm_size (tree gnu_type)
9197 /* For integral types, we store the RM size explicitly. */
9198 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
9199 return TYPE_RM_SIZE (gnu_type);
9201 /* Return the RM size of the actual data plus the size of the template. */
9202 if (TREE_CODE (gnu_type) == RECORD_TYPE
9203 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9205 size_binop (PLUS_EXPR,
9206 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
9207 DECL_SIZE (TYPE_FIELDS (gnu_type)));
9209 /* For record or union types, we store the size explicitly. */
9210 if (RECORD_OR_UNION_TYPE_P (gnu_type)
9211 && !TYPE_FAT_POINTER_P (gnu_type)
9212 && TYPE_ADA_SIZE (gnu_type))
9213 return TYPE_ADA_SIZE (gnu_type);
9215 /* For other types, this is just the size. */
9216 return TYPE_SIZE (gnu_type);
9219 /* Return the name to be used for GNAT_ENTITY. If a type, create a
9220 fully-qualified name, possibly with type information encoding.
9221 Otherwise, return the name. */
9224 get_entity_name (Entity_Id gnat_entity)
9226 Get_Encoded_Name (gnat_entity);
9227 return get_identifier_with_length (Name_Buffer, Name_Len);
9230 /* Return an identifier representing the external name to be used for
9231 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
9232 and the specified suffix. */
9235 create_concat_name (Entity_Id gnat_entity, const char *suffix)
9237 Entity_Kind kind = Ekind (gnat_entity);
9241 String_Template temp = {1, (int) strlen (suffix)};
9242 Fat_Pointer fp = {suffix, &temp};
9243 Get_External_Name_With_Suffix (gnat_entity, fp);
9246 Get_External_Name (gnat_entity, 0);
9248 /* A variable using the Stdcall convention lives in a DLL. We adjust
9249 its name to use the jump table, the _imp__NAME contains the address
9250 for the NAME variable. */
9251 if ((kind == E_Variable || kind == E_Constant)
9252 && Has_Stdcall_Convention (gnat_entity))
9254 const int len = 6 + Name_Len;
9255 char *new_name = (char *) alloca (len + 1);
9256 strcpy (new_name, "_imp__");
9257 strcat (new_name, Name_Buffer);
9258 return get_identifier_with_length (new_name, len);
9261 return get_identifier_with_length (Name_Buffer, Name_Len);
9264 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9265 string, return a new IDENTIFIER_NODE that is the concatenation of
9266 the name followed by "___" and the specified suffix. */
9269 concat_name (tree gnu_name, const char *suffix)
9271 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
9272 char *new_name = (char *) alloca (len + 1);
9273 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
9274 strcat (new_name, "___");
9275 strcat (new_name, suffix);
9276 return get_identifier_with_length (new_name, len);
9279 #include "gt-ada-decl.h"
OSDN Git Service
