1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2011, 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 is_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, 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 get_rep_part (tree);
180 static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree,
181 tree, VEC(subst_pair,heap) *);
182 static void copy_and_substitute_in_size (tree, tree, VEC(subst_pair,heap) *);
183 static void rest_of_type_decl_compilation_no_defer (tree);
185 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
186 to pass around calls performing profile compatibility checks. */
189 Entity_Id gnat_entity; /* The Ada subprogram entity. */
190 tree ada_fntype; /* The corresponding GCC type node. */
191 tree btin_fntype; /* The GCC builtin function type node. */
194 static bool intrin_profiles_compatible_p (intrin_binding_t *);
196 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
197 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
198 and associate the ..._DECL node with the input GNAT defining identifier.
200 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
201 initial value (in GCC tree form). This is optional for a variable. For
202 a renamed entity, GNU_EXPR gives the object being renamed.
204 DEFINITION is nonzero if this call is intended for a definition. This is
205 used for separate compilation where it is necessary to know whether an
206 external declaration or a definition must be created if the GCC equivalent
207 was not created previously. The value of 1 is normally used for a nonzero
208 DEFINITION, but a value of 2 is used in special circumstances, defined in
212 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
214 /* Contains the kind of the input GNAT node. */
215 const Entity_Kind kind = Ekind (gnat_entity);
216 /* True if this is a type. */
217 const bool is_type = IN (kind, Type_Kind);
218 /* True if debug info is requested for this entity. */
219 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
220 /* True if this entity is to be considered as imported. */
221 const bool imported_p
222 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
223 /* For a type, contains the equivalent GNAT node to be used in gigi. */
224 Entity_Id gnat_equiv_type = Empty;
225 /* Temporary used to walk the GNAT tree. */
227 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
228 This node will be associated with the GNAT node by calling at the end
229 of the `switch' statement. */
230 tree gnu_decl = NULL_TREE;
231 /* Contains the GCC type to be used for the GCC node. */
232 tree gnu_type = NULL_TREE;
233 /* Contains the GCC size tree to be used for the GCC node. */
234 tree gnu_size = NULL_TREE;
235 /* Contains the GCC name to be used for the GCC node. */
236 tree gnu_entity_name;
237 /* True if we have already saved gnu_decl as a GNAT association. */
239 /* True if we incremented defer_incomplete_level. */
240 bool this_deferred = false;
241 /* True if we incremented force_global. */
242 bool this_global = false;
243 /* True if we should check to see if elaborated during processing. */
244 bool maybe_present = false;
245 /* True if we made GNU_DECL and its type here. */
246 bool this_made_decl = false;
247 /* Size and alignment of the GCC node, if meaningful. */
248 unsigned int esize = 0, align = 0;
249 /* Contains the list of attributes directly attached to the entity. */
250 struct attrib *attr_list = NULL;
252 /* Since a use of an Itype is a definition, process it as such if it
253 is not in a with'ed unit. */
256 && Is_Itype (gnat_entity)
257 && !present_gnu_tree (gnat_entity)
258 && In_Extended_Main_Code_Unit (gnat_entity))
260 /* Ensure that we are in a subprogram mentioned in the Scope chain of
261 this entity, our current scope is global, or we encountered a task
262 or entry (where we can't currently accurately check scoping). */
263 if (!current_function_decl
264 || DECL_ELABORATION_PROC_P (current_function_decl))
266 process_type (gnat_entity);
267 return get_gnu_tree (gnat_entity);
270 for (gnat_temp = Scope (gnat_entity);
272 gnat_temp = Scope (gnat_temp))
274 if (Is_Type (gnat_temp))
275 gnat_temp = Underlying_Type (gnat_temp);
277 if (Ekind (gnat_temp) == E_Subprogram_Body)
279 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
281 if (IN (Ekind (gnat_temp), Subprogram_Kind)
282 && Present (Protected_Body_Subprogram (gnat_temp)))
283 gnat_temp = Protected_Body_Subprogram (gnat_temp);
285 if (Ekind (gnat_temp) == E_Entry
286 || Ekind (gnat_temp) == E_Entry_Family
287 || Ekind (gnat_temp) == E_Task_Type
288 || (IN (Ekind (gnat_temp), Subprogram_Kind)
289 && present_gnu_tree (gnat_temp)
290 && (current_function_decl
291 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
293 process_type (gnat_entity);
294 return get_gnu_tree (gnat_entity);
298 /* This abort means the Itype has an incorrect scope, i.e. that its
299 scope does not correspond to the subprogram it is declared in. */
303 /* If we've already processed this entity, return what we got last time.
304 If we are defining the node, we should not have already processed it.
305 In that case, we will abort below when we try to save a new GCC tree
306 for this object. We also need to handle the case of getting a dummy
307 type when a Full_View exists. */
308 if ((!definition || (is_type && imported_p))
309 && present_gnu_tree (gnat_entity))
311 gnu_decl = get_gnu_tree (gnat_entity);
313 if (TREE_CODE (gnu_decl) == TYPE_DECL
314 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
315 && IN (kind, Incomplete_Or_Private_Kind)
316 && Present (Full_View (gnat_entity)))
319 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
320 save_gnu_tree (gnat_entity, NULL_TREE, false);
321 save_gnu_tree (gnat_entity, gnu_decl, false);
327 /* If this is a numeric or enumeral type, or an access type, a nonzero
328 Esize must be specified unless it was specified by the programmer. */
329 gcc_assert (!Unknown_Esize (gnat_entity)
330 || Has_Size_Clause (gnat_entity)
331 || (!IN (kind, Numeric_Kind)
332 && !IN (kind, Enumeration_Kind)
333 && (!IN (kind, Access_Kind)
334 || kind == E_Access_Protected_Subprogram_Type
335 || kind == E_Anonymous_Access_Protected_Subprogram_Type
336 || kind == E_Access_Subtype)));
338 /* The RM size must be specified for all discrete and fixed-point types. */
339 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
340 && Unknown_RM_Size (gnat_entity)));
342 /* If we get here, it means we have not yet done anything with this entity.
343 If we are not defining it, it must be a type or an entity that is defined
344 elsewhere or externally, otherwise we should have defined it already. */
345 gcc_assert (definition
346 || type_annotate_only
348 || kind == E_Discriminant
349 || kind == E_Component
351 || (kind == E_Constant && Present (Full_View (gnat_entity)))
352 || Is_Public (gnat_entity));
354 /* Get the name of the entity and set up the line number and filename of
355 the original definition for use in any decl we make. */
356 gnu_entity_name = get_entity_name (gnat_entity);
357 Sloc_to_locus (Sloc (gnat_entity), &input_location);
359 /* For cases when we are not defining (i.e., we are referencing from
360 another compilation unit) public entities, show we are at global level
361 for the purpose of computing scopes. Don't do this for components or
362 discriminants since the relevant test is whether or not the record is
363 being defined. Don't do this for constants either as we'll look into
364 their defining expression in the local context. */
366 && kind != E_Component
367 && kind != E_Discriminant
368 && kind != E_Constant
369 && Is_Public (gnat_entity)
370 && !Is_Statically_Allocated (gnat_entity))
371 force_global++, this_global = true;
373 /* Handle any attributes directly attached to the entity. */
374 if (Has_Gigi_Rep_Item (gnat_entity))
375 prepend_attributes (gnat_entity, &attr_list);
377 /* Do some common processing for types. */
380 /* Compute the equivalent type to be used in gigi. */
381 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
383 /* Machine_Attributes on types are expected to be propagated to
384 subtypes. The corresponding Gigi_Rep_Items are only attached
385 to the first subtype though, so we handle the propagation here. */
386 if (Base_Type (gnat_entity) != gnat_entity
387 && !Is_First_Subtype (gnat_entity)
388 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
389 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
392 /* Compute a default value for the size of the type. */
393 if (Known_Esize (gnat_entity)
394 && UI_Is_In_Int_Range (Esize (gnat_entity)))
396 unsigned int max_esize;
397 esize = UI_To_Int (Esize (gnat_entity));
399 if (IN (kind, Float_Kind))
400 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
401 else if (IN (kind, Access_Kind))
402 max_esize = POINTER_SIZE * 2;
404 max_esize = LONG_LONG_TYPE_SIZE;
406 if (esize > max_esize)
410 esize = LONG_LONG_TYPE_SIZE;
416 /* If this is a use of a deferred constant without address clause,
417 get its full definition. */
419 && No (Address_Clause (gnat_entity))
420 && Present (Full_View (gnat_entity)))
423 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
428 /* If we have an external constant that we are not defining, get the
429 expression that is was defined to represent. We may throw it away
430 later if it is not a constant. But do not retrieve the expression
431 if it is an allocator because the designated type might be dummy
434 && !No_Initialization (Declaration_Node (gnat_entity))
435 && Present (Expression (Declaration_Node (gnat_entity)))
436 && Nkind (Expression (Declaration_Node (gnat_entity)))
439 bool went_into_elab_proc = false;
441 /* The expression may contain N_Expression_With_Actions nodes and
442 thus object declarations from other units. In this case, even
443 though the expression will eventually be discarded since not a
444 constant, the declarations would be stuck either in the global
445 varpool or in the current scope. Therefore we force the local
446 context and create a fake scope that we'll zap at the end. */
447 if (!current_function_decl)
449 current_function_decl = get_elaboration_procedure ();
450 went_into_elab_proc = true;
454 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
457 if (went_into_elab_proc)
458 current_function_decl = NULL_TREE;
461 /* Ignore deferred constant definitions without address clause since
462 they are processed fully in the front-end. If No_Initialization
463 is set, this is not a deferred constant but a constant whose value
464 is built manually. And constants that are renamings are handled
468 && No (Address_Clause (gnat_entity))
469 && !No_Initialization (Declaration_Node (gnat_entity))
470 && No (Renamed_Object (gnat_entity)))
472 gnu_decl = error_mark_node;
477 /* Ignore constant definitions already marked with the error node. See
478 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
481 && present_gnu_tree (gnat_entity)
482 && get_gnu_tree (gnat_entity) == error_mark_node)
484 maybe_present = true;
491 /* We used to special case VMS exceptions here to directly map them to
492 their associated condition code. Since this code had to be masked
493 dynamically to strip off the severity bits, this caused trouble in
494 the GCC/ZCX case because the "type" pointers we store in the tables
495 have to be static. We now don't special case here anymore, and let
496 the regular processing take place, which leaves us with a regular
497 exception data object for VMS exceptions too. The condition code
498 mapping is taken care of by the front end and the bitmasking by the
505 /* The GNAT record where the component was defined. */
506 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
508 /* If the variable is an inherited record component (in the case of
509 extended record types), just return the inherited entity, which
510 must be a FIELD_DECL. Likewise for discriminants.
511 For discriminants of untagged records which have explicit
512 stored discriminants, return the entity for the corresponding
513 stored discriminant. Also use Original_Record_Component
514 if the record has a private extension. */
515 if (Present (Original_Record_Component (gnat_entity))
516 && Original_Record_Component (gnat_entity) != gnat_entity)
519 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
520 gnu_expr, definition);
525 /* If the enclosing record has explicit stored discriminants,
526 then it is an untagged record. If the Corresponding_Discriminant
527 is not empty then this must be a renamed discriminant and its
528 Original_Record_Component must point to the corresponding explicit
529 stored discriminant (i.e. we should have taken the previous
531 else if (Present (Corresponding_Discriminant (gnat_entity))
532 && Is_Tagged_Type (gnat_record))
534 /* A tagged record has no explicit stored discriminants. */
535 gcc_assert (First_Discriminant (gnat_record)
536 == First_Stored_Discriminant (gnat_record));
538 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
539 gnu_expr, definition);
544 else if (Present (CR_Discriminant (gnat_entity))
545 && type_annotate_only)
547 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
548 gnu_expr, definition);
553 /* If the enclosing record has explicit stored discriminants, then
554 it is an untagged record. If the Corresponding_Discriminant
555 is not empty then this must be a renamed discriminant and its
556 Original_Record_Component must point to the corresponding explicit
557 stored discriminant (i.e. we should have taken the first
559 else if (Present (Corresponding_Discriminant (gnat_entity))
560 && (First_Discriminant (gnat_record)
561 != First_Stored_Discriminant (gnat_record)))
564 /* Otherwise, if we are not defining this and we have no GCC type
565 for the containing record, make one for it. Then we should
566 have made our own equivalent. */
567 else if (!definition && !present_gnu_tree (gnat_record))
569 /* ??? If this is in a record whose scope is a protected
570 type and we have an Original_Record_Component, use it.
571 This is a workaround for major problems in protected type
573 Entity_Id Scop = Scope (Scope (gnat_entity));
574 if ((Is_Protected_Type (Scop)
575 || (Is_Private_Type (Scop)
576 && Present (Full_View (Scop))
577 && Is_Protected_Type (Full_View (Scop))))
578 && Present (Original_Record_Component (gnat_entity)))
581 = gnat_to_gnu_entity (Original_Record_Component
588 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
589 gnu_decl = get_gnu_tree (gnat_entity);
595 /* Here we have no GCC type and this is a reference rather than a
596 definition. This should never happen. Most likely the cause is
597 reference before declaration in the gnat tree for gnat_entity. */
601 case E_Loop_Parameter:
602 case E_Out_Parameter:
605 /* Simple variables, loop variables, Out parameters and exceptions. */
609 = ((kind == E_Constant || kind == E_Variable)
610 && Is_True_Constant (gnat_entity)
611 && !Treat_As_Volatile (gnat_entity)
612 && (((Nkind (Declaration_Node (gnat_entity))
613 == N_Object_Declaration)
614 && Present (Expression (Declaration_Node (gnat_entity))))
615 || Present (Renamed_Object (gnat_entity))
617 bool inner_const_flag = const_flag;
618 bool static_p = Is_Statically_Allocated (gnat_entity);
619 bool mutable_p = false;
620 bool used_by_ref = false;
621 tree gnu_ext_name = NULL_TREE;
622 tree renamed_obj = NULL_TREE;
623 tree gnu_object_size;
625 if (Present (Renamed_Object (gnat_entity)) && !definition)
627 if (kind == E_Exception)
628 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
631 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
634 /* Get the type after elaborating the renamed object. */
635 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
637 /* If this is a standard exception definition, then use the standard
638 exception type. This is necessary to make sure that imported and
639 exported views of exceptions are properly merged in LTO mode. */
640 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
641 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
642 gnu_type = except_type_node;
644 /* For a debug renaming declaration, build a debug-only entity. */
645 if (Present (Debug_Renaming_Link (gnat_entity)))
647 /* Force a non-null value to make sure the symbol is retained. */
648 tree value = build1 (INDIRECT_REF, gnu_type,
650 build_pointer_type (gnu_type),
651 integer_minus_one_node));
652 gnu_decl = build_decl (input_location,
653 VAR_DECL, gnu_entity_name, gnu_type);
654 SET_DECL_VALUE_EXPR (gnu_decl, value);
655 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
656 gnat_pushdecl (gnu_decl, gnat_entity);
660 /* If this is a loop variable, its type should be the base type.
661 This is because the code for processing a loop determines whether
662 a normal loop end test can be done by comparing the bounds of the
663 loop against those of the base type, which is presumed to be the
664 size used for computation. But this is not correct when the size
665 of the subtype is smaller than the type. */
666 if (kind == E_Loop_Parameter)
667 gnu_type = get_base_type (gnu_type);
669 /* Reject non-renamed objects whose type is an unconstrained array or
670 any object whose type is a dummy type or void. */
671 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
672 && No (Renamed_Object (gnat_entity)))
673 || TYPE_IS_DUMMY_P (gnu_type)
674 || TREE_CODE (gnu_type) == VOID_TYPE)
676 gcc_assert (type_annotate_only);
679 return error_mark_node;
682 /* If an alignment is specified, use it if valid. Note that exceptions
683 are objects but don't have an alignment. We must do this before we
684 validate the size, since the alignment can affect the size. */
685 if (kind != E_Exception && Known_Alignment (gnat_entity))
687 gcc_assert (Present (Alignment (gnat_entity)));
689 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
690 TYPE_ALIGN (gnu_type));
692 /* No point in changing the type if there is an address clause
693 as the final type of the object will be a reference type. */
694 if (Present (Address_Clause (gnat_entity)))
698 tree orig_type = gnu_type;
701 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
702 false, false, definition, true);
704 /* If a padding record was made, declare it now since it will
705 never be declared otherwise. This is necessary to ensure
706 that its subtrees are properly marked. */
707 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
708 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
709 debug_info_p, gnat_entity);
713 /* If we are defining the object, see if it has a Size and validate it
714 if so. If we are not defining the object and a Size clause applies,
715 simply retrieve the value. We don't want to ignore the clause and
716 it is expected to have been validated already. Then get the new
719 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
720 gnat_entity, VAR_DECL, false,
721 Has_Size_Clause (gnat_entity));
722 else if (Has_Size_Clause (gnat_entity))
723 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
728 = make_type_from_size (gnu_type, gnu_size,
729 Has_Biased_Representation (gnat_entity));
731 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
732 gnu_size = NULL_TREE;
735 /* If this object has self-referential size, it must be a record with
736 a default discriminant. We are supposed to allocate an object of
737 the maximum size in this case, unless it is a constant with an
738 initializing expression, in which case we can get the size from
739 that. Note that the resulting size may still be a variable, so
740 this may end up with an indirect allocation. */
741 if (No (Renamed_Object (gnat_entity))
742 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
744 if (gnu_expr && kind == E_Constant)
746 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
747 if (CONTAINS_PLACEHOLDER_P (size))
749 /* If the initializing expression is itself a constant,
750 despite having a nominal type with self-referential
751 size, we can get the size directly from it. */
752 if (TREE_CODE (gnu_expr) == COMPONENT_REF
754 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
755 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
756 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
757 || DECL_READONLY_ONCE_ELAB
758 (TREE_OPERAND (gnu_expr, 0))))
759 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
762 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
767 /* We may have no GNU_EXPR because No_Initialization is
768 set even though there's an Expression. */
769 else if (kind == E_Constant
770 && (Nkind (Declaration_Node (gnat_entity))
771 == N_Object_Declaration)
772 && Present (Expression (Declaration_Node (gnat_entity))))
774 = TYPE_SIZE (gnat_to_gnu_type
776 (Expression (Declaration_Node (gnat_entity)))));
779 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
784 /* If the size is zero byte, make it one byte since some linkers have
785 troubles with zero-sized objects. If the object will have a
786 template, that will make it nonzero so don't bother. Also avoid
787 doing that for an object renaming or an object with an address
788 clause, as we would lose useful information on the view size
789 (e.g. for null array slices) and we are not allocating the object
792 && integer_zerop (gnu_size)
793 && !TREE_OVERFLOW (gnu_size))
794 || (TYPE_SIZE (gnu_type)
795 && integer_zerop (TYPE_SIZE (gnu_type))
796 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
797 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
798 || !Is_Array_Type (Etype (gnat_entity)))
799 && No (Renamed_Object (gnat_entity))
800 && No (Address_Clause (gnat_entity)))
801 gnu_size = bitsize_unit_node;
803 /* If this is an object with no specified size and alignment, and
804 if either it is atomic or we are not optimizing alignment for
805 space and it is composite and not an exception, an Out parameter
806 or a reference to another object, and the size of its type is a
807 constant, set the alignment to the smallest one which is not
808 smaller than the size, with an appropriate cap. */
809 if (!gnu_size && align == 0
810 && (Is_Atomic (gnat_entity)
811 || (!Optimize_Alignment_Space (gnat_entity)
812 && kind != E_Exception
813 && kind != E_Out_Parameter
814 && Is_Composite_Type (Etype (gnat_entity))
815 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
816 && !Is_Exported (gnat_entity)
818 && No (Renamed_Object (gnat_entity))
819 && No (Address_Clause (gnat_entity))))
820 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
822 /* No point in jumping through all the hoops needed in order
823 to support BIGGEST_ALIGNMENT if we don't really have to.
824 So we cap to the smallest alignment that corresponds to
825 a known efficient memory access pattern of the target. */
826 unsigned int align_cap = Is_Atomic (gnat_entity)
828 : get_mode_alignment (ptr_mode);
830 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
831 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
834 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
836 /* But make sure not to under-align the object. */
837 if (align <= TYPE_ALIGN (gnu_type))
840 /* And honor the minimum valid atomic alignment, if any. */
841 #ifdef MINIMUM_ATOMIC_ALIGNMENT
842 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
843 align = MINIMUM_ATOMIC_ALIGNMENT;
847 /* If the object is set to have atomic components, find the component
848 type and validate it.
850 ??? Note that we ignore Has_Volatile_Components on objects; it's
851 not at all clear what to do in that case. */
852 if (Has_Atomic_Components (gnat_entity))
854 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
855 ? TREE_TYPE (gnu_type) : gnu_type);
857 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
858 && TYPE_MULTI_ARRAY_P (gnu_inner))
859 gnu_inner = TREE_TYPE (gnu_inner);
861 check_ok_for_atomic (gnu_inner, gnat_entity, true);
864 /* Now check if the type of the object allows atomic access. Note
865 that we must test the type, even if this object has size and
866 alignment to allow such access, because we will be going inside
867 the padded record to assign to the object. We could fix this by
868 always copying via an intermediate value, but it's not clear it's
870 if (Is_Atomic (gnat_entity))
871 check_ok_for_atomic (gnu_type, gnat_entity, false);
873 /* If this is an aliased object with an unconstrained nominal subtype,
874 make a type that includes the template. */
875 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
876 && Is_Array_Type (Etype (gnat_entity))
877 && !type_annotate_only)
880 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
882 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
883 concat_name (gnu_entity_name,
888 #ifdef MINIMUM_ATOMIC_ALIGNMENT
889 /* If the size is a constant and no alignment is specified, force
890 the alignment to be the minimum valid atomic alignment. The
891 restriction on constant size avoids problems with variable-size
892 temporaries; if the size is variable, there's no issue with
893 atomic access. Also don't do this for a constant, since it isn't
894 necessary and can interfere with constant replacement. Finally,
895 do not do it for Out parameters since that creates an
896 size inconsistency with In parameters. */
897 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
898 && !FLOAT_TYPE_P (gnu_type)
899 && !const_flag && No (Renamed_Object (gnat_entity))
900 && !imported_p && No (Address_Clause (gnat_entity))
901 && kind != E_Out_Parameter
902 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
903 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
904 align = MINIMUM_ATOMIC_ALIGNMENT;
907 /* Make a new type with the desired size and alignment, if needed.
908 But do not take into account alignment promotions to compute the
909 size of the object. */
910 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
911 if (gnu_size || align > 0)
913 tree orig_type = gnu_type;
915 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
916 false, false, definition,
917 gnu_size ? true : false);
919 /* If a padding record was made, declare it now since it will
920 never be declared otherwise. This is necessary to ensure
921 that its subtrees are properly marked. */
922 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
923 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
924 debug_info_p, gnat_entity);
927 /* If this is a renaming, avoid as much as possible to create a new
928 object. However, in several cases, creating it is required.
929 This processing needs to be applied to the raw expression so
930 as to make it more likely to rename the underlying object. */
931 if (Present (Renamed_Object (gnat_entity)))
933 bool create_normal_object = false;
935 /* If the renamed object had padding, strip off the reference
936 to the inner object and reset our type. */
937 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
938 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
939 /* Strip useless conversions around the object. */
940 || (TREE_CODE (gnu_expr) == NOP_EXPR
941 && gnat_types_compatible_p
942 (TREE_TYPE (gnu_expr),
943 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
945 gnu_expr = TREE_OPERAND (gnu_expr, 0);
946 gnu_type = TREE_TYPE (gnu_expr);
949 /* Case 1: If this is a constant renaming stemming from a function
950 call, treat it as a normal object whose initial value is what
951 is being renamed. RM 3.3 says that the result of evaluating a
952 function call is a constant object. As a consequence, it can
953 be the inner object of a constant renaming. In this case, the
954 renaming must be fully instantiated, i.e. it cannot be a mere
955 reference to (part of) an existing object. */
958 tree inner_object = gnu_expr;
959 while (handled_component_p (inner_object))
960 inner_object = TREE_OPERAND (inner_object, 0);
961 if (TREE_CODE (inner_object) == CALL_EXPR)
962 create_normal_object = true;
965 /* Otherwise, see if we can proceed with a stabilized version of
966 the renamed entity or if we need to make a new object. */
967 if (!create_normal_object)
969 tree maybe_stable_expr = NULL_TREE;
972 /* Case 2: If the renaming entity need not be materialized and
973 the renamed expression is something we can stabilize, use
974 that for the renaming. At the global level, we can only do
975 this if we know no SAVE_EXPRs need be made, because the
976 expression we return might be used in arbitrary conditional
977 branches so we must force the evaluation of the SAVE_EXPRs
978 immediately and this requires a proper function context.
979 Note that an external constant is at the global level. */
980 if (!Materialize_Entity (gnat_entity)
981 && (!((!definition && kind == E_Constant)
982 || global_bindings_p ())
983 || (staticp (gnu_expr)
984 && !TREE_SIDE_EFFECTS (gnu_expr))))
987 = gnat_stabilize_reference (gnu_expr, true, &stable);
991 /* ??? No DECL_EXPR is created so we need to mark
992 the expression manually lest it is shared. */
993 if ((!definition && kind == E_Constant)
994 || global_bindings_p ())
995 MARK_VISITED (maybe_stable_expr);
996 gnu_decl = maybe_stable_expr;
997 save_gnu_tree (gnat_entity, gnu_decl, true);
999 annotate_object (gnat_entity, gnu_type, NULL_TREE,
1004 /* The stabilization failed. Keep maybe_stable_expr
1005 untouched here to let the pointer case below know
1006 about that failure. */
1009 /* Case 3: If this is a constant renaming and creating a
1010 new object is allowed and cheap, treat it as a normal
1011 object whose initial value is what is being renamed. */
1013 && !Is_Composite_Type
1014 (Underlying_Type (Etype (gnat_entity))))
1017 /* Case 4: Make this into a constant pointer to the object we
1018 are to rename and attach the object to the pointer if it is
1019 something we can stabilize.
1021 From the proper scope, attached objects will be referenced
1022 directly instead of indirectly via the pointer to avoid
1023 subtle aliasing problems with non-addressable entities.
1024 They have to be stable because we must not evaluate the
1025 variables in the expression every time the renaming is used.
1026 The pointer is called a "renaming" pointer in this case.
1028 In the rare cases where we cannot stabilize the renamed
1029 object, we just make a "bare" pointer, and the renamed
1030 entity is always accessed indirectly through it. */
1033 gnu_type = build_reference_type (gnu_type);
1034 inner_const_flag = TREE_READONLY (gnu_expr);
1037 /* If the previous attempt at stabilizing failed, there
1038 is no point in trying again and we reuse the result
1039 without attaching it to the pointer. In this case it
1040 will only be used as the initializing expression of
1041 the pointer and thus needs no special treatment with
1042 regard to multiple evaluations. */
1043 if (maybe_stable_expr)
1046 /* Otherwise, try to stabilize and attach the expression
1047 to the pointer if the stabilization succeeds.
1049 Note that this might introduce SAVE_EXPRs and we don't
1050 check whether we're at the global level or not. This
1051 is fine since we are building a pointer initializer and
1052 neither the pointer nor the initializing expression can
1053 be accessed before the pointer elaboration has taken
1054 place in a correct program.
1056 These SAVE_EXPRs will be evaluated at the right place
1057 by either the evaluation of the initializer for the
1058 non-global case or the elaboration code for the global
1059 case, and will be attached to the elaboration procedure
1060 in the latter case. */
1064 = gnat_stabilize_reference (gnu_expr, true, &stable);
1067 renamed_obj = maybe_stable_expr;
1069 /* Attaching is actually performed downstream, as soon
1070 as we have a VAR_DECL for the pointer we make. */
1073 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type,
1076 gnu_size = NULL_TREE;
1082 /* Make a volatile version of this object's type if we are to make
1083 the object volatile. We also interpret 13.3(19) conservatively
1084 and disallow any optimizations for such a non-constant object. */
1085 if ((Treat_As_Volatile (gnat_entity)
1087 && gnu_type != except_type_node
1088 && (Is_Exported (gnat_entity)
1090 || Present (Address_Clause (gnat_entity)))))
1091 && !TYPE_VOLATILE (gnu_type))
1092 gnu_type = build_qualified_type (gnu_type,
1093 (TYPE_QUALS (gnu_type)
1094 | TYPE_QUAL_VOLATILE));
1096 /* If we are defining an aliased object whose nominal subtype is
1097 unconstrained, the object is a record that contains both the
1098 template and the object. If there is an initializer, it will
1099 have already been converted to the right type, but we need to
1100 create the template if there is no initializer. */
1103 && TREE_CODE (gnu_type) == RECORD_TYPE
1104 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1105 /* Beware that padding might have been introduced above. */
1106 || (TYPE_PADDING_P (gnu_type)
1107 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1109 && TYPE_CONTAINS_TEMPLATE_P
1110 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1113 = TYPE_PADDING_P (gnu_type)
1114 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1115 : TYPE_FIELDS (gnu_type);
1116 VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
1117 tree t = build_template (TREE_TYPE (template_field),
1118 TREE_TYPE (DECL_CHAIN (template_field)),
1120 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1121 gnu_expr = gnat_build_constructor (gnu_type, v);
1124 /* Convert the expression to the type of the object except in the
1125 case where the object's type is unconstrained or the object's type
1126 is a padded record whose field is of self-referential size. In
1127 the former case, converting will generate unnecessary evaluations
1128 of the CONSTRUCTOR to compute the size and in the latter case, we
1129 want to only copy the actual data. */
1131 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1132 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1133 && !(TYPE_IS_PADDING_P (gnu_type)
1134 && CONTAINS_PLACEHOLDER_P
1135 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1136 gnu_expr = convert (gnu_type, gnu_expr);
1138 /* If this is a pointer that doesn't have an initializing expression,
1139 initialize it to NULL, unless the object is imported. */
1141 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1143 && !Is_Imported (gnat_entity))
1144 gnu_expr = integer_zero_node;
1146 /* If we are defining the object and it has an Address clause, we must
1147 either get the address expression from the saved GCC tree for the
1148 object if it has a Freeze node, or elaborate the address expression
1149 here since the front-end has guaranteed that the elaboration has no
1150 effects in this case. */
1151 if (definition && Present (Address_Clause (gnat_entity)))
1153 Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1155 = present_gnu_tree (gnat_entity)
1156 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1158 save_gnu_tree (gnat_entity, NULL_TREE, false);
1160 /* Ignore the size. It's either meaningless or was handled
1162 gnu_size = NULL_TREE;
1163 /* Convert the type of the object to a reference type that can
1164 alias everything as per 13.3(19). */
1166 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1167 gnu_address = convert (gnu_type, gnu_address);
1170 = !Is_Public (gnat_entity)
1171 || compile_time_known_address_p (gnat_expr);
1173 /* If this is a deferred constant, the initializer is attached to
1175 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1178 (Expression (Declaration_Node (Full_View (gnat_entity))));
1180 /* If we don't have an initializing expression for the underlying
1181 variable, the initializing expression for the pointer is the
1182 specified address. Otherwise, we have to make a COMPOUND_EXPR
1183 to assign both the address and the initial value. */
1185 gnu_expr = gnu_address;
1188 = build2 (COMPOUND_EXPR, gnu_type,
1190 (MODIFY_EXPR, NULL_TREE,
1191 build_unary_op (INDIRECT_REF, NULL_TREE,
1197 /* If it has an address clause and we are not defining it, mark it
1198 as an indirect object. Likewise for Stdcall objects that are
1200 if ((!definition && Present (Address_Clause (gnat_entity)))
1201 || (Is_Imported (gnat_entity)
1202 && Has_Stdcall_Convention (gnat_entity)))
1204 /* Convert the type of the object to a reference type that can
1205 alias everything as per 13.3(19). */
1207 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1208 gnu_size = NULL_TREE;
1210 /* No point in taking the address of an initializing expression
1211 that isn't going to be used. */
1212 gnu_expr = NULL_TREE;
1214 /* If it has an address clause whose value is known at compile
1215 time, make the object a CONST_DECL. This will avoid a
1216 useless dereference. */
1217 if (Present (Address_Clause (gnat_entity)))
1219 Node_Id gnat_address
1220 = Expression (Address_Clause (gnat_entity));
1222 if (compile_time_known_address_p (gnat_address))
1224 gnu_expr = gnat_to_gnu (gnat_address);
1232 /* If we are at top level and this object is of variable size,
1233 make the actual type a hidden pointer to the real type and
1234 make the initializer be a memory allocation and initialization.
1235 Likewise for objects we aren't defining (presumed to be
1236 external references from other packages), but there we do
1237 not set up an initialization.
1239 If the object's size overflows, make an allocator too, so that
1240 Storage_Error gets raised. Note that we will never free
1241 such memory, so we presume it never will get allocated. */
1242 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1243 global_bindings_p ()
1246 || (gnu_size && !allocatable_size_p (gnu_size,
1247 global_bindings_p ()
1251 gnu_type = build_reference_type (gnu_type);
1252 gnu_size = NULL_TREE;
1255 /* In case this was a aliased object whose nominal subtype is
1256 unconstrained, the pointer above will be a thin pointer and
1257 build_allocator will automatically make the template.
1259 If we have a template initializer only (that we made above),
1260 pretend there is none and rely on what build_allocator creates
1261 again anyway. Otherwise (if we have a full initializer), get
1262 the data part and feed that to build_allocator.
1264 If we are elaborating a mutable object, tell build_allocator to
1265 ignore a possibly simpler size from the initializer, if any, as
1266 we must allocate the maximum possible size in this case. */
1267 if (definition && !imported_p)
1269 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1271 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1272 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1275 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1277 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1278 && 1 == VEC_length (constructor_elt,
1279 CONSTRUCTOR_ELTS (gnu_expr)))
1283 = build_component_ref
1284 (gnu_expr, NULL_TREE,
1285 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1289 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1290 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)))
1291 post_error ("?`Storage_Error` will be raised at run time!",
1295 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1296 Empty, Empty, gnat_entity, mutable_p);
1301 gnu_expr = NULL_TREE;
1306 /* If this object would go into the stack and has an alignment larger
1307 than the largest stack alignment the back-end can honor, resort to
1308 a variable of "aligning type". */
1309 if (!global_bindings_p () && !static_p && definition
1310 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1312 /* Create the new variable. No need for extra room before the
1313 aligned field as this is in automatic storage. */
1315 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1316 TYPE_SIZE_UNIT (gnu_type),
1317 BIGGEST_ALIGNMENT, 0);
1319 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1320 NULL_TREE, gnu_new_type, NULL_TREE, false,
1321 false, false, false, NULL, gnat_entity);
1323 /* Initialize the aligned field if we have an initializer. */
1326 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1328 (gnu_new_var, NULL_TREE,
1329 TYPE_FIELDS (gnu_new_type), false),
1333 /* And setup this entity as a reference to the aligned field. */
1334 gnu_type = build_reference_type (gnu_type);
1337 (ADDR_EXPR, gnu_type,
1338 build_component_ref (gnu_new_var, NULL_TREE,
1339 TYPE_FIELDS (gnu_new_type), false));
1341 gnu_size = NULL_TREE;
1347 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1348 | TYPE_QUAL_CONST));
1350 /* Convert the expression to the type of the object except in the
1351 case where the object's type is unconstrained or the object's type
1352 is a padded record whose field is of self-referential size. In
1353 the former case, converting will generate unnecessary evaluations
1354 of the CONSTRUCTOR to compute the size and in the latter case, we
1355 want to only copy the actual data. */
1357 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1358 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1359 && !(TYPE_IS_PADDING_P (gnu_type)
1360 && CONTAINS_PLACEHOLDER_P
1361 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1362 gnu_expr = convert (gnu_type, gnu_expr);
1364 /* If this name is external or there was a name specified, use it,
1365 unless this is a VMS exception object since this would conflict
1366 with the symbol we need to export in addition. Don't use the
1367 Interface_Name if there is an address clause (see CD30005). */
1368 if (!Is_VMS_Exception (gnat_entity)
1369 && ((Present (Interface_Name (gnat_entity))
1370 && No (Address_Clause (gnat_entity)))
1371 || (Is_Public (gnat_entity)
1372 && (!Is_Imported (gnat_entity)
1373 || Is_Exported (gnat_entity)))))
1374 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1376 /* If this is an aggregate constant initialized to a constant, force it
1377 to be statically allocated. This saves an initialization copy. */
1380 && gnu_expr && TREE_CONSTANT (gnu_expr)
1381 && AGGREGATE_TYPE_P (gnu_type)
1382 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1383 && !(TYPE_IS_PADDING_P (gnu_type)
1384 && !host_integerp (TYPE_SIZE_UNIT
1385 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1388 /* Now create the variable or the constant and set various flags. */
1390 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1391 gnu_expr, const_flag, Is_Public (gnat_entity),
1392 imported_p || !definition, static_p, attr_list,
1394 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1395 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1397 /* If we are defining an Out parameter and optimization isn't enabled,
1398 create a fake PARM_DECL for debugging purposes and make it point to
1399 the VAR_DECL. Suppress debug info for the latter but make sure it
1400 will live on the stack so that it can be accessed from within the
1401 debugger through the PARM_DECL. */
1402 if (kind == E_Out_Parameter && definition && !optimize && debug_info_p)
1404 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1405 gnat_pushdecl (param, gnat_entity);
1406 SET_DECL_VALUE_EXPR (param, gnu_decl);
1407 DECL_HAS_VALUE_EXPR_P (param) = 1;
1408 DECL_IGNORED_P (gnu_decl) = 1;
1409 TREE_ADDRESSABLE (gnu_decl) = 1;
1412 /* If this is a renaming pointer, attach the renamed object to it and
1413 register it if we are at the global level. Note that an external
1414 constant is at the global level. */
1415 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1417 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1418 if ((!definition && kind == E_Constant) || global_bindings_p ())
1420 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1421 record_global_renaming_pointer (gnu_decl);
1425 /* If this is a constant and we are defining it or it generates a real
1426 symbol at the object level and we are referencing it, we may want
1427 or need to have a true variable to represent it:
1428 - if optimization isn't enabled, for debugging purposes,
1429 - if the constant is public and not overlaid on something else,
1430 - if its address is taken,
1431 - if either itself or its type is aliased. */
1432 if (TREE_CODE (gnu_decl) == CONST_DECL
1433 && (definition || Sloc (gnat_entity) > Standard_Location)
1434 && ((!optimize && debug_info_p)
1435 || (Is_Public (gnat_entity)
1436 && No (Address_Clause (gnat_entity)))
1437 || Address_Taken (gnat_entity)
1438 || Is_Aliased (gnat_entity)
1439 || Is_Aliased (Etype (gnat_entity))))
1442 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1443 gnu_expr, true, Is_Public (gnat_entity),
1444 !definition, static_p, attr_list,
1447 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1449 /* As debugging information will be generated for the variable,
1450 do not generate debugging information for the constant. */
1452 DECL_IGNORED_P (gnu_decl) = 1;
1454 DECL_IGNORED_P (gnu_corr_var) = 1;
1457 /* If this is a constant, even if we don't need a true variable, we
1458 may need to avoid returning the initializer in every case. That
1459 can happen for the address of a (constant) constructor because,
1460 upon dereferencing it, the constructor will be reinjected in the
1461 tree, which may not be valid in every case; see lvalue_required_p
1462 for more details. */
1463 if (TREE_CODE (gnu_decl) == CONST_DECL)
1464 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1466 /* If this object is declared in a block that contains a block with an
1467 exception handler, and we aren't using the GCC exception mechanism,
1468 we must force this variable in memory in order to avoid an invalid
1470 if (Exception_Mechanism != Back_End_Exceptions
1471 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1472 TREE_ADDRESSABLE (gnu_decl) = 1;
1474 /* If we are defining an object with variable size or an object with
1475 fixed size that will be dynamically allocated, and we are using the
1476 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1478 && Exception_Mechanism == Setjmp_Longjmp
1479 && get_block_jmpbuf_decl ()
1480 && DECL_SIZE_UNIT (gnu_decl)
1481 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1482 || (flag_stack_check == GENERIC_STACK_CHECK
1483 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1484 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1485 add_stmt_with_node (build_call_1_expr
1486 (update_setjmp_buf_decl,
1487 build_unary_op (ADDR_EXPR, NULL_TREE,
1488 get_block_jmpbuf_decl ())),
1491 /* Back-annotate Esize and Alignment of the object if not already
1492 known. Note that we pick the values of the type, not those of
1493 the object, to shield ourselves from low-level platform-dependent
1494 adjustments like alignment promotion. This is both consistent with
1495 all the treatment above, where alignment and size are set on the
1496 type of the object and not on the object directly, and makes it
1497 possible to support all confirming representation clauses. */
1498 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1499 used_by_ref, false);
1504 /* Return a TYPE_DECL for "void" that we previously made. */
1505 gnu_decl = TYPE_NAME (void_type_node);
1508 case E_Enumeration_Type:
1509 /* A special case: for the types Character and Wide_Character in
1510 Standard, we do not list all the literals. So if the literals
1511 are not specified, make this an unsigned type. */
1512 if (No (First_Literal (gnat_entity)))
1514 gnu_type = make_unsigned_type (esize);
1515 TYPE_NAME (gnu_type) = gnu_entity_name;
1517 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1518 This is needed by the DWARF-2 back-end to distinguish between
1519 unsigned integer types and character types. */
1520 TYPE_STRING_FLAG (gnu_type) = 1;
1525 /* We have a list of enumeral constants in First_Literal. We make a
1526 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1527 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1528 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1529 value of the literal. But when we have a regular boolean type, we
1530 simplify this a little by using a BOOLEAN_TYPE. */
1531 bool is_boolean = Is_Boolean_Type (gnat_entity)
1532 && !Has_Non_Standard_Rep (gnat_entity);
1533 tree gnu_literal_list = NULL_TREE;
1534 Entity_Id gnat_literal;
1536 if (Is_Unsigned_Type (gnat_entity))
1537 gnu_type = make_unsigned_type (esize);
1539 gnu_type = make_signed_type (esize);
1541 TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1543 for (gnat_literal = First_Literal (gnat_entity);
1544 Present (gnat_literal);
1545 gnat_literal = Next_Literal (gnat_literal))
1548 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1550 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1551 gnu_type, gnu_value, true, false, false,
1552 false, NULL, gnat_literal);
1553 /* Do not generate debug info for individual enumerators. */
1554 DECL_IGNORED_P (gnu_literal) = 1;
1555 save_gnu_tree (gnat_literal, gnu_literal, false);
1556 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1557 gnu_value, gnu_literal_list);
1561 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1563 /* Note that the bounds are updated at the end of this function
1564 to avoid an infinite recursion since they refer to the type. */
1568 case E_Signed_Integer_Type:
1569 case E_Ordinary_Fixed_Point_Type:
1570 case E_Decimal_Fixed_Point_Type:
1571 /* For integer types, just make a signed type the appropriate number
1573 gnu_type = make_signed_type (esize);
1576 case E_Modular_Integer_Type:
1578 /* For modular types, make the unsigned type of the proper number
1579 of bits and then set up the modulus, if required. */
1580 tree gnu_modulus, gnu_high = NULL_TREE;
1582 /* Packed array types are supposed to be subtypes only. */
1583 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1585 gnu_type = make_unsigned_type (esize);
1587 /* Get the modulus in this type. If it overflows, assume it is because
1588 it is equal to 2**Esize. Note that there is no overflow checking
1589 done on unsigned type, so we detect the overflow by looking for
1590 a modulus of zero, which is otherwise invalid. */
1591 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1593 if (!integer_zerop (gnu_modulus))
1595 TYPE_MODULAR_P (gnu_type) = 1;
1596 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1597 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1598 convert (gnu_type, integer_one_node));
1601 /* If the upper bound is not maximal, make an extra subtype. */
1603 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1605 tree gnu_subtype = make_unsigned_type (esize);
1606 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1607 TREE_TYPE (gnu_subtype) = gnu_type;
1608 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1609 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1610 gnu_type = gnu_subtype;
1615 case E_Signed_Integer_Subtype:
1616 case E_Enumeration_Subtype:
1617 case E_Modular_Integer_Subtype:
1618 case E_Ordinary_Fixed_Point_Subtype:
1619 case E_Decimal_Fixed_Point_Subtype:
1621 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1622 not want to call create_range_type since we would like each subtype
1623 node to be distinct. ??? Historically this was in preparation for
1624 when memory aliasing is implemented, but that's obsolete now given
1625 the call to relate_alias_sets below.
1627 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1628 this fact is used by the arithmetic conversion functions.
1630 We elaborate the Ancestor_Subtype if it is not in the current unit
1631 and one of our bounds is non-static. We do this to ensure consistent
1632 naming in the case where several subtypes share the same bounds, by
1633 elaborating the first such subtype first, thus using its name. */
1636 && Present (Ancestor_Subtype (gnat_entity))
1637 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1638 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1639 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1640 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1642 /* Set the precision to the Esize except for bit-packed arrays. */
1643 if (Is_Packed_Array_Type (gnat_entity)
1644 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1645 esize = UI_To_Int (RM_Size (gnat_entity));
1647 /* This should be an unsigned type if the base type is unsigned or
1648 if the lower bound is constant and non-negative or if the type
1650 if (Is_Unsigned_Type (Etype (gnat_entity))
1651 || Is_Unsigned_Type (gnat_entity)
1652 || Has_Biased_Representation (gnat_entity))
1653 gnu_type = make_unsigned_type (esize);
1655 gnu_type = make_signed_type (esize);
1656 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1658 SET_TYPE_RM_MIN_VALUE
1660 convert (TREE_TYPE (gnu_type),
1661 elaborate_expression (Type_Low_Bound (gnat_entity),
1662 gnat_entity, get_identifier ("L"),
1664 Needs_Debug_Info (gnat_entity))));
1666 SET_TYPE_RM_MAX_VALUE
1668 convert (TREE_TYPE (gnu_type),
1669 elaborate_expression (Type_High_Bound (gnat_entity),
1670 gnat_entity, get_identifier ("U"),
1672 Needs_Debug_Info (gnat_entity))));
1674 /* One of the above calls might have caused us to be elaborated,
1675 so don't blow up if so. */
1676 if (present_gnu_tree (gnat_entity))
1678 maybe_present = true;
1682 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1683 = Has_Biased_Representation (gnat_entity);
1685 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1686 TYPE_STUB_DECL (gnu_type)
1687 = create_type_stub_decl (gnu_entity_name, gnu_type);
1689 /* Inherit our alias set from what we're a subtype of. Subtypes
1690 are not different types and a pointer can designate any instance
1691 within a subtype hierarchy. */
1692 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1694 /* For a packed array, make the original array type a parallel type. */
1696 && Is_Packed_Array_Type (gnat_entity)
1697 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1698 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1700 (Original_Array_Type (gnat_entity)));
1704 /* We have to handle clauses that under-align the type specially. */
1705 if ((Present (Alignment_Clause (gnat_entity))
1706 || (Is_Packed_Array_Type (gnat_entity)
1708 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1709 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1711 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1712 if (align >= TYPE_ALIGN (gnu_type))
1716 /* If the type we are dealing with represents a bit-packed array,
1717 we need to have the bits left justified on big-endian targets
1718 and right justified on little-endian targets. We also need to
1719 ensure that when the value is read (e.g. for comparison of two
1720 such values), we only get the good bits, since the unused bits
1721 are uninitialized. Both goals are accomplished by wrapping up
1722 the modular type in an enclosing record type. */
1723 if (Is_Packed_Array_Type (gnat_entity)
1724 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1726 tree gnu_field_type, gnu_field;
1728 /* Set the RM size before wrapping up the original type. */
1729 SET_TYPE_RM_SIZE (gnu_type,
1730 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1731 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1733 /* Create a stripped-down declaration, mainly for debugging. */
1734 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1735 debug_info_p, gnat_entity);
1737 /* Now save it and build the enclosing record type. */
1738 gnu_field_type = gnu_type;
1740 gnu_type = make_node (RECORD_TYPE);
1741 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1742 TYPE_PACKED (gnu_type) = 1;
1743 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1744 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1745 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1747 /* Propagate the alignment of the modular type to the record type,
1748 unless there is an alignment clause that under-aligns the type.
1749 This means that bit-packed arrays are given "ceil" alignment for
1750 their size by default, which may seem counter-intuitive but makes
1751 it possible to overlay them on modular types easily. */
1752 TYPE_ALIGN (gnu_type)
1753 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1755 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1757 /* Don't declare the field as addressable since we won't be taking
1758 its address and this would prevent create_field_decl from making
1761 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1762 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1764 /* Do not emit debug info until after the parallel type is added. */
1765 finish_record_type (gnu_type, gnu_field, 2, false);
1766 compute_record_mode (gnu_type);
1767 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1771 /* Make the original array type a parallel type. */
1772 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1773 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1775 (Original_Array_Type (gnat_entity)));
1777 rest_of_record_type_compilation (gnu_type);
1781 /* If the type we are dealing with has got a smaller alignment than the
1782 natural one, we need to wrap it up in a record type and under-align
1783 the latter. We reuse the padding machinery for this purpose. */
1786 tree gnu_field_type, gnu_field;
1788 /* Set the RM size before wrapping up the type. */
1789 SET_TYPE_RM_SIZE (gnu_type,
1790 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1792 /* Create a stripped-down declaration, mainly for debugging. */
1793 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1794 debug_info_p, gnat_entity);
1796 /* Now save it and build the enclosing record type. */
1797 gnu_field_type = gnu_type;
1799 gnu_type = make_node (RECORD_TYPE);
1800 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1801 TYPE_PACKED (gnu_type) = 1;
1802 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1803 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1804 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1805 TYPE_ALIGN (gnu_type) = align;
1806 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1808 /* Don't declare the field as addressable since we won't be taking
1809 its address and this would prevent create_field_decl from making
1812 = create_field_decl (get_identifier ("F"), gnu_field_type,
1813 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1815 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1816 compute_record_mode (gnu_type);
1817 TYPE_PADDING_P (gnu_type) = 1;
1822 case E_Floating_Point_Type:
1823 /* If this is a VAX floating-point type, use an integer of the proper
1824 size. All the operations will be handled with ASM statements. */
1825 if (Vax_Float (gnat_entity))
1827 gnu_type = make_signed_type (esize);
1828 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1829 SET_TYPE_DIGITS_VALUE (gnu_type,
1830 UI_To_gnu (Digits_Value (gnat_entity),
1835 /* The type of the Low and High bounds can be our type if this is
1836 a type from Standard, so set them at the end of the function. */
1837 gnu_type = make_node (REAL_TYPE);
1838 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1839 layout_type (gnu_type);
1842 case E_Floating_Point_Subtype:
1843 if (Vax_Float (gnat_entity))
1845 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1851 && Present (Ancestor_Subtype (gnat_entity))
1852 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1853 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1854 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1855 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1858 gnu_type = make_node (REAL_TYPE);
1859 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1860 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1861 TYPE_GCC_MIN_VALUE (gnu_type)
1862 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1863 TYPE_GCC_MAX_VALUE (gnu_type)
1864 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1865 layout_type (gnu_type);
1867 SET_TYPE_RM_MIN_VALUE
1869 convert (TREE_TYPE (gnu_type),
1870 elaborate_expression (Type_Low_Bound (gnat_entity),
1871 gnat_entity, get_identifier ("L"),
1873 Needs_Debug_Info (gnat_entity))));
1875 SET_TYPE_RM_MAX_VALUE
1877 convert (TREE_TYPE (gnu_type),
1878 elaborate_expression (Type_High_Bound (gnat_entity),
1879 gnat_entity, get_identifier ("U"),
1881 Needs_Debug_Info (gnat_entity))));
1883 /* One of the above calls might have caused us to be elaborated,
1884 so don't blow up if so. */
1885 if (present_gnu_tree (gnat_entity))
1887 maybe_present = true;
1891 /* Inherit our alias set from what we're a subtype of, as for
1892 integer subtypes. */
1893 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1897 /* Array and String Types and Subtypes
1899 Unconstrained array types are represented by E_Array_Type and
1900 constrained array types are represented by E_Array_Subtype. There
1901 are no actual objects of an unconstrained array type; all we have
1902 are pointers to that type.
1904 The following fields are defined on array types and subtypes:
1906 Component_Type Component type of the array.
1907 Number_Dimensions Number of dimensions (an int).
1908 First_Index Type of first index. */
1913 const bool convention_fortran_p
1914 = (Convention (gnat_entity) == Convention_Fortran);
1915 const int ndim = Number_Dimensions (gnat_entity);
1916 tree gnu_template_type = make_node (RECORD_TYPE);
1917 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1918 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
1919 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
1920 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
1921 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
1922 Entity_Id gnat_index, gnat_name;
1925 /* We complete an existing dummy fat pointer type in place. This both
1926 avoids further complex adjustments in update_pointer_to and yields
1927 better debugging information in DWARF by leveraging the support for
1928 incomplete declarations of "tagged" types in the DWARF back-end. */
1929 gnu_type = get_dummy_type (gnat_entity);
1930 if (gnu_type && TYPE_POINTER_TO (gnu_type))
1932 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
1933 TYPE_NAME (gnu_fat_type) = NULL_TREE;
1934 /* Save the contents of the dummy type for update_pointer_to. */
1935 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
1938 gnu_fat_type = make_node (RECORD_TYPE);
1940 /* Make a node for the array. If we are not defining the array
1941 suppress expanding incomplete types. */
1942 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1946 defer_incomplete_level++;
1947 this_deferred = true;
1950 /* Build the fat pointer type. Use a "void *" object instead of
1951 a pointer to the array type since we don't have the array type
1952 yet (it will reference the fat pointer via the bounds). */
1954 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
1955 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1957 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
1958 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
1960 if (COMPLETE_TYPE_P (gnu_fat_type))
1962 /* We are going to lay it out again so reset the alias set. */
1963 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
1964 TYPE_ALIAS_SET (gnu_fat_type) = -1;
1965 finish_fat_pointer_type (gnu_fat_type, tem);
1966 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
1967 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
1969 TYPE_FIELDS (t) = tem;
1970 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
1975 finish_fat_pointer_type (gnu_fat_type, tem);
1976 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1979 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1980 is the fat pointer. This will be used to access the individual
1981 fields once we build them. */
1982 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1983 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1984 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1985 gnu_template_reference
1986 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1987 TREE_READONLY (gnu_template_reference) = 1;
1989 /* Now create the GCC type for each index and add the fields for that
1990 index to the template. */
1991 for (index = (convention_fortran_p ? ndim - 1 : 0),
1992 gnat_index = First_Index (gnat_entity);
1993 0 <= index && index < ndim;
1994 index += (convention_fortran_p ? - 1 : 1),
1995 gnat_index = Next_Index (gnat_index))
1997 char field_name[16];
1998 tree gnu_index_base_type
1999 = get_unpadded_type (Base_Type (Etype (gnat_index)));
2000 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2001 tree gnu_min, gnu_max, gnu_high;
2003 /* Make the FIELD_DECLs for the low and high bounds of this
2004 type and then make extractions of these fields from the
2006 sprintf (field_name, "LB%d", index);
2007 gnu_lb_field = create_field_decl (get_identifier (field_name),
2008 gnu_index_base_type,
2009 gnu_template_type, NULL_TREE,
2011 Sloc_to_locus (Sloc (gnat_entity),
2012 &DECL_SOURCE_LOCATION (gnu_lb_field));
2014 field_name[0] = 'U';
2015 gnu_hb_field = create_field_decl (get_identifier (field_name),
2016 gnu_index_base_type,
2017 gnu_template_type, NULL_TREE,
2019 Sloc_to_locus (Sloc (gnat_entity),
2020 &DECL_SOURCE_LOCATION (gnu_hb_field));
2022 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2024 /* We can't use build_component_ref here since the template type
2025 isn't complete yet. */
2026 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2027 gnu_template_reference, gnu_lb_field,
2029 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2030 gnu_template_reference, gnu_hb_field,
2032 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2034 gnu_min = convert (sizetype, gnu_orig_min);
2035 gnu_max = convert (sizetype, gnu_orig_max);
2037 /* Compute the size of this dimension. See the E_Array_Subtype
2038 case below for the rationale. */
2040 = build3 (COND_EXPR, sizetype,
2041 build2 (GE_EXPR, boolean_type_node,
2042 gnu_orig_max, gnu_orig_min),
2044 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2046 /* Make a range type with the new range in the Ada base type.
2047 Then make an index type with the size range in sizetype. */
2048 gnu_index_types[index]
2049 = create_index_type (gnu_min, gnu_high,
2050 create_range_type (gnu_index_base_type,
2055 /* Update the maximum size of the array in elements. */
2058 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2060 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2062 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2064 = size_binop (MAX_EXPR,
2065 size_binop (PLUS_EXPR, size_one_node,
2066 size_binop (MINUS_EXPR,
2070 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2071 && TREE_OVERFLOW (gnu_this_max))
2072 gnu_max_size = NULL_TREE;
2075 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2078 TYPE_NAME (gnu_index_types[index])
2079 = create_concat_name (gnat_entity, field_name);
2082 /* Install all the fields into the template. */
2083 TYPE_NAME (gnu_template_type)
2084 = create_concat_name (gnat_entity, "XUB");
2085 gnu_template_fields = NULL_TREE;
2086 for (index = 0; index < ndim; index++)
2088 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2089 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2091 TYPE_READONLY (gnu_template_type) = 1;
2093 /* Now make the array of arrays and update the pointer to the array
2094 in the fat pointer. Note that it is the first field. */
2096 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2098 /* If Component_Size is not already specified, annotate it with the
2099 size of the component. */
2100 if (Unknown_Component_Size (gnat_entity))
2101 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
2103 /* Compute the maximum size of the array in units and bits. */
2106 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2107 TYPE_SIZE_UNIT (tem));
2108 gnu_max_size = size_binop (MULT_EXPR,
2109 convert (bitsizetype, gnu_max_size),
2113 gnu_max_size_unit = NULL_TREE;
2115 /* Now build the array type. */
2116 for (index = ndim - 1; index >= 0; index--)
2118 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2119 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2120 if (array_type_has_nonaliased_component (tem, gnat_entity))
2121 TYPE_NONALIASED_COMPONENT (tem) = 1;
2124 /* If an alignment is specified, use it if valid. But ignore it
2125 for the original type of packed array types. If the alignment
2126 was requested with an explicit alignment clause, state so. */
2127 if (No (Packed_Array_Type (gnat_entity))
2128 && Known_Alignment (gnat_entity))
2131 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2133 if (Present (Alignment_Clause (gnat_entity)))
2134 TYPE_USER_ALIGN (tem) = 1;
2137 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2139 /* Adjust the type of the pointer-to-array field of the fat pointer
2140 and record the aliasing relationships if necessary. */
2141 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2142 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2143 record_component_aliases (gnu_fat_type);
2145 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2146 corresponding fat pointer. */
2147 TREE_TYPE (gnu_type) = gnu_fat_type;
2148 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2149 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2150 SET_TYPE_MODE (gnu_type, BLKmode);
2151 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2153 /* If the maximum size doesn't overflow, use it. */
2155 && TREE_CODE (gnu_max_size) == INTEGER_CST
2156 && !TREE_OVERFLOW (gnu_max_size)
2157 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2158 && !TREE_OVERFLOW (gnu_max_size_unit))
2160 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2162 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2163 TYPE_SIZE_UNIT (tem));
2166 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2167 tem, NULL, !Comes_From_Source (gnat_entity),
2168 debug_info_p, gnat_entity);
2170 /* Give the fat pointer type a name. If this is a packed type, tell
2171 the debugger how to interpret the underlying bits. */
2172 if (Present (Packed_Array_Type (gnat_entity)))
2173 gnat_name = Packed_Array_Type (gnat_entity);
2175 gnat_name = gnat_entity;
2176 create_type_decl (create_concat_name (gnat_name, "XUP"),
2177 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2178 debug_info_p, gnat_entity);
2180 /* Create the type to be used as what a thin pointer designates:
2181 a record type for the object and its template with the fields
2182 shifted to have the template at a negative offset. */
2183 tem = build_unc_object_type (gnu_template_type, tem,
2184 create_concat_name (gnat_name, "XUT"),
2186 shift_unc_components_for_thin_pointers (tem);
2188 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2189 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2193 case E_String_Subtype:
2194 case E_Array_Subtype:
2196 /* This is the actual data type for array variables. Multidimensional
2197 arrays are implemented as arrays of arrays. Note that arrays which
2198 have sparse enumeration subtypes as index components create sparse
2199 arrays, which is obviously space inefficient but so much easier to
2202 Also note that the subtype never refers to the unconstrained array
2203 type, which is somewhat at variance with Ada semantics.
2205 First check to see if this is simply a renaming of the array type.
2206 If so, the result is the array type. */
2208 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2209 if (!Is_Constrained (gnat_entity))
2213 Entity_Id gnat_index, gnat_base_index;
2214 const bool convention_fortran_p
2215 = (Convention (gnat_entity) == Convention_Fortran);
2216 const int ndim = Number_Dimensions (gnat_entity);
2217 tree gnu_base_type = gnu_type;
2218 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2219 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2220 bool need_index_type_struct = false;
2223 /* First create the GCC type for each index and find out whether
2224 special types are needed for debugging information. */
2225 for (index = (convention_fortran_p ? ndim - 1 : 0),
2226 gnat_index = First_Index (gnat_entity),
2228 = First_Index (Implementation_Base_Type (gnat_entity));
2229 0 <= index && index < ndim;
2230 index += (convention_fortran_p ? - 1 : 1),
2231 gnat_index = Next_Index (gnat_index),
2232 gnat_base_index = Next_Index (gnat_base_index))
2234 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2235 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2236 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2237 tree gnu_min = convert (sizetype, gnu_orig_min);
2238 tree gnu_max = convert (sizetype, gnu_orig_max);
2239 tree gnu_base_index_type
2240 = get_unpadded_type (Etype (gnat_base_index));
2241 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2242 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2245 /* See if the base array type is already flat. If it is, we
2246 are probably compiling an ACATS test but it will cause the
2247 code below to malfunction if we don't handle it specially. */
2248 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2249 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2250 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2252 gnu_min = size_one_node;
2253 gnu_max = size_zero_node;
2257 /* Similarly, if one of the values overflows in sizetype and the
2258 range is null, use 1..0 for the sizetype bounds. */
2259 else if (TREE_CODE (gnu_min) == INTEGER_CST
2260 && TREE_CODE (gnu_max) == INTEGER_CST
2261 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2262 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2264 gnu_min = size_one_node;
2265 gnu_max = size_zero_node;
2269 /* If the minimum and maximum values both overflow in sizetype,
2270 but the difference in the original type does not overflow in
2271 sizetype, ignore the overflow indication. */
2272 else if (TREE_CODE (gnu_min) == INTEGER_CST
2273 && TREE_CODE (gnu_max) == INTEGER_CST
2274 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2277 fold_build2 (MINUS_EXPR, gnu_index_type,
2281 TREE_OVERFLOW (gnu_min) = 0;
2282 TREE_OVERFLOW (gnu_max) = 0;
2286 /* Compute the size of this dimension in the general case. We
2287 need to provide GCC with an upper bound to use but have to
2288 deal with the "superflat" case. There are three ways to do
2289 this. If we can prove that the array can never be superflat,
2290 we can just use the high bound of the index type. */
2291 else if ((Nkind (gnat_index) == N_Range
2292 && cannot_be_superflat_p (gnat_index))
2293 /* Packed Array Types are never superflat. */
2294 || Is_Packed_Array_Type (gnat_entity))
2297 /* Otherwise, if the high bound is constant but the low bound is
2298 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2299 lower bound. Note that the comparison must be done in the
2300 original type to avoid any overflow during the conversion. */
2301 else if (TREE_CODE (gnu_max) == INTEGER_CST
2302 && TREE_CODE (gnu_min) != INTEGER_CST)
2306 = build_cond_expr (sizetype,
2307 build_binary_op (GE_EXPR,
2312 size_binop (PLUS_EXPR, gnu_max,
2316 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2317 in all the other cases. Note that, here as well as above,
2318 the condition used in the comparison must be equivalent to
2319 the condition (length != 0). This is relied upon in order
2320 to optimize array comparisons in compare_arrays. */
2323 = build_cond_expr (sizetype,
2324 build_binary_op (GE_EXPR,
2329 size_binop (MINUS_EXPR, gnu_min,
2332 /* Reuse the index type for the range type. Then make an index
2333 type with the size range in sizetype. */
2334 gnu_index_types[index]
2335 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2338 /* Update the maximum size of the array in elements. Here we
2339 see if any constraint on the index type of the base type
2340 can be used in the case of self-referential bound on the
2341 index type of the subtype. We look for a non-"infinite"
2342 and non-self-referential bound from any type involved and
2343 handle each bound separately. */
2346 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2347 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2348 tree gnu_base_index_base_type
2349 = get_base_type (gnu_base_index_type);
2350 tree gnu_base_base_min
2351 = convert (sizetype,
2352 TYPE_MIN_VALUE (gnu_base_index_base_type));
2353 tree gnu_base_base_max
2354 = convert (sizetype,
2355 TYPE_MAX_VALUE (gnu_base_index_base_type));
2357 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2358 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2359 && !TREE_OVERFLOW (gnu_base_min)))
2360 gnu_base_min = gnu_min;
2362 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2363 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2364 && !TREE_OVERFLOW (gnu_base_max)))
2365 gnu_base_max = gnu_max;
2367 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2368 && TREE_OVERFLOW (gnu_base_min))
2369 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2370 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2371 && TREE_OVERFLOW (gnu_base_max))
2372 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2373 gnu_max_size = NULL_TREE;
2377 = size_binop (MAX_EXPR,
2378 size_binop (PLUS_EXPR, size_one_node,
2379 size_binop (MINUS_EXPR,
2384 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2385 && TREE_OVERFLOW (gnu_this_max))
2386 gnu_max_size = NULL_TREE;
2389 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2393 /* We need special types for debugging information to point to
2394 the index types if they have variable bounds, are not integer
2395 types, are biased or are wider than sizetype. */
2396 if (!integer_onep (gnu_orig_min)
2397 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2398 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2399 || (TREE_TYPE (gnu_index_type)
2400 && TREE_CODE (TREE_TYPE (gnu_index_type))
2402 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2403 || compare_tree_int (rm_size (gnu_index_type),
2404 TYPE_PRECISION (sizetype)) > 0)
2405 need_index_type_struct = true;
2408 /* Then flatten: create the array of arrays. For an array type
2409 used to implement a packed array, get the component type from
2410 the original array type since the representation clauses that
2411 can affect it are on the latter. */
2412 if (Is_Packed_Array_Type (gnat_entity)
2413 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2415 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2416 for (index = ndim - 1; index >= 0; index--)
2417 gnu_type = TREE_TYPE (gnu_type);
2419 /* One of the above calls might have caused us to be elaborated,
2420 so don't blow up if so. */
2421 if (present_gnu_tree (gnat_entity))
2423 maybe_present = true;
2429 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2432 /* One of the above calls might have caused us to be elaborated,
2433 so don't blow up if so. */
2434 if (present_gnu_tree (gnat_entity))
2436 maybe_present = true;
2441 /* Compute the maximum size of the array in units and bits. */
2444 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2445 TYPE_SIZE_UNIT (gnu_type));
2446 gnu_max_size = size_binop (MULT_EXPR,
2447 convert (bitsizetype, gnu_max_size),
2448 TYPE_SIZE (gnu_type));
2451 gnu_max_size_unit = NULL_TREE;
2453 /* Now build the array type. */
2454 for (index = ndim - 1; index >= 0; index --)
2456 gnu_type = build_nonshared_array_type (gnu_type,
2457 gnu_index_types[index]);
2458 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2459 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2460 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2463 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2464 TYPE_STUB_DECL (gnu_type)
2465 = create_type_stub_decl (gnu_entity_name, gnu_type);
2467 /* If we are at file level and this is a multi-dimensional array,
2468 we need to make a variable corresponding to the stride of the
2469 inner dimensions. */
2470 if (global_bindings_p () && ndim > 1)
2472 tree gnu_st_name = get_identifier ("ST");
2475 for (gnu_arr_type = TREE_TYPE (gnu_type);
2476 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2477 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2478 gnu_st_name = concat_name (gnu_st_name, "ST"))
2480 tree eltype = TREE_TYPE (gnu_arr_type);
2482 TYPE_SIZE (gnu_arr_type)
2483 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2484 gnat_entity, gnu_st_name,
2487 /* ??? For now, store the size as a multiple of the
2488 alignment of the element type in bytes so that we
2489 can see the alignment from the tree. */
2490 TYPE_SIZE_UNIT (gnu_arr_type)
2491 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2493 concat_name (gnu_st_name, "A_U"),
2495 TYPE_ALIGN (eltype));
2497 /* ??? create_type_decl is not invoked on the inner types so
2498 the MULT_EXPR node built above will never be marked. */
2499 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2503 /* If we need to write out a record type giving the names of the
2504 bounds for debugging purposes, do it now and make the record
2505 type a parallel type. This is not needed for a packed array
2506 since the bounds are conveyed by the original array type. */
2507 if (need_index_type_struct
2509 && !Is_Packed_Array_Type (gnat_entity))
2511 tree gnu_bound_rec = make_node (RECORD_TYPE);
2512 tree gnu_field_list = NULL_TREE;
2515 TYPE_NAME (gnu_bound_rec)
2516 = create_concat_name (gnat_entity, "XA");
2518 for (index = ndim - 1; index >= 0; index--)
2520 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2521 tree gnu_index_name = TYPE_NAME (gnu_index);
2523 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2524 gnu_index_name = DECL_NAME (gnu_index_name);
2526 /* Make sure to reference the types themselves, and not just
2527 their names, as the debugger may fall back on them. */
2528 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2529 gnu_bound_rec, NULL_TREE,
2531 DECL_CHAIN (gnu_field) = gnu_field_list;
2532 gnu_field_list = gnu_field;
2535 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2536 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2539 /* If this is a packed array type, make the original array type a
2540 parallel type. Otherwise, do it for the base array type if it
2541 isn't artificial to make sure it is kept in the debug info. */
2544 if (Is_Packed_Array_Type (gnat_entity)
2545 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2546 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2548 (Original_Array_Type (gnat_entity)));
2552 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2553 if (!DECL_ARTIFICIAL (gnu_base_decl))
2554 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2555 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2559 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2560 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2561 = (Is_Packed_Array_Type (gnat_entity)
2562 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2564 /* If the size is self-referential and the maximum size doesn't
2565 overflow, use it. */
2566 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2568 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2569 && TREE_OVERFLOW (gnu_max_size))
2570 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2571 && TREE_OVERFLOW (gnu_max_size_unit)))
2573 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2574 TYPE_SIZE (gnu_type));
2575 TYPE_SIZE_UNIT (gnu_type)
2576 = size_binop (MIN_EXPR, gnu_max_size_unit,
2577 TYPE_SIZE_UNIT (gnu_type));
2580 /* Set our alias set to that of our base type. This gives all
2581 array subtypes the same alias set. */
2582 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2584 /* If this is a packed type, make this type the same as the packed
2585 array type, but do some adjusting in the type first. */
2586 if (Present (Packed_Array_Type (gnat_entity)))
2588 Entity_Id gnat_index;
2591 /* First finish the type we had been making so that we output
2592 debugging information for it. */
2593 if (Treat_As_Volatile (gnat_entity))
2595 = build_qualified_type (gnu_type,
2596 TYPE_QUALS (gnu_type)
2597 | TYPE_QUAL_VOLATILE);
2599 /* Make it artificial only if the base type was artificial too.
2600 That's sort of "morally" true and will make it possible for
2601 the debugger to look it up by name in DWARF, which is needed
2602 in order to decode the packed array type. */
2604 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2605 !Comes_From_Source (Etype (gnat_entity))
2606 && !Comes_From_Source (gnat_entity),
2607 debug_info_p, gnat_entity);
2609 /* Save it as our equivalent in case the call below elaborates
2611 save_gnu_tree (gnat_entity, gnu_decl, false);
2613 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2615 this_made_decl = true;
2616 gnu_type = TREE_TYPE (gnu_decl);
2617 save_gnu_tree (gnat_entity, NULL_TREE, false);
2619 gnu_inner = gnu_type;
2620 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2621 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2622 || TYPE_PADDING_P (gnu_inner)))
2623 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2625 /* We need to attach the index type to the type we just made so
2626 that the actual bounds can later be put into a template. */
2627 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2628 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2629 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2630 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2632 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2634 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2635 TYPE_MODULUS for modular types so we make an extra
2636 subtype if necessary. */
2637 if (TYPE_MODULAR_P (gnu_inner))
2640 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2641 TREE_TYPE (gnu_subtype) = gnu_inner;
2642 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2643 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2644 TYPE_MIN_VALUE (gnu_inner));
2645 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2646 TYPE_MAX_VALUE (gnu_inner));
2647 gnu_inner = gnu_subtype;
2650 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2652 #ifdef ENABLE_CHECKING
2653 /* Check for other cases of overloading. */
2654 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2658 for (gnat_index = First_Index (gnat_entity);
2659 Present (gnat_index);
2660 gnat_index = Next_Index (gnat_index))
2661 SET_TYPE_ACTUAL_BOUNDS
2663 tree_cons (NULL_TREE,
2664 get_unpadded_type (Etype (gnat_index)),
2665 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2667 if (Convention (gnat_entity) != Convention_Fortran)
2668 SET_TYPE_ACTUAL_BOUNDS
2669 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2671 if (TREE_CODE (gnu_type) == RECORD_TYPE
2672 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2673 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2678 /* Abort if packed array with no Packed_Array_Type field set. */
2679 gcc_assert (!Is_Packed (gnat_entity));
2683 case E_String_Literal_Subtype:
2684 /* Create the type for a string literal. */
2686 Entity_Id gnat_full_type
2687 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2688 && Present (Full_View (Etype (gnat_entity)))
2689 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2690 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2691 tree gnu_string_array_type
2692 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2693 tree gnu_string_index_type
2694 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2695 (TYPE_DOMAIN (gnu_string_array_type))));
2696 tree gnu_lower_bound
2697 = convert (gnu_string_index_type,
2698 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2699 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2700 tree gnu_length = ssize_int (length - 1);
2701 tree gnu_upper_bound
2702 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2704 convert (gnu_string_index_type, gnu_length));
2706 = create_index_type (convert (sizetype, gnu_lower_bound),
2707 convert (sizetype, gnu_upper_bound),
2708 create_range_type (gnu_string_index_type,
2714 = build_nonshared_array_type (gnat_to_gnu_type
2715 (Component_Type (gnat_entity)),
2717 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2718 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2719 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2723 /* Record Types and Subtypes
2725 The following fields are defined on record types:
2727 Has_Discriminants True if the record has discriminants
2728 First_Discriminant Points to head of list of discriminants
2729 First_Entity Points to head of list of fields
2730 Is_Tagged_Type True if the record is tagged
2732 Implementation of Ada records and discriminated records:
2734 A record type definition is transformed into the equivalent of a C
2735 struct definition. The fields that are the discriminants which are
2736 found in the Full_Type_Declaration node and the elements of the
2737 Component_List found in the Record_Type_Definition node. The
2738 Component_List can be a recursive structure since each Variant of
2739 the Variant_Part of the Component_List has a Component_List.
2741 Processing of a record type definition comprises starting the list of
2742 field declarations here from the discriminants and the calling the
2743 function components_to_record to add the rest of the fields from the
2744 component list and return the gnu type node. The function
2745 components_to_record will call itself recursively as it traverses
2749 if (Has_Complex_Representation (gnat_entity))
2752 = build_complex_type
2754 (Etype (Defining_Entity
2755 (First (Component_Items
2758 (Declaration_Node (gnat_entity)))))))));
2764 Node_Id full_definition = Declaration_Node (gnat_entity);
2765 Node_Id record_definition = Type_Definition (full_definition);
2766 Entity_Id gnat_field;
2767 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2768 /* Set PACKED in keeping with gnat_to_gnu_field. */
2770 = Is_Packed (gnat_entity)
2772 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2774 : (Known_Alignment (gnat_entity)
2775 || (Strict_Alignment (gnat_entity)
2776 && Known_Static_Esize (gnat_entity)))
2779 bool has_discr = Has_Discriminants (gnat_entity);
2780 bool has_rep = Has_Specified_Layout (gnat_entity);
2781 bool all_rep = has_rep;
2783 = (Is_Tagged_Type (gnat_entity)
2784 && Nkind (record_definition) == N_Derived_Type_Definition);
2785 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2787 /* See if all fields have a rep clause. Stop when we find one
2790 for (gnat_field = First_Entity (gnat_entity);
2791 Present (gnat_field);
2792 gnat_field = Next_Entity (gnat_field))
2793 if ((Ekind (gnat_field) == E_Component
2794 || Ekind (gnat_field) == E_Discriminant)
2795 && No (Component_Clause (gnat_field)))
2801 /* If this is a record extension, go a level further to find the
2802 record definition. Also, verify we have a Parent_Subtype. */
2805 if (!type_annotate_only
2806 || Present (Record_Extension_Part (record_definition)))
2807 record_definition = Record_Extension_Part (record_definition);
2809 gcc_assert (type_annotate_only
2810 || Present (Parent_Subtype (gnat_entity)));
2813 /* Make a node for the record. If we are not defining the record,
2814 suppress expanding incomplete types. */
2815 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2816 TYPE_NAME (gnu_type) = gnu_entity_name;
2817 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2821 defer_incomplete_level++;
2822 this_deferred = true;
2825 /* If both a size and rep clause was specified, put the size in
2826 the record type now so that it can get the proper mode. */
2827 if (has_rep && Known_Esize (gnat_entity))
2828 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2830 /* Always set the alignment here so that it can be used to
2831 set the mode, if it is making the alignment stricter. If
2832 it is invalid, it will be checked again below. If this is to
2833 be Atomic, choose a default alignment of a word unless we know
2834 the size and it's smaller. */
2835 if (Known_Alignment (gnat_entity))
2836 TYPE_ALIGN (gnu_type)
2837 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2838 else if (Is_Atomic (gnat_entity))
2839 TYPE_ALIGN (gnu_type)
2840 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2841 /* If a type needs strict alignment, the minimum size will be the
2842 type size instead of the RM size (see validate_size). Cap the
2843 alignment, lest it causes this type size to become too large. */
2844 else if (Strict_Alignment (gnat_entity)
2845 && Known_Static_Esize (gnat_entity))
2847 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2848 unsigned int raw_align = raw_size & -raw_size;
2849 if (raw_align < BIGGEST_ALIGNMENT)
2850 TYPE_ALIGN (gnu_type) = raw_align;
2853 TYPE_ALIGN (gnu_type) = 0;
2855 /* If we have a Parent_Subtype, make a field for the parent. If
2856 this record has rep clauses, force the position to zero. */
2857 if (Present (Parent_Subtype (gnat_entity)))
2859 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2862 /* A major complexity here is that the parent subtype will
2863 reference our discriminants in its Discriminant_Constraint
2864 list. But those must reference the parent component of this
2865 record which is of the parent subtype we have not built yet!
2866 To break the circle we first build a dummy COMPONENT_REF which
2867 represents the "get to the parent" operation and initialize
2868 each of those discriminants to a COMPONENT_REF of the above
2869 dummy parent referencing the corresponding discriminant of the
2870 base type of the parent subtype. */
2871 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2872 build0 (PLACEHOLDER_EXPR, gnu_type),
2873 build_decl (input_location,
2874 FIELD_DECL, NULL_TREE,
2879 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2880 Present (gnat_field);
2881 gnat_field = Next_Stored_Discriminant (gnat_field))
2882 if (Present (Corresponding_Discriminant (gnat_field)))
2885 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2889 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2890 gnu_get_parent, gnu_field, NULL_TREE),
2894 /* Then we build the parent subtype. If it has discriminants but
2895 the type itself has unknown discriminants, this means that it
2896 doesn't contain information about how the discriminants are
2897 derived from those of the ancestor type, so it cannot be used
2898 directly. Instead it is built by cloning the parent subtype
2899 of the underlying record view of the type, for which the above
2900 derivation of discriminants has been made explicit. */
2901 if (Has_Discriminants (gnat_parent)
2902 && Has_Unknown_Discriminants (gnat_entity))
2904 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2906 /* If we are defining the type, the underlying record
2907 view must already have been elaborated at this point.
2908 Otherwise do it now as its parent subtype cannot be
2909 technically elaborated on its own. */
2911 gcc_assert (present_gnu_tree (gnat_uview));
2913 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2915 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2917 /* Substitute the "get to the parent" of the type for that
2918 of its underlying record view in the cloned type. */
2919 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2920 Present (gnat_field);
2921 gnat_field = Next_Stored_Discriminant (gnat_field))
2922 if (Present (Corresponding_Discriminant (gnat_field)))
2924 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2926 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2927 gnu_get_parent, gnu_field, NULL_TREE);
2929 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2933 gnu_parent = gnat_to_gnu_type (gnat_parent);
2935 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2936 initially built. The discriminants must reference the fields
2937 of the parent subtype and not those of its base type for the
2938 placeholder machinery to properly work. */
2941 /* The actual parent subtype is the full view. */
2942 if (IN (Ekind (gnat_parent), Private_Kind))
2944 if (Present (Full_View (gnat_parent)))
2945 gnat_parent = Full_View (gnat_parent);
2947 gnat_parent = Underlying_Full_View (gnat_parent);
2950 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2951 Present (gnat_field);
2952 gnat_field = Next_Stored_Discriminant (gnat_field))
2953 if (Present (Corresponding_Discriminant (gnat_field)))
2955 Entity_Id field = Empty;
2956 for (field = First_Stored_Discriminant (gnat_parent);
2958 field = Next_Stored_Discriminant (field))
2959 if (same_discriminant_p (gnat_field, field))
2961 gcc_assert (Present (field));
2962 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2963 = gnat_to_gnu_field_decl (field);
2967 /* The "get to the parent" COMPONENT_REF must be given its
2969 TREE_TYPE (gnu_get_parent) = gnu_parent;
2971 /* ...and reference the _Parent field of this record. */
2973 = create_field_decl (parent_name_id,
2974 gnu_parent, gnu_type,
2976 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2978 ? bitsize_zero_node : NULL_TREE,
2980 DECL_INTERNAL_P (gnu_field) = 1;
2981 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2982 TYPE_FIELDS (gnu_type) = gnu_field;
2985 /* Make the fields for the discriminants and put them into the record
2986 unless it's an Unchecked_Union. */
2988 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2989 Present (gnat_field);
2990 gnat_field = Next_Stored_Discriminant (gnat_field))
2992 /* If this is a record extension and this discriminant is the
2993 renaming of another discriminant, we've handled it above. */
2994 if (Present (Parent_Subtype (gnat_entity))
2995 && Present (Corresponding_Discriminant (gnat_field)))
2999 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3002 /* Make an expression using a PLACEHOLDER_EXPR from the
3003 FIELD_DECL node just created and link that with the
3004 corresponding GNAT defining identifier. */
3005 save_gnu_tree (gnat_field,
3006 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3007 build0 (PLACEHOLDER_EXPR, gnu_type),
3008 gnu_field, NULL_TREE),
3011 if (!is_unchecked_union)
3013 DECL_CHAIN (gnu_field) = gnu_field_list;
3014 gnu_field_list = gnu_field;
3018 /* Add the fields into the record type and finish it up. */
3019 components_to_record (gnu_type, Component_List (record_definition),
3020 gnu_field_list, packed, definition, false,
3021 all_rep, is_unchecked_union, debug_info_p,
3022 false, OK_To_Reorder_Components (gnat_entity),
3025 /* If it is passed by reference, force BLKmode to ensure that objects
3026 of this type will always be put in memory. */
3027 if (Is_By_Reference_Type (gnat_entity))
3028 SET_TYPE_MODE (gnu_type, BLKmode);
3030 /* We used to remove the associations of the discriminants and _Parent
3031 for validity checking but we may need them if there's a Freeze_Node
3032 for a subtype used in this record. */
3033 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3035 /* Fill in locations of fields. */
3036 annotate_rep (gnat_entity, gnu_type);
3038 /* If there are any entities in the chain corresponding to components
3039 that we did not elaborate, ensure we elaborate their types if they
3041 for (gnat_temp = First_Entity (gnat_entity);
3042 Present (gnat_temp);
3043 gnat_temp = Next_Entity (gnat_temp))
3044 if ((Ekind (gnat_temp) == E_Component
3045 || Ekind (gnat_temp) == E_Discriminant)
3046 && Is_Itype (Etype (gnat_temp))
3047 && !present_gnu_tree (gnat_temp))
3048 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3050 /* If this is a record type associated with an exception definition,
3051 equate its fields to those of the standard exception type. This
3052 will make it possible to convert between them. */
3053 if (gnu_entity_name == exception_data_name_id)
3056 for (gnu_field = TYPE_FIELDS (gnu_type),
3057 gnu_std_field = TYPE_FIELDS (except_type_node);
3059 gnu_field = DECL_CHAIN (gnu_field),
3060 gnu_std_field = DECL_CHAIN (gnu_std_field))
3061 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3062 gcc_assert (!gnu_std_field);
3067 case E_Class_Wide_Subtype:
3068 /* If an equivalent type is present, that is what we should use.
3069 Otherwise, fall through to handle this like a record subtype
3070 since it may have constraints. */
3071 if (gnat_equiv_type != gnat_entity)
3073 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3074 maybe_present = true;
3078 /* ... fall through ... */
3080 case E_Record_Subtype:
3081 /* If Cloned_Subtype is Present it means this record subtype has
3082 identical layout to that type or subtype and we should use
3083 that GCC type for this one. The front end guarantees that
3084 the component list is shared. */
3085 if (Present (Cloned_Subtype (gnat_entity)))
3087 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3089 maybe_present = true;
3093 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3094 changing the type, make a new type with each field having the type of
3095 the field in the new subtype but the position computed by transforming
3096 every discriminant reference according to the constraints. We don't
3097 see any difference between private and non-private type here since
3098 derivations from types should have been deferred until the completion
3099 of the private type. */
3102 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3107 defer_incomplete_level++;
3108 this_deferred = true;
3111 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
3113 if (present_gnu_tree (gnat_entity))
3115 maybe_present = true;
3119 /* If this is a record subtype associated with a dispatch table,
3120 strip the suffix. This is necessary to make sure 2 different
3121 subtypes associated with the imported and exported views of a
3122 dispatch table are properly merged in LTO mode. */
3123 if (Is_Dispatch_Table_Entity (gnat_entity))
3126 Get_Encoded_Name (gnat_entity);
3127 p = strchr (Name_Buffer, '_');
3129 strcpy (p+2, "dtS");
3130 gnu_entity_name = get_identifier (Name_Buffer);
3133 /* When the subtype has discriminants and these discriminants affect
3134 the initial shape it has inherited, factor them in. But for an
3135 Unchecked_Union (it must be an Itype), just return the type.
3136 We can't just test Is_Constrained because private subtypes without
3137 discriminants of types with discriminants with default expressions
3138 are Is_Constrained but aren't constrained! */
3139 if (IN (Ekind (gnat_base_type), Record_Kind)
3140 && !Is_Unchecked_Union (gnat_base_type)
3141 && !Is_For_Access_Subtype (gnat_entity)
3142 && Is_Constrained (gnat_entity)
3143 && Has_Discriminants (gnat_entity)
3144 && Present (Discriminant_Constraint (gnat_entity))
3145 && Stored_Constraint (gnat_entity) != No_Elist)
3147 VEC(subst_pair,heap) *gnu_subst_list
3148 = build_subst_list (gnat_entity, gnat_base_type, definition);
3149 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
3150 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3151 bool selected_variant = false;
3152 Entity_Id gnat_field;
3153 VEC(variant_desc,heap) *gnu_variant_list;
3155 gnu_type = make_node (RECORD_TYPE);
3156 TYPE_NAME (gnu_type) = gnu_entity_name;
3158 /* Set the size, alignment and alias set of the new type to
3159 match that of the old one, doing required substitutions. */
3160 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3163 if (TYPE_IS_PADDING_P (gnu_base_type))
3164 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3166 gnu_unpad_base_type = gnu_base_type;
3168 /* Look for a REP part in the base type. */
3169 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3171 /* Look for a variant part in the base type. */
3172 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3174 /* If there is a variant part, we must compute whether the
3175 constraints statically select a particular variant. If
3176 so, we simply drop the qualified union and flatten the
3177 list of fields. Otherwise we'll build a new qualified
3178 union for the variants that are still relevant. */
3179 if (gnu_variant_part)
3185 = build_variant_list (TREE_TYPE (gnu_variant_part),
3186 gnu_subst_list, NULL);
3188 /* If all the qualifiers are unconditionally true, the
3189 innermost variant is statically selected. */
3190 selected_variant = true;
3191 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3193 if (!integer_onep (v->qual))
3195 selected_variant = false;
3199 /* Otherwise, create the new variants. */
3200 if (!selected_variant)
3201 FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
3204 tree old_variant = v->type;
3205 tree new_variant = make_node (RECORD_TYPE);
3206 TYPE_NAME (new_variant)
3207 = DECL_NAME (TYPE_NAME (old_variant));
3208 copy_and_substitute_in_size (new_variant, old_variant,
3210 v->record = new_variant;
3215 gnu_variant_list = NULL;
3216 selected_variant = false;
3220 = build_position_list (gnu_unpad_base_type,
3221 gnu_variant_list && !selected_variant,
3222 size_zero_node, bitsize_zero_node,
3223 BIGGEST_ALIGNMENT, NULL_TREE);
3225 for (gnat_field = First_Entity (gnat_entity);
3226 Present (gnat_field);
3227 gnat_field = Next_Entity (gnat_field))
3228 if ((Ekind (gnat_field) == E_Component
3229 || Ekind (gnat_field) == E_Discriminant)
3230 && !(Present (Corresponding_Discriminant (gnat_field))
3231 && Is_Tagged_Type (gnat_base_type))
3232 && Underlying_Type (Scope (Original_Record_Component
3236 Name_Id gnat_name = Chars (gnat_field);
3237 Entity_Id gnat_old_field
3238 = Original_Record_Component (gnat_field);
3240 = gnat_to_gnu_field_decl (gnat_old_field);
3241 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3242 tree gnu_field, gnu_field_type, gnu_size;
3243 tree gnu_cont_type, gnu_last = NULL_TREE;
3245 /* If the type is the same, retrieve the GCC type from the
3246 old field to take into account possible adjustments. */
3247 if (Etype (gnat_field) == Etype (gnat_old_field))
3248 gnu_field_type = TREE_TYPE (gnu_old_field);
3250 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3252 /* If there was a component clause, the field types must be
3253 the same for the type and subtype, so copy the data from
3254 the old field to avoid recomputation here. Also if the
3255 field is justified modular and the optimization in
3256 gnat_to_gnu_field was applied. */
3257 if (Present (Component_Clause (gnat_old_field))
3258 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3259 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3260 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3261 == TREE_TYPE (gnu_old_field)))
3263 gnu_size = DECL_SIZE (gnu_old_field);
3264 gnu_field_type = TREE_TYPE (gnu_old_field);
3267 /* If the old field was packed and of constant size, we
3268 have to get the old size here, as it might differ from
3269 what the Etype conveys and the latter might overlap
3270 onto the following field. Try to arrange the type for
3271 possible better packing along the way. */
3272 else if (DECL_PACKED (gnu_old_field)
3273 && TREE_CODE (DECL_SIZE (gnu_old_field))
3276 gnu_size = DECL_SIZE (gnu_old_field);
3277 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3278 && !TYPE_FAT_POINTER_P (gnu_field_type)
3279 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3281 = make_packable_type (gnu_field_type, true);
3285 gnu_size = TYPE_SIZE (gnu_field_type);
3287 /* If the context of the old field is the base type or its
3288 REP part (if any), put the field directly in the new
3289 type; otherwise look up the context in the variant list
3290 and put the field either in the new type if there is a
3291 selected variant or in one of the new variants. */
3292 if (gnu_context == gnu_unpad_base_type
3294 && gnu_context == TREE_TYPE (gnu_rep_part)))
3295 gnu_cont_type = gnu_type;
3302 FOR_EACH_VEC_ELT_REVERSE (variant_desc,
3303 gnu_variant_list, ix, v)
3304 if (v->type == gnu_context)
3311 if (selected_variant)
3312 gnu_cont_type = gnu_type;
3314 gnu_cont_type = v->record;
3317 /* The front-end may pass us "ghost" components if
3318 it fails to recognize that a constrained subtype
3319 is statically constrained. Discard them. */
3323 /* Now create the new field modeled on the old one. */
3325 = create_field_decl_from (gnu_old_field, gnu_field_type,
3326 gnu_cont_type, gnu_size,
3327 gnu_pos_list, gnu_subst_list);
3329 /* Put it in one of the new variants directly. */
3330 if (gnu_cont_type != gnu_type)
3332 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3333 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3336 /* To match the layout crafted in components_to_record,
3337 if this is the _Tag or _Parent field, put it before
3338 any other fields. */
3339 else if (gnat_name == Name_uTag
3340 || gnat_name == Name_uParent)
3341 gnu_field_list = chainon (gnu_field_list, gnu_field);
3343 /* Similarly, if this is the _Controller field, put
3344 it before the other fields except for the _Tag or
3346 else if (gnat_name == Name_uController && gnu_last)
3348 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3349 DECL_CHAIN (gnu_last) = gnu_field;
3352 /* Otherwise, if this is a regular field, put it after
3353 the other fields. */
3356 DECL_CHAIN (gnu_field) = gnu_field_list;
3357 gnu_field_list = gnu_field;
3359 gnu_last = gnu_field;
3362 save_gnu_tree (gnat_field, gnu_field, false);
3365 /* If there is a variant list and no selected variant, we need
3366 to create the nest of variant parts from the old nest. */
3367 if (gnu_variant_list && !selected_variant)
3369 tree new_variant_part
3370 = create_variant_part_from (gnu_variant_part,
3371 gnu_variant_list, gnu_type,
3372 gnu_pos_list, gnu_subst_list);
3373 DECL_CHAIN (new_variant_part) = gnu_field_list;
3374 gnu_field_list = new_variant_part;
3377 /* Now go through the entities again looking for Itypes that
3378 we have not elaborated but should (e.g., Etypes of fields
3379 that have Original_Components). */
3380 for (gnat_field = First_Entity (gnat_entity);
3381 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3382 if ((Ekind (gnat_field) == E_Discriminant
3383 || Ekind (gnat_field) == E_Component)
3384 && !present_gnu_tree (Etype (gnat_field)))
3385 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3387 /* Do not emit debug info for the type yet since we're going to
3389 gnu_field_list = nreverse (gnu_field_list);
3390 finish_record_type (gnu_type, gnu_field_list, 2, false);
3392 /* See the E_Record_Type case for the rationale. */
3393 if (Is_By_Reference_Type (gnat_entity))
3394 SET_TYPE_MODE (gnu_type, BLKmode);
3396 compute_record_mode (gnu_type);
3398 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3400 /* Fill in locations of fields. */
3401 annotate_rep (gnat_entity, gnu_type);
3403 /* If debugging information is being written for the type, write
3404 a record that shows what we are a subtype of and also make a
3405 variable that indicates our size, if still variable. */
3408 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3409 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3410 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3412 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3413 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3415 TYPE_NAME (gnu_subtype_marker)
3416 = create_concat_name (gnat_entity, "XVS");
3417 finish_record_type (gnu_subtype_marker,
3418 create_field_decl (gnu_unpad_base_name,
3419 build_reference_type
3420 (gnu_unpad_base_type),
3422 NULL_TREE, NULL_TREE,
3426 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3427 gnu_subtype_marker);
3430 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3431 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3432 TYPE_SIZE_UNIT (gnu_subtype_marker)
3433 = create_var_decl (create_concat_name (gnat_entity,
3435 NULL_TREE, sizetype, gnu_size_unit,
3436 false, false, false, false, NULL,
3440 VEC_free (variant_desc, heap, gnu_variant_list);
3441 VEC_free (subst_pair, heap, gnu_subst_list);
3443 /* Now we can finalize it. */
3444 rest_of_record_type_compilation (gnu_type);
3447 /* Otherwise, go down all the components in the new type and make
3448 them equivalent to those in the base type. */
3451 gnu_type = gnu_base_type;
3453 for (gnat_temp = First_Entity (gnat_entity);
3454 Present (gnat_temp);
3455 gnat_temp = Next_Entity (gnat_temp))
3456 if ((Ekind (gnat_temp) == E_Discriminant
3457 && !Is_Unchecked_Union (gnat_base_type))
3458 || Ekind (gnat_temp) == E_Component)
3459 save_gnu_tree (gnat_temp,
3460 gnat_to_gnu_field_decl
3461 (Original_Record_Component (gnat_temp)),
3467 case E_Access_Subprogram_Type:
3468 /* Use the special descriptor type for dispatch tables if needed,
3469 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3470 Note that we are only required to do so for static tables in
3471 order to be compatible with the C++ ABI, but Ada 2005 allows
3472 to extend library level tagged types at the local level so
3473 we do it in the non-static case as well. */
3474 if (TARGET_VTABLE_USES_DESCRIPTORS
3475 && Is_Dispatch_Table_Entity (gnat_entity))
3477 gnu_type = fdesc_type_node;
3478 gnu_size = TYPE_SIZE (gnu_type);
3482 /* ... fall through ... */
3484 case E_Anonymous_Access_Subprogram_Type:
3485 /* If we are not defining this entity, and we have incomplete
3486 entities being processed above us, make a dummy type and
3487 fill it in later. */
3488 if (!definition && defer_incomplete_level != 0)
3490 struct incomplete *p
3491 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3494 = build_pointer_type
3495 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3496 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3497 !Comes_From_Source (gnat_entity),
3498 debug_info_p, gnat_entity);
3499 this_made_decl = true;
3500 gnu_type = TREE_TYPE (gnu_decl);
3501 save_gnu_tree (gnat_entity, gnu_decl, false);
3504 p->old_type = TREE_TYPE (gnu_type);
3505 p->full_type = Directly_Designated_Type (gnat_entity);
3506 p->next = defer_incomplete_list;
3507 defer_incomplete_list = p;
3511 /* ... fall through ... */
3513 case E_Allocator_Type:
3515 case E_Access_Attribute_Type:
3516 case E_Anonymous_Access_Type:
3517 case E_General_Access_Type:
3519 /* The designated type and its equivalent type for gigi. */
3520 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3521 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3522 /* Whether it comes from a limited with. */
3523 bool is_from_limited_with
3524 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3525 && From_With_Type (gnat_desig_equiv));
3526 /* The "full view" of the designated type. If this is an incomplete
3527 entity from a limited with, treat its non-limited view as the full
3528 view. Otherwise, if this is an incomplete or private type, use the
3529 full view. In the former case, we might point to a private type,
3530 in which case, we need its full view. Also, we want to look at the
3531 actual type used for the representation, so this takes a total of
3533 Entity_Id gnat_desig_full_direct_first
3534 = (is_from_limited_with
3535 ? Non_Limited_View (gnat_desig_equiv)
3536 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3537 ? Full_View (gnat_desig_equiv) : Empty));
3538 Entity_Id gnat_desig_full_direct
3539 = ((is_from_limited_with
3540 && Present (gnat_desig_full_direct_first)
3541 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3542 ? Full_View (gnat_desig_full_direct_first)
3543 : gnat_desig_full_direct_first);
3544 Entity_Id gnat_desig_full
3545 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3546 /* The type actually used to represent the designated type, either
3547 gnat_desig_full or gnat_desig_equiv. */
3548 Entity_Id gnat_desig_rep;
3549 /* True if this is a pointer to an unconstrained array. */
3550 bool is_unconstrained_array;
3551 /* We want to know if we'll be seeing the freeze node for any
3552 incomplete type we may be pointing to. */
3554 = (Present (gnat_desig_full)
3555 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3556 : In_Extended_Main_Code_Unit (gnat_desig_type));
3557 /* True if we make a dummy type here. */
3558 bool made_dummy = false;
3559 /* The mode to be used for the pointer type. */
3560 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3561 /* The GCC type used for the designated type. */
3562 tree gnu_desig_type = NULL_TREE;
3564 if (!targetm.valid_pointer_mode (p_mode))
3567 /* If either the designated type or its full view is an unconstrained
3568 array subtype, replace it with the type it's a subtype of. This
3569 avoids problems with multiple copies of unconstrained array types.
3570 Likewise, if the designated type is a subtype of an incomplete
3571 record type, use the parent type to avoid order of elaboration
3572 issues. This can lose some code efficiency, but there is no
3574 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3575 && !Is_Constrained (gnat_desig_equiv))
3576 gnat_desig_equiv = Etype (gnat_desig_equiv);
3577 if (Present (gnat_desig_full)
3578 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3579 && !Is_Constrained (gnat_desig_full))
3580 || (Ekind (gnat_desig_full) == E_Record_Subtype
3581 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3582 gnat_desig_full = Etype (gnat_desig_full);
3584 /* Set the type that's actually the representation of the designated
3585 type and also flag whether we have a unconstrained array. */
3587 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3588 is_unconstrained_array
3589 = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
3591 /* If we are pointing to an incomplete type whose completion is an
3592 unconstrained array, make dummy fat and thin pointer types to it.
3593 Likewise if the type itself is dummy or an unconstrained array. */
3594 if (is_unconstrained_array
3595 && (Present (gnat_desig_full)
3596 || (present_gnu_tree (gnat_desig_equiv)
3598 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
3600 && defer_incomplete_level != 0
3601 && !present_gnu_tree (gnat_desig_equiv))
3603 && is_from_limited_with
3604 && Present (Freeze_Node (gnat_desig_equiv)))))
3606 if (present_gnu_tree (gnat_desig_rep))
3607 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3610 gnu_desig_type = make_dummy_type (gnat_desig_rep);
3614 /* If the call above got something that has a pointer, the pointer
3615 is our type. This could have happened either because the type
3616 was elaborated or because somebody else executed the code. */
3617 if (!TYPE_POINTER_TO (gnu_desig_type))
3618 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3619 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3622 /* If we already know what the full type is, use it. */
3623 else if (Present (gnat_desig_full)
3624 && present_gnu_tree (gnat_desig_full))
3625 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3627 /* Get the type of the thing we are to point to and build a pointer to
3628 it. If it is a reference to an incomplete or private type with a
3629 full view that is a record, make a dummy type node and get the
3630 actual type later when we have verified it is safe. */
3631 else if ((!in_main_unit
3632 && !present_gnu_tree (gnat_desig_equiv)
3633 && Present (gnat_desig_full)
3634 && !present_gnu_tree (gnat_desig_full)
3635 && Is_Record_Type (gnat_desig_full))
3636 /* Likewise if we are pointing to a record or array and we are
3637 to defer elaborating incomplete types. We do this as this
3638 access type may be the full view of a private type. Note
3639 that the unconstrained array case is handled above. */
3640 || ((!in_main_unit || imported_p)
3641 && defer_incomplete_level != 0
3642 && !present_gnu_tree (gnat_desig_equiv)
3643 && (Is_Record_Type (gnat_desig_rep)
3644 || Is_Array_Type (gnat_desig_rep)))
3645 /* If this is a reference from a limited_with type back to our
3646 main unit and there's a freeze node for it, either we have
3647 already processed the declaration and made the dummy type,
3648 in which case we just reuse the latter, or we have not yet,
3649 in which case we make the dummy type and it will be reused
3650 when the declaration is finally processed. In both cases,
3651 the pointer eventually created below will be automatically
3652 adjusted when the freeze node is processed. Note that the
3653 unconstrained array case is handled above. */
3655 && is_from_limited_with
3656 && Present (Freeze_Node (gnat_desig_rep))))
3658 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3662 /* Otherwise handle the case of a pointer to itself. */
3663 else if (gnat_desig_equiv == gnat_entity)
3666 = build_pointer_type_for_mode (void_type_node, p_mode,
3667 No_Strict_Aliasing (gnat_entity));
3668 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3671 /* If expansion is disabled, the equivalent type of a concurrent type
3672 is absent, so build a dummy pointer type. */
3673 else if (type_annotate_only && No (gnat_desig_equiv))
3674 gnu_type = ptr_void_type_node;
3676 /* Finally, handle the default case where we can just elaborate our
3679 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3681 /* It is possible that a call to gnat_to_gnu_type above resolved our
3682 type. If so, just return it. */
3683 if (present_gnu_tree (gnat_entity))
3685 maybe_present = true;
3689 /* If we have not done it yet, build the pointer type the usual way. */
3692 /* Modify the designated type if we are pointing only to constant
3693 objects, but don't do it for unconstrained arrays. */
3694 if (Is_Access_Constant (gnat_entity)
3695 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3698 = build_qualified_type
3700 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3702 /* Some extra processing is required if we are building a
3703 pointer to an incomplete type (in the GCC sense). We might
3704 have such a type if we just made a dummy, or directly out
3705 of the call to gnat_to_gnu_type above if we are processing
3706 an access type for a record component designating the
3707 record type itself. */
3708 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3710 /* We must ensure that the pointer to variant we make will
3711 be processed by update_pointer_to when the initial type
3712 is completed. Pretend we made a dummy and let further
3713 processing act as usual. */
3716 /* We must ensure that update_pointer_to will not retrieve
3717 the dummy variant when building a properly qualified
3718 version of the complete type. We take advantage of the
3719 fact that get_qualified_type is requiring TYPE_NAMEs to
3720 match to influence build_qualified_type and then also
3721 update_pointer_to here. */
3722 TYPE_NAME (gnu_desig_type)
3723 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3728 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3729 No_Strict_Aliasing (gnat_entity));
3732 /* If we are not defining this object and we have made a dummy pointer,
3733 save our current definition, evaluate the actual type, and replace
3734 the tentative type we made with the actual one. If we are to defer
3735 actually looking up the actual type, make an entry in the deferred
3736 list. If this is from a limited with, we may have to defer to the
3737 end of the current unit. */
3738 if ((!in_main_unit || is_from_limited_with) && made_dummy)
3740 tree gnu_old_desig_type;
3742 if (TYPE_IS_FAT_POINTER_P (gnu_type))
3744 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
3745 if (esize == POINTER_SIZE)
3746 gnu_type = build_pointer_type
3747 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
3750 gnu_old_desig_type = TREE_TYPE (gnu_type);
3752 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3753 !Comes_From_Source (gnat_entity),
3754 debug_info_p, gnat_entity);
3755 this_made_decl = true;
3756 gnu_type = TREE_TYPE (gnu_decl);
3757 save_gnu_tree (gnat_entity, gnu_decl, false);
3760 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3761 update gnu_old_desig_type directly, in which case it will not be
3762 a dummy type any more when we get into update_pointer_to.
3764 This can happen e.g. when the designated type is a record type,
3765 because their elaboration starts with an initial node from
3766 make_dummy_type, which may be the same node as the one we got.
3768 Besides, variants of this non-dummy type might have been created
3769 along the way. update_pointer_to is expected to properly take
3770 care of those situations. */
3771 if (defer_incomplete_level == 0 && !is_from_limited_with)
3773 defer_finalize_level++;
3774 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
3775 gnat_to_gnu_type (gnat_desig_equiv));
3776 defer_finalize_level--;
3780 struct incomplete *p = XNEW (struct incomplete);
3781 struct incomplete **head
3782 = (is_from_limited_with
3783 ? &defer_limited_with : &defer_incomplete_list);
3784 p->old_type = gnu_old_desig_type;
3785 p->full_type = gnat_desig_equiv;
3793 case E_Access_Protected_Subprogram_Type:
3794 case E_Anonymous_Access_Protected_Subprogram_Type:
3795 if (type_annotate_only && No (gnat_equiv_type))
3796 gnu_type = ptr_void_type_node;
3799 /* The run-time representation is the equivalent type. */
3800 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3801 maybe_present = true;
3804 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3805 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3806 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3807 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3808 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3813 case E_Access_Subtype:
3815 /* We treat this as identical to its base type; any constraint is
3816 meaningful only to the front end.
3818 The designated type must be elaborated as well, if it does
3819 not have its own freeze node. Designated (sub)types created
3820 for constrained components of records with discriminants are
3821 not frozen by the front end and thus not elaborated by gigi,
3822 because their use may appear before the base type is frozen,
3823 and because it is not clear that they are needed anywhere in
3824 Gigi. With the current model, there is no correct place where
3825 they could be elaborated. */
3827 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3828 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3829 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3830 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3831 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3833 /* If we are not defining this entity, and we have incomplete
3834 entities being processed above us, make a dummy type and
3835 elaborate it later. */
3836 if (!definition && defer_incomplete_level != 0)
3838 struct incomplete *p
3839 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3841 = build_pointer_type
3842 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3844 p->old_type = TREE_TYPE (gnu_ptr_type);
3845 p->full_type = Directly_Designated_Type (gnat_entity);
3846 p->next = defer_incomplete_list;
3847 defer_incomplete_list = p;
3849 else if (!IN (Ekind (Base_Type
3850 (Directly_Designated_Type (gnat_entity))),
3851 Incomplete_Or_Private_Kind))
3852 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3856 maybe_present = true;
3859 /* Subprogram Entities
3861 The following access functions are defined for subprograms:
3863 Etype Return type or Standard_Void_Type.
3864 First_Formal The first formal parameter.
3865 Is_Imported Indicates that the subprogram has appeared in
3866 an INTERFACE or IMPORT pragma. For now we
3867 assume that the external language is C.
3868 Is_Exported Likewise but for an EXPORT pragma.
3869 Is_Inlined True if the subprogram is to be inlined.
3871 Each parameter is first checked by calling must_pass_by_ref on its
3872 type to determine if it is passed by reference. For parameters which
3873 are copied in, if they are Ada In Out or Out parameters, their return
3874 value becomes part of a record which becomes the return type of the
3875 function (C function - note that this applies only to Ada procedures
3876 so there is no Ada return type). Additional code to store back the
3877 parameters will be generated on the caller side. This transformation
3878 is done here, not in the front-end.
3880 The intended result of the transformation can be seen from the
3881 equivalent source rewritings that follow:
3883 struct temp {int a,b};
3884 procedure P (A,B: In Out ...) is temp P (int A,B)
3887 end P; return {A,B};
3894 For subprogram types we need to perform mainly the same conversions to
3895 GCC form that are needed for procedures and function declarations. The
3896 only difference is that at the end, we make a type declaration instead
3897 of a function declaration. */
3899 case E_Subprogram_Type:
3903 /* The type returned by a function or else Standard_Void_Type for a
3905 Entity_Id gnat_return_type = Etype (gnat_entity);
3906 tree gnu_return_type;
3907 /* The first GCC parameter declaration (a PARM_DECL node). The
3908 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
3909 actually is the head of this parameter list. */
3910 tree gnu_param_list = NULL_TREE;
3911 /* Likewise for the stub associated with an exported procedure. */
3912 tree gnu_stub_param_list = NULL_TREE;
3913 /* Non-null for subprograms containing parameters passed by copy-in
3914 copy-out (Ada In Out or Out parameters not passed by reference),
3915 in which case it is the list of nodes used to specify the values
3916 of the In Out/Out parameters that are returned as a record upon
3917 procedure return. The TREE_PURPOSE of an element of this list is
3918 a field of the record and the TREE_VALUE is the PARM_DECL
3919 corresponding to that field. This list will be saved in the
3920 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3921 tree gnu_cico_list = NULL_TREE;
3922 /* List of fields in return type of procedure with copy-in copy-out
3924 tree gnu_field_list = NULL_TREE;
3925 /* If an import pragma asks to map this subprogram to a GCC builtin,
3926 this is the builtin DECL node. */
3927 tree gnu_builtin_decl = NULL_TREE;
3928 /* For the stub associated with an exported procedure. */
3929 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3930 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3931 Entity_Id gnat_param;
3932 bool inline_flag = Is_Inlined (gnat_entity);
3933 bool public_flag = Is_Public (gnat_entity) || imported_p;
3935 = (Is_Public (gnat_entity) && !definition) || imported_p;
3936 bool artificial_flag = !Comes_From_Source (gnat_entity);
3937 /* The semantics of "pure" in Ada essentially matches that of "const"
3938 in the back-end. In particular, both properties are orthogonal to
3939 the "nothrow" property if the EH circuitry is explicit in the
3940 internal representation of the back-end. If we are to completely
3941 hide the EH circuitry from it, we need to declare that calls to pure
3942 Ada subprograms that can throw have side effects since they can
3943 trigger an "abnormal" transfer of control flow; thus they can be
3944 neither "const" nor "pure" in the back-end sense. */
3946 = (Exception_Mechanism == Back_End_Exceptions
3947 && Is_Pure (gnat_entity));
3948 bool volatile_flag = No_Return (gnat_entity);
3949 bool return_by_direct_ref_p = false;
3950 bool return_by_invisi_ref_p = false;
3951 bool return_unconstrained_p = false;
3952 bool has_stub = false;
3955 /* A parameter may refer to this type, so defer completion of any
3956 incomplete types. */
3957 if (kind == E_Subprogram_Type && !definition)
3959 defer_incomplete_level++;
3960 this_deferred = true;
3963 /* If the subprogram has an alias, it is probably inherited, so
3964 we can use the original one. If the original "subprogram"
3965 is actually an enumeration literal, it may be the first use
3966 of its type, so we must elaborate that type now. */
3967 if (Present (Alias (gnat_entity)))
3969 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3970 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3972 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
3974 /* Elaborate any Itypes in the parameters of this entity. */
3975 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3976 Present (gnat_temp);
3977 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3978 if (Is_Itype (Etype (gnat_temp)))
3979 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3984 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3985 corresponding DECL node. Proper generation of calls later on need
3986 proper parameter associations so we don't "break;" here. */
3987 if (Convention (gnat_entity) == Convention_Intrinsic
3988 && Present (Interface_Name (gnat_entity)))
3990 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3992 /* Inability to find the builtin decl most often indicates a
3993 genuine mistake, but imports of unregistered intrinsics are
3994 sometimes issued on purpose to allow hooking in alternate
3995 bodies. We post a warning conditioned on Wshadow in this case,
3996 to let developers be notified on demand without risking false
3997 positives with common default sets of options. */
3999 if (gnu_builtin_decl == NULL_TREE && warn_shadow)
4000 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4003 /* ??? What if we don't find the builtin node above ? warn ? err ?
4004 In the current state we neither warn nor err, and calls will just
4005 be handled as for regular subprograms. */
4007 /* Look into the return type and get its associated GCC tree. If it
4008 is not void, compute various flags for the subprogram type. */
4009 if (Ekind (gnat_return_type) == E_Void)
4010 gnu_return_type = void_type_node;
4013 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4015 /* If this function returns by reference, make the actual return
4016 type the pointer type and make a note of that. */
4017 if (Returns_By_Ref (gnat_entity))
4019 gnu_return_type = build_pointer_type (gnu_return_type);
4020 return_by_direct_ref_p = true;
4023 /* If we are supposed to return an unconstrained array type, make
4024 the actual return type the fat pointer type. */
4025 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4027 gnu_return_type = TREE_TYPE (gnu_return_type);
4028 return_unconstrained_p = true;
4031 /* Likewise, if the return type requires a transient scope, the
4032 return value will be allocated on the secondary stack so the
4033 actual return type is the pointer type. */
4034 else if (Requires_Transient_Scope (gnat_return_type))
4036 gnu_return_type = build_pointer_type (gnu_return_type);
4037 return_unconstrained_p = true;
4040 /* If the Mechanism is By_Reference, ensure this function uses the
4041 target's by-invisible-reference mechanism, which may not be the
4042 same as above (e.g. it might be passing an extra parameter). */
4043 else if (kind == E_Function
4044 && Mechanism (gnat_entity) == By_Reference)
4045 return_by_invisi_ref_p = true;
4047 /* Likewise, if the return type is itself By_Reference. */
4048 else if (TREE_ADDRESSABLE (gnu_return_type))
4049 return_by_invisi_ref_p = true;
4051 /* If the type is a padded type and the underlying type would not
4052 be passed by reference or the function has a foreign convention,
4053 return the underlying type. */
4054 else if (TYPE_IS_PADDING_P (gnu_return_type)
4055 && (!default_pass_by_ref
4056 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4057 || Has_Foreign_Convention (gnat_entity)))
4058 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4060 /* If the return type is unconstrained, that means it must have a
4061 maximum size. Use the padded type as the effective return type.
4062 And ensure the function uses the target's by-invisible-reference
4063 mechanism to avoid copying too much data when it returns. */
4064 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4067 = maybe_pad_type (gnu_return_type,
4068 max_size (TYPE_SIZE (gnu_return_type),
4070 0, gnat_entity, false, false, false, true);
4072 /* Declare it now since it will never be declared otherwise.
4073 This is necessary to ensure that its subtrees are properly
4075 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
4076 NULL, true, debug_info_p, gnat_entity);
4078 return_by_invisi_ref_p = true;
4081 /* If the return type has a size that overflows, we cannot have
4082 a function that returns that type. This usage doesn't make
4083 sense anyway, so give an error here. */
4084 if (TYPE_SIZE_UNIT (gnu_return_type)
4085 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
4086 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
4088 post_error ("cannot return type whose size overflows",
4090 gnu_return_type = copy_node (gnu_return_type);
4091 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4092 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4093 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4094 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4098 /* Loop over the parameters and get their associated GCC tree. While
4099 doing this, build a copy-in copy-out structure if we need one. */
4100 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4101 Present (gnat_param);
4102 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4104 tree gnu_param_name = get_entity_name (gnat_param);
4105 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4106 tree gnu_param, gnu_field;
4107 bool copy_in_copy_out = false;
4108 Mechanism_Type mech = Mechanism (gnat_param);
4110 /* Builtins are expanded inline and there is no real call sequence
4111 involved. So the type expected by the underlying expander is
4112 always the type of each argument "as is". */
4113 if (gnu_builtin_decl)
4115 /* Handle the first parameter of a valued procedure specially. */
4116 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4117 mech = By_Copy_Return;
4118 /* Otherwise, see if a Mechanism was supplied that forced this
4119 parameter to be passed one way or another. */
4120 else if (mech == Default
4121 || mech == By_Copy || mech == By_Reference)
4123 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4124 mech = By_Descriptor;
4126 else if (By_Short_Descriptor_Last <= mech &&
4127 mech <= By_Short_Descriptor)
4128 mech = By_Short_Descriptor;
4132 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4133 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4134 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4136 mech = By_Reference;
4142 post_error ("unsupported mechanism for&", gnat_param);
4147 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4148 Has_Foreign_Convention (gnat_entity),
4151 /* We are returned either a PARM_DECL or a type if no parameter
4152 needs to be passed; in either case, adjust the type. */
4153 if (DECL_P (gnu_param))
4154 gnu_param_type = TREE_TYPE (gnu_param);
4157 gnu_param_type = gnu_param;
4158 gnu_param = NULL_TREE;
4161 /* The failure of this assertion will very likely come from an
4162 order of elaboration issue for the type of the parameter. */
4163 gcc_assert (kind == E_Subprogram_Type
4164 || !TYPE_IS_DUMMY_P (gnu_param_type));
4168 /* If it's an exported subprogram, we build a parameter list
4169 in parallel, in case we need to emit a stub for it. */
4170 if (Is_Exported (gnat_entity))
4173 = chainon (gnu_param, gnu_stub_param_list);
4174 /* Change By_Descriptor parameter to By_Reference for
4175 the internal version of an exported subprogram. */
4176 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4179 = gnat_to_gnu_param (gnat_param, By_Reference,
4185 gnu_param = copy_node (gnu_param);
4188 gnu_param_list = chainon (gnu_param, gnu_param_list);
4189 Sloc_to_locus (Sloc (gnat_param),
4190 &DECL_SOURCE_LOCATION (gnu_param));
4191 save_gnu_tree (gnat_param, gnu_param, false);
4193 /* If a parameter is a pointer, this function may modify
4194 memory through it and thus shouldn't be considered
4195 a const function. Also, the memory may be modified
4196 between two calls, so they can't be CSE'ed. The latter
4197 case also handles by-ref parameters. */
4198 if (POINTER_TYPE_P (gnu_param_type)
4199 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4203 if (copy_in_copy_out)
4207 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4209 /* If this is a function, we also need a field for the
4210 return value to be placed. */
4211 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4214 = create_field_decl (get_identifier ("RETVAL"),
4216 gnu_new_ret_type, NULL_TREE,
4218 Sloc_to_locus (Sloc (gnat_entity),
4219 &DECL_SOURCE_LOCATION (gnu_field));
4220 gnu_field_list = gnu_field;
4222 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4225 gnu_return_type = gnu_new_ret_type;
4226 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4227 /* Set a default alignment to speed up accesses. */
4228 TYPE_ALIGN (gnu_return_type)
4229 = get_mode_alignment (ptr_mode);
4233 = create_field_decl (gnu_param_name, gnu_param_type,
4234 gnu_return_type, NULL_TREE, NULL_TREE,
4236 /* Set a minimum alignment to speed up accesses. */
4237 if (DECL_ALIGN (gnu_field) < TYPE_ALIGN (gnu_return_type))
4238 DECL_ALIGN (gnu_field) = TYPE_ALIGN (gnu_return_type);
4239 Sloc_to_locus (Sloc (gnat_param),
4240 &DECL_SOURCE_LOCATION (gnu_field));
4241 DECL_CHAIN (gnu_field) = gnu_field_list;
4242 gnu_field_list = gnu_field;
4244 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4250 /* If we have a CICO list but it has only one entry, we convert
4251 this function into a function that returns this object. */
4252 if (list_length (gnu_cico_list) == 1)
4253 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4255 /* Do not finalize the return type if the subprogram is stubbed
4256 since structures are incomplete for the back-end. */
4257 else if (Convention (gnat_entity) != Convention_Stubbed)
4259 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4262 /* Try to promote the mode of the return type if it is passed
4263 in registers, again to speed up accesses. */
4264 if (TYPE_MODE (gnu_return_type) == BLKmode
4265 && !targetm.calls.return_in_memory (gnu_return_type,
4269 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4270 unsigned int i = BITS_PER_UNIT;
4271 enum machine_mode mode;
4275 mode = mode_for_size (i, MODE_INT, 0);
4276 if (mode != BLKmode)
4278 SET_TYPE_MODE (gnu_return_type, mode);
4279 TYPE_ALIGN (gnu_return_type)
4280 = GET_MODE_ALIGNMENT (mode);
4281 TYPE_SIZE (gnu_return_type)
4282 = bitsize_int (GET_MODE_BITSIZE (mode));
4283 TYPE_SIZE_UNIT (gnu_return_type)
4284 = size_int (GET_MODE_SIZE (mode));
4289 rest_of_record_type_compilation (gnu_return_type);
4293 if (Has_Stdcall_Convention (gnat_entity))
4294 prepend_one_attribute_to
4295 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4296 get_identifier ("stdcall"), NULL_TREE,
4299 /* If we should request stack realignment for a foreign convention
4300 subprogram, do so. Note that this applies to task entry points in
4302 if (FOREIGN_FORCE_REALIGN_STACK
4303 && Has_Foreign_Convention (gnat_entity))
4304 prepend_one_attribute_to
4305 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4306 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4309 /* The lists have been built in reverse. */
4310 gnu_param_list = nreverse (gnu_param_list);
4312 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4313 gnu_cico_list = nreverse (gnu_cico_list);
4315 if (kind == E_Function)
4316 Set_Mechanism (gnat_entity, return_unconstrained_p
4317 || return_by_direct_ref_p
4318 || return_by_invisi_ref_p
4319 ? By_Reference : By_Copy);
4321 = create_subprog_type (gnu_return_type, gnu_param_list,
4322 gnu_cico_list, return_unconstrained_p,
4323 return_by_direct_ref_p,
4324 return_by_invisi_ref_p);
4328 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4329 gnu_cico_list, return_unconstrained_p,
4330 return_by_direct_ref_p,
4331 return_by_invisi_ref_p);
4333 /* A subprogram (something that doesn't return anything) shouldn't
4334 be considered const since there would be no reason for such a
4335 subprogram. Note that procedures with Out (or In Out) parameters
4336 have already been converted into a function with a return type. */
4337 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4341 = build_qualified_type (gnu_type,
4342 TYPE_QUALS (gnu_type)
4343 | (TYPE_QUAL_CONST * const_flag)
4344 | (TYPE_QUAL_VOLATILE * volatile_flag));
4348 = build_qualified_type (gnu_stub_type,
4349 TYPE_QUALS (gnu_stub_type)
4350 | (TYPE_QUAL_CONST * const_flag)
4351 | (TYPE_QUAL_VOLATILE * volatile_flag));
4353 /* If we have a builtin decl for that function, use it. Check if the
4354 profiles are compatible and warn if they are not. The checker is
4355 expected to post extra diagnostics in this case. */
4356 if (gnu_builtin_decl)
4358 intrin_binding_t inb;
4360 inb.gnat_entity = gnat_entity;
4361 inb.ada_fntype = gnu_type;
4362 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4364 if (!intrin_profiles_compatible_p (&inb))
4366 ("?profile of& doesn''t match the builtin it binds!",
4369 gnu_decl = gnu_builtin_decl;
4370 gnu_type = TREE_TYPE (gnu_builtin_decl);
4374 /* If there was no specified Interface_Name and the external and
4375 internal names of the subprogram are the same, only use the
4376 internal name to allow disambiguation of nested subprograms. */
4377 if (No (Interface_Name (gnat_entity))
4378 && gnu_ext_name == gnu_entity_name)
4379 gnu_ext_name = NULL_TREE;
4381 /* If we are defining the subprogram and it has an Address clause
4382 we must get the address expression from the saved GCC tree for the
4383 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4384 the address expression here since the front-end has guaranteed
4385 in that case that the elaboration has no effects. If there is
4386 an Address clause and we are not defining the object, just
4387 make it a constant. */
4388 if (Present (Address_Clause (gnat_entity)))
4390 tree gnu_address = NULL_TREE;
4394 = (present_gnu_tree (gnat_entity)
4395 ? get_gnu_tree (gnat_entity)
4396 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4398 save_gnu_tree (gnat_entity, NULL_TREE, false);
4400 /* Convert the type of the object to a reference type that can
4401 alias everything as per 13.3(19). */
4403 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4405 gnu_address = convert (gnu_type, gnu_address);
4408 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4409 gnu_address, false, Is_Public (gnat_entity),
4410 extern_flag, false, NULL, gnat_entity);
4411 DECL_BY_REF_P (gnu_decl) = 1;
4414 else if (kind == E_Subprogram_Type)
4416 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4417 artificial_flag, debug_info_p, gnat_entity);
4422 gnu_stub_name = gnu_ext_name;
4423 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4424 public_flag = false;
4425 artificial_flag = true;
4429 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4430 gnu_param_list, inline_flag, public_flag,
4431 extern_flag, artificial_flag, attr_list,
4436 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4437 gnu_stub_type, gnu_stub_param_list,
4438 inline_flag, true, extern_flag,
4439 false, attr_list, gnat_entity);
4440 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4443 /* This is unrelated to the stub built right above. */
4444 DECL_STUBBED_P (gnu_decl)
4445 = Convention (gnat_entity) == Convention_Stubbed;
4450 case E_Incomplete_Type:
4451 case E_Incomplete_Subtype:
4452 case E_Private_Type:
4453 case E_Private_Subtype:
4454 case E_Limited_Private_Type:
4455 case E_Limited_Private_Subtype:
4456 case E_Record_Type_With_Private:
4457 case E_Record_Subtype_With_Private:
4459 /* Get the "full view" of this entity. If this is an incomplete
4460 entity from a limited with, treat its non-limited view as the
4461 full view. Otherwise, use either the full view or the underlying
4462 full view, whichever is present. This is used in all the tests
4465 = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity))
4466 ? Non_Limited_View (gnat_entity)
4467 : Present (Full_View (gnat_entity))
4468 ? Full_View (gnat_entity)
4469 : Underlying_Full_View (gnat_entity);
4471 /* If this is an incomplete type with no full view, it must be a Taft
4472 Amendment type, in which case we return a dummy type. Otherwise,
4473 just get the type from its Etype. */
4476 if (kind == E_Incomplete_Type)
4478 gnu_type = make_dummy_type (gnat_entity);
4479 gnu_decl = TYPE_STUB_DECL (gnu_type);
4483 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4485 maybe_present = true;
4490 /* If we already made a type for the full view, reuse it. */
4491 else if (present_gnu_tree (full_view))
4493 gnu_decl = get_gnu_tree (full_view);
4497 /* Otherwise, if we are not defining the type now, get the type
4498 from the full view. But always get the type from the full view
4499 for define on use types, since otherwise we won't see them! */
4500 else if (!definition
4501 || (Is_Itype (full_view)
4502 && No (Freeze_Node (gnat_entity)))
4503 || (Is_Itype (gnat_entity)
4504 && No (Freeze_Node (full_view))))
4506 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4507 maybe_present = true;
4511 /* For incomplete types, make a dummy type entry which will be
4512 replaced later. Save it as the full declaration's type so
4513 we can do any needed updates when we see it. */
4514 gnu_type = make_dummy_type (gnat_entity);
4515 gnu_decl = TYPE_STUB_DECL (gnu_type);
4516 if (Has_Completion_In_Body (gnat_entity))
4517 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4518 save_gnu_tree (full_view, gnu_decl, 0);
4522 case E_Class_Wide_Type:
4523 /* Class-wide types are always transformed into their root type. */
4524 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4525 maybe_present = true;
4529 case E_Task_Subtype:
4530 case E_Protected_Type:
4531 case E_Protected_Subtype:
4532 /* Concurrent types are always transformed into their record type. */
4533 if (type_annotate_only && No (gnat_equiv_type))
4534 gnu_type = void_type_node;
4536 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4537 maybe_present = true;
4541 gnu_decl = create_label_decl (gnu_entity_name);
4546 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4547 we've already saved it, so we don't try to. */
4548 gnu_decl = error_mark_node;
4556 /* If we had a case where we evaluated another type and it might have
4557 defined this one, handle it here. */
4558 if (maybe_present && present_gnu_tree (gnat_entity))
4560 gnu_decl = get_gnu_tree (gnat_entity);
4564 /* If we are processing a type and there is either no decl for it or
4565 we just made one, do some common processing for the type, such as
4566 handling alignment and possible padding. */
4567 if (is_type && (!gnu_decl || this_made_decl))
4569 /* Tell the middle-end that objects of tagged types are guaranteed to
4570 be properly aligned. This is necessary because conversions to the
4571 class-wide type are translated into conversions to the root type,
4572 which can be less aligned than some of its derived types. */
4573 if (Is_Tagged_Type (gnat_entity)
4574 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4575 TYPE_ALIGN_OK (gnu_type) = 1;
4577 /* If the type is passed by reference, objects of this type must be
4578 fully addressable and cannot be copied. */
4579 if (Is_By_Reference_Type (gnat_entity))
4580 TREE_ADDRESSABLE (gnu_type) = 1;
4582 /* ??? Don't set the size for a String_Literal since it is either
4583 confirming or we don't handle it properly (if the low bound is
4585 if (!gnu_size && kind != E_String_Literal_Subtype)
4586 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4588 Has_Size_Clause (gnat_entity));
4590 /* If a size was specified, see if we can make a new type of that size
4591 by rearranging the type, for example from a fat to a thin pointer. */
4595 = make_type_from_size (gnu_type, gnu_size,
4596 Has_Biased_Representation (gnat_entity));
4598 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4599 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4603 /* If the alignment hasn't already been processed and this is
4604 not an unconstrained array, see if an alignment is specified.
4605 If not, we pick a default alignment for atomic objects. */
4606 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4608 else if (Known_Alignment (gnat_entity))
4610 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4611 TYPE_ALIGN (gnu_type));
4613 /* Warn on suspiciously large alignments. This should catch
4614 errors about the (alignment,byte)/(size,bit) discrepancy. */
4615 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4619 /* If a size was specified, take it into account. Otherwise
4620 use the RM size for records as the type size has already
4621 been adjusted to the alignment. */
4624 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4625 || TREE_CODE (gnu_type) == UNION_TYPE
4626 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4627 && !TYPE_FAT_POINTER_P (gnu_type))
4628 size = rm_size (gnu_type);
4630 size = TYPE_SIZE (gnu_type);
4632 /* Consider an alignment as suspicious if the alignment/size
4633 ratio is greater or equal to the byte/bit ratio. */
4634 if (host_integerp (size, 1)
4635 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4636 post_error_ne ("?suspiciously large alignment specified for&",
4637 Expression (Alignment_Clause (gnat_entity)),
4641 else if (Is_Atomic (gnat_entity) && !gnu_size
4642 && host_integerp (TYPE_SIZE (gnu_type), 1)
4643 && integer_pow2p (TYPE_SIZE (gnu_type)))
4644 align = MIN (BIGGEST_ALIGNMENT,
4645 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4646 else if (Is_Atomic (gnat_entity) && gnu_size
4647 && host_integerp (gnu_size, 1)
4648 && integer_pow2p (gnu_size))
4649 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4651 /* See if we need to pad the type. If we did, and made a record,
4652 the name of the new type may be changed. So get it back for
4653 us when we make the new TYPE_DECL below. */
4654 if (gnu_size || align > 0)
4655 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4656 false, !gnu_decl, definition, false);
4658 if (TYPE_IS_PADDING_P (gnu_type))
4660 gnu_entity_name = TYPE_NAME (gnu_type);
4661 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4662 gnu_entity_name = DECL_NAME (gnu_entity_name);
4665 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4667 /* If we are at global level, GCC will have applied variable_size to
4668 the type, but that won't have done anything. So, if it's not
4669 a constant or self-referential, call elaborate_expression_1 to
4670 make a variable for the size rather than calculating it each time.
4671 Handle both the RM size and the actual size. */
4672 if (global_bindings_p ()
4673 && TYPE_SIZE (gnu_type)
4674 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4675 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4677 tree size = TYPE_SIZE (gnu_type);
4679 TYPE_SIZE (gnu_type)
4680 = elaborate_expression_1 (size, gnat_entity,
4681 get_identifier ("SIZE"),
4684 /* ??? For now, store the size as a multiple of the alignment in
4685 bytes so that we can see the alignment from the tree. */
4686 TYPE_SIZE_UNIT (gnu_type)
4687 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4688 get_identifier ("SIZE_A_UNIT"),
4690 TYPE_ALIGN (gnu_type));
4692 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4693 may not be marked by the call to create_type_decl below. */
4694 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4696 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4698 tree variant_part = get_variant_part (gnu_type);
4699 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4703 tree union_type = TREE_TYPE (variant_part);
4704 tree offset = DECL_FIELD_OFFSET (variant_part);
4706 /* If the position of the variant part is constant, subtract
4707 it from the size of the type of the parent to get the new
4708 size. This manual CSE reduces the data size. */
4709 if (TREE_CODE (offset) == INTEGER_CST)
4711 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4712 TYPE_SIZE (union_type)
4713 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4714 bit_from_pos (offset, bitpos));
4715 TYPE_SIZE_UNIT (union_type)
4716 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4717 byte_from_pos (offset, bitpos));
4721 TYPE_SIZE (union_type)
4722 = elaborate_expression_1 (TYPE_SIZE (union_type),
4724 get_identifier ("VSIZE"),
4727 /* ??? For now, store the size as a multiple of the
4728 alignment in bytes so that we can see the alignment
4730 TYPE_SIZE_UNIT (union_type)
4731 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4736 TYPE_ALIGN (union_type));
4738 /* ??? For now, store the offset as a multiple of the
4739 alignment in bytes so that we can see the alignment
4741 DECL_FIELD_OFFSET (variant_part)
4742 = elaborate_expression_2 (offset,
4744 get_identifier ("VOFFSET"),
4750 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4751 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4754 if (operand_equal_p (ada_size, size, 0))
4755 ada_size = TYPE_SIZE (gnu_type);
4758 = elaborate_expression_1 (ada_size, gnat_entity,
4759 get_identifier ("RM_SIZE"),
4761 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4765 /* If this is a record type or subtype, call elaborate_expression_1 on
4766 any field position. Do this for both global and local types.
4767 Skip any fields that we haven't made trees for to avoid problems with
4768 class wide types. */
4769 if (IN (kind, Record_Kind))
4770 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4771 gnat_temp = Next_Entity (gnat_temp))
4772 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4774 tree gnu_field = get_gnu_tree (gnat_temp);
4776 /* ??? For now, store the offset as a multiple of the alignment
4777 in bytes so that we can see the alignment from the tree. */
4778 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4780 DECL_FIELD_OFFSET (gnu_field)
4781 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4783 get_identifier ("OFFSET"),
4785 DECL_OFFSET_ALIGN (gnu_field));
4787 /* ??? The context of gnu_field is not necessarily gnu_type
4788 so the MULT_EXPR node built above may not be marked by
4789 the call to create_type_decl below. */
4790 if (global_bindings_p ())
4791 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4795 if (Treat_As_Volatile (gnat_entity))
4797 = build_qualified_type (gnu_type,
4798 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4800 if (Is_Atomic (gnat_entity))
4801 check_ok_for_atomic (gnu_type, gnat_entity, false);
4803 if (Present (Alignment_Clause (gnat_entity)))
4804 TYPE_USER_ALIGN (gnu_type) = 1;
4806 if (Universal_Aliasing (gnat_entity))
4807 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4810 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4811 !Comes_From_Source (gnat_entity),
4812 debug_info_p, gnat_entity);
4815 TREE_TYPE (gnu_decl) = gnu_type;
4816 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4820 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4822 gnu_type = TREE_TYPE (gnu_decl);
4824 /* If this is a derived type, relate its alias set to that of its parent
4825 to avoid troubles when a call to an inherited primitive is inlined in
4826 a context where a derived object is accessed. The inlined code works
4827 on the parent view so the resulting code may access the same object
4828 using both the parent and the derived alias sets, which thus have to
4829 conflict. As the same issue arises with component references, the
4830 parent alias set also has to conflict with composite types enclosing
4831 derived components. For instance, if we have:
4838 we want T to conflict with both D and R, in addition to R being a
4839 superset of D by record/component construction.
4841 One way to achieve this is to perform an alias set copy from the
4842 parent to the derived type. This is not quite appropriate, though,
4843 as we don't want separate derived types to conflict with each other:
4845 type I1 is new Integer;
4846 type I2 is new Integer;
4848 We want I1 and I2 to both conflict with Integer but we do not want
4849 I1 to conflict with I2, and an alias set copy on derivation would
4852 The option chosen is to make the alias set of the derived type a
4853 superset of that of its parent type. It trivially fulfills the
4854 simple requirement for the Integer derivation example above, and
4855 the component case as well by superset transitivity:
4858 R ----------> D ----------> T
4860 However, for composite types, conversions between derived types are
4861 translated into VIEW_CONVERT_EXPRs so a sequence like:
4863 type Comp1 is new Comp;
4864 type Comp2 is new Comp;
4865 procedure Proc (C : Comp1);
4873 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4875 and gimplified into:
4882 i.e. generates code involving type punning. Therefore, Comp1 needs
4883 to conflict with Comp2 and an alias set copy is required.
4885 The language rules ensure the parent type is already frozen here. */
4886 if (Is_Derived_Type (gnat_entity))
4888 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4889 relate_alias_sets (gnu_type, gnu_parent_type,
4890 Is_Composite_Type (gnat_entity)
4891 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4894 /* Back-annotate the Alignment of the type if not already in the
4895 tree. Likewise for sizes. */
4896 if (Unknown_Alignment (gnat_entity))
4898 unsigned int double_align, align;
4899 bool is_capped_double, align_clause;
4901 /* If the default alignment of "double" or larger scalar types is
4902 specifically capped and this is not an array with an alignment
4903 clause on the component type, return the cap. */
4904 if ((double_align = double_float_alignment) > 0)
4906 = is_double_float_or_array (gnat_entity, &align_clause);
4907 else if ((double_align = double_scalar_alignment) > 0)
4909 = is_double_scalar_or_array (gnat_entity, &align_clause);
4911 is_capped_double = align_clause = false;
4913 if (is_capped_double && !align_clause)
4914 align = double_align;
4916 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4918 Set_Alignment (gnat_entity, UI_From_Int (align));
4921 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4923 tree gnu_size = TYPE_SIZE (gnu_type);
4925 /* If the size is self-referential, annotate the maximum value. */
4926 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4927 gnu_size = max_size (gnu_size, true);
4929 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4931 /* In this mode, the tag and the parent components are not
4932 generated by the front-end so the sizes must be adjusted. */
4933 tree pointer_size = bitsize_int (POINTER_SIZE), offset;
4936 if (Is_Derived_Type (gnat_entity))
4938 offset = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
4940 Set_Alignment (gnat_entity,
4941 Alignment (Etype (Base_Type (gnat_entity))));
4944 offset = pointer_size;
4946 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4947 gnu_size = size_binop (MULT_EXPR, pointer_size,
4948 size_binop (CEIL_DIV_EXPR,
4951 uint_size = annotate_value (gnu_size);
4952 Set_Esize (gnat_entity, uint_size);
4953 Set_RM_Size (gnat_entity, uint_size);
4956 Set_Esize (gnat_entity, annotate_value (gnu_size));
4959 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4960 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4963 /* If we really have a ..._DECL node, set a couple of flags on it. But we
4964 cannot do so if we are reusing the ..._DECL node made for an alias or a
4965 renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
4966 if (DECL_P (gnu_decl)
4967 && !Present (Alias (gnat_entity))
4968 && !(Present (Renamed_Object (gnat_entity)) && saved))
4970 if (!Comes_From_Source (gnat_entity))
4971 DECL_ARTIFICIAL (gnu_decl) = 1;
4974 DECL_IGNORED_P (gnu_decl) = 1;
4977 /* If we haven't already, associate the ..._DECL node that we just made with
4978 the input GNAT entity node. */
4980 save_gnu_tree (gnat_entity, gnu_decl, false);
4982 /* If this is an enumeration or floating-point type, we were not able to set
4983 the bounds since they refer to the type. These are always static. */
4984 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4985 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4987 tree gnu_scalar_type = gnu_type;
4988 tree gnu_low_bound, gnu_high_bound;
4990 /* If this is a padded type, we need to use the underlying type. */
4991 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4992 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4994 /* If this is a floating point type and we haven't set a floating
4995 point type yet, use this in the evaluation of the bounds. */
4996 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4997 longest_float_type_node = gnu_scalar_type;
4999 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5000 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5002 if (kind == E_Enumeration_Type)
5004 /* Enumeration types have specific RM bounds. */
5005 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5006 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5008 /* Write full debugging information. */
5009 rest_of_type_decl_compilation (gnu_decl);
5014 /* Floating-point types don't have specific RM bounds. */
5015 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5016 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5020 /* If we deferred processing of incomplete types, re-enable it. If there
5021 were no other disables and we have deferred types to process, do so. */
5023 && --defer_incomplete_level == 0
5024 && defer_incomplete_list)
5026 struct incomplete *p, *next;
5028 /* We are back to level 0 for the deferring of incomplete types.
5029 But processing these incomplete types below may itself require
5030 deferring, so preserve what we have and restart from scratch. */
5031 p = defer_incomplete_list;
5032 defer_incomplete_list = NULL;
5034 /* For finalization, however, all types must be complete so we
5035 cannot do the same because deferred incomplete types may end up
5036 referencing each other. Process them all recursively first. */
5037 defer_finalize_level++;
5044 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5045 gnat_to_gnu_type (p->full_type));
5049 defer_finalize_level--;
5052 /* If all the deferred incomplete types have been processed, we can proceed
5053 with the finalization of the deferred types. */
5054 if (defer_incomplete_level == 0
5055 && defer_finalize_level == 0
5056 && defer_finalize_list)
5061 FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t)
5062 rest_of_type_decl_compilation_no_defer (t);
5064 VEC_free (tree, heap, defer_finalize_list);
5067 /* If we are not defining this type, see if it's on one of the lists of
5068 incomplete types. If so, handle the list entry now. */
5069 if (is_type && !definition)
5071 struct incomplete *p;
5073 for (p = defer_incomplete_list; p; p = p->next)
5074 if (p->old_type && p->full_type == gnat_entity)
5076 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5077 TREE_TYPE (gnu_decl));
5078 p->old_type = NULL_TREE;
5081 for (p = defer_limited_with; p; p = p->next)
5082 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5084 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5085 TREE_TYPE (gnu_decl));
5086 p->old_type = NULL_TREE;
5093 /* If this is a packed array type whose original array type is itself
5094 an Itype without freeze node, make sure the latter is processed. */
5095 if (Is_Packed_Array_Type (gnat_entity)
5096 && Is_Itype (Original_Array_Type (gnat_entity))
5097 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5098 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5099 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5104 /* Similar, but if the returned value is a COMPONENT_REF, return the
5108 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5110 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5112 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5113 gnu_field = TREE_OPERAND (gnu_field, 1);
5118 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5119 the GCC type corresponding to that entity. */
5122 gnat_to_gnu_type (Entity_Id gnat_entity)
5126 /* The back end never attempts to annotate generic types. */
5127 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5128 return void_type_node;
5130 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5131 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5133 return TREE_TYPE (gnu_decl);
5136 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5137 the unpadded version of the GCC type corresponding to that entity. */
5140 get_unpadded_type (Entity_Id gnat_entity)
5142 tree type = gnat_to_gnu_type (gnat_entity);
5144 if (TYPE_IS_PADDING_P (type))
5145 type = TREE_TYPE (TYPE_FIELDS (type));
5150 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
5151 Every TYPE_DECL generated for a type definition must be passed
5152 to this function once everything else has been done for it. */
5155 rest_of_type_decl_compilation (tree decl)
5157 /* We need to defer finalizing the type if incomplete types
5158 are being deferred or if they are being processed. */
5159 if (defer_incomplete_level != 0 || defer_finalize_level != 0)
5160 VEC_safe_push (tree, heap, defer_finalize_list, decl);
5162 rest_of_type_decl_compilation_no_defer (decl);
5165 /* Same as above but without deferring the compilation. This
5166 function should not be invoked directly on a TYPE_DECL. */
5169 rest_of_type_decl_compilation_no_defer (tree decl)
5171 const int toplev = global_bindings_p ();
5172 tree t = TREE_TYPE (decl);
5174 rest_of_decl_compilation (decl, toplev, 0);
5176 /* Now process all the variants. This is needed for STABS. */
5177 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
5179 if (t == TREE_TYPE (decl))
5182 if (!TYPE_STUB_DECL (t))
5183 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
5185 rest_of_type_compilation (t, toplev);
5189 /* Finalize the processing of From_With_Type incomplete types. */
5192 finalize_from_with_types (void)
5194 struct incomplete *p, *next;
5196 p = defer_limited_with;
5197 defer_limited_with = NULL;
5204 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5205 gnat_to_gnu_type (p->full_type));
5210 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5211 kind of type (such E_Task_Type) that has a different type which Gigi
5212 uses for its representation. If the type does not have a special type
5213 for its representation, return GNAT_ENTITY. If a type is supposed to
5214 exist, but does not, abort unless annotating types, in which case
5215 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5218 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5220 Entity_Id gnat_equiv = gnat_entity;
5222 if (No (gnat_entity))
5225 switch (Ekind (gnat_entity))
5227 case E_Class_Wide_Subtype:
5228 if (Present (Equivalent_Type (gnat_entity)))
5229 gnat_equiv = Equivalent_Type (gnat_entity);
5232 case E_Access_Protected_Subprogram_Type:
5233 case E_Anonymous_Access_Protected_Subprogram_Type:
5234 gnat_equiv = Equivalent_Type (gnat_entity);
5237 case E_Class_Wide_Type:
5238 gnat_equiv = Root_Type (gnat_entity);
5242 case E_Task_Subtype:
5243 case E_Protected_Type:
5244 case E_Protected_Subtype:
5245 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5252 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5256 /* Return a GCC tree for a type corresponding to the component type of the
5257 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5258 is for an array being defined. DEBUG_INFO_P is true if we need to write
5259 debug information for other types that we may create in the process. */
5262 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5265 const Entity_Id gnat_type = Component_Type (gnat_array);
5266 tree gnu_type = gnat_to_gnu_type (gnat_type);
5269 /* Try to get a smaller form of the component if needed. */
5270 if ((Is_Packed (gnat_array)
5271 || Has_Component_Size_Clause (gnat_array))
5272 && !Is_Bit_Packed_Array (gnat_array)
5273 && !Has_Aliased_Components (gnat_array)
5274 && !Strict_Alignment (gnat_type)
5275 && TREE_CODE (gnu_type) == RECORD_TYPE
5276 && !TYPE_FAT_POINTER_P (gnu_type)
5277 && host_integerp (TYPE_SIZE (gnu_type), 1))
5278 gnu_type = make_packable_type (gnu_type, false);
5280 if (Has_Atomic_Components (gnat_array))
5281 check_ok_for_atomic (gnu_type, gnat_array, true);
5283 /* Get and validate any specified Component_Size. */
5285 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5286 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5287 true, Has_Component_Size_Clause (gnat_array));
5289 /* If the array has aliased components and the component size can be zero,
5290 force at least unit size to ensure that the components have distinct
5293 && Has_Aliased_Components (gnat_array)
5294 && (integer_zerop (TYPE_SIZE (gnu_type))
5295 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5296 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5298 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5300 /* If the component type is a RECORD_TYPE that has a self-referential size,
5301 then use the maximum size for the component size. */
5303 && TREE_CODE (gnu_type) == RECORD_TYPE
5304 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5305 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5307 /* Honor the component size. This is not needed for bit-packed arrays. */
5308 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5310 tree orig_type = gnu_type;
5311 unsigned int max_align;
5313 /* If an alignment is specified, use it as a cap on the component type
5314 so that it can be honored for the whole type. But ignore it for the
5315 original type of packed array types. */
5316 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5317 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5321 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5322 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5323 gnu_type = orig_type;
5325 orig_type = gnu_type;
5327 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5328 true, false, definition, true);
5330 /* If a padding record was made, declare it now since it will never be
5331 declared otherwise. This is necessary to ensure that its subtrees
5332 are properly marked. */
5333 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5334 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5335 debug_info_p, gnat_array);
5338 if (Has_Volatile_Components (gnat_array))
5340 = build_qualified_type (gnu_type,
5341 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5346 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5347 using MECH as its passing mechanism, to be placed in the parameter
5348 list built for GNAT_SUBPROG. Assume a foreign convention for the
5349 latter if FOREIGN is true. Also set CICO to true if the parameter
5350 must use the copy-in copy-out implementation mechanism.
5352 The returned tree is a PARM_DECL, except for those cases where no
5353 parameter needs to be actually passed to the subprogram; the type
5354 of this "shadow" parameter is then returned instead. */
5357 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5358 Entity_Id gnat_subprog, bool foreign, bool *cico)
5360 tree gnu_param_name = get_entity_name (gnat_param);
5361 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5362 tree gnu_param_type_alt = NULL_TREE;
5363 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5364 /* The parameter can be indirectly modified if its address is taken. */
5365 bool ro_param = in_param && !Address_Taken (gnat_param);
5366 bool by_return = false, by_component_ptr = false;
5367 bool by_ref = false, by_double_ref = false;
5370 /* Copy-return is used only for the first parameter of a valued procedure.
5371 It's a copy mechanism for which a parameter is never allocated. */
5372 if (mech == By_Copy_Return)
5374 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5379 /* If this is either a foreign function or if the underlying type won't
5380 be passed by reference, strip off possible padding type. */
5381 if (TYPE_IS_PADDING_P (gnu_param_type))
5383 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5385 if (mech == By_Reference
5387 || (!must_pass_by_ref (unpadded_type)
5388 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5389 gnu_param_type = unpadded_type;
5392 /* If this is a read-only parameter, make a variant of the type that is
5393 read-only. ??? However, if this is an unconstrained array, that type
5394 can be very complex, so skip it for now. Likewise for any other
5395 self-referential type. */
5397 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5398 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5399 gnu_param_type = build_qualified_type (gnu_param_type,
5400 (TYPE_QUALS (gnu_param_type)
5401 | TYPE_QUAL_CONST));
5403 /* For foreign conventions, pass arrays as pointers to the element type.
5404 First check for unconstrained array and get the underlying array. */
5405 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5407 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5409 /* For GCC builtins, pass Address integer types as (void *) */
5410 if (Convention (gnat_subprog) == Convention_Intrinsic
5411 && Present (Interface_Name (gnat_subprog))
5412 && Is_Descendent_Of_Address (Etype (gnat_param)))
5413 gnu_param_type = ptr_void_type_node;
5415 /* VMS descriptors are themselves passed by reference. */
5416 if (mech == By_Short_Descriptor ||
5417 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5419 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5420 Mechanism (gnat_param),
5422 else if (mech == By_Descriptor)
5424 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5425 chosen in fill_vms_descriptor. */
5427 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5428 Mechanism (gnat_param),
5431 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5432 Mechanism (gnat_param),
5436 /* Arrays are passed as pointers to element type for foreign conventions. */
5439 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5441 /* Strip off any multi-dimensional entries, then strip
5442 off the last array to get the component type. */
5443 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5444 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5445 gnu_param_type = TREE_TYPE (gnu_param_type);
5447 by_component_ptr = true;
5448 gnu_param_type = TREE_TYPE (gnu_param_type);
5451 gnu_param_type = build_qualified_type (gnu_param_type,
5452 (TYPE_QUALS (gnu_param_type)
5453 | TYPE_QUAL_CONST));
5455 gnu_param_type = build_pointer_type (gnu_param_type);
5458 /* Fat pointers are passed as thin pointers for foreign conventions. */
5459 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5461 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5463 /* If we must pass or were requested to pass by reference, do so.
5464 If we were requested to pass by copy, do so.
5465 Otherwise, for foreign conventions, pass In Out or Out parameters
5466 or aggregates by reference. For COBOL and Fortran, pass all
5467 integer and FP types that way too. For Convention Ada, use
5468 the standard Ada default. */
5469 else if (must_pass_by_ref (gnu_param_type)
5470 || mech == By_Reference
5473 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5475 && (Convention (gnat_subprog) == Convention_Fortran
5476 || Convention (gnat_subprog) == Convention_COBOL)
5477 && (INTEGRAL_TYPE_P (gnu_param_type)
5478 || FLOAT_TYPE_P (gnu_param_type)))
5480 && default_pass_by_ref (gnu_param_type)))))
5482 gnu_param_type = build_reference_type (gnu_param_type);
5485 /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
5486 passed by reference. Pass them by explicit reference, this will
5487 generate more debuggable code at -O0. */
5488 if (TYPE_IS_FAT_POINTER_P (gnu_param_type)
5489 && targetm.calls.pass_by_reference (pack_cumulative_args (NULL),
5490 TYPE_MODE (gnu_param_type),
5494 gnu_param_type = build_reference_type (gnu_param_type);
5495 by_double_ref = true;
5499 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5503 if (mech == By_Copy && (by_ref || by_component_ptr))
5504 post_error ("?cannot pass & by copy", gnat_param);
5506 /* If this is an Out parameter that isn't passed by reference and isn't
5507 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5508 it will be a VAR_DECL created when we process the procedure, so just
5509 return its type. For the special parameter of a valued procedure,
5512 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5513 Out parameters with discriminants or implicit initial values to be
5514 handled like In Out parameters. These type are normally built as
5515 aggregates, hence passed by reference, except for some packed arrays
5516 which end up encoded in special integer types.
5518 The exception we need to make is then for packed arrays of records
5519 with discriminants or implicit initial values. We have no light/easy
5520 way to check for the latter case, so we merely check for packed arrays
5521 of records. This may lead to useless copy-in operations, but in very
5522 rare cases only, as these would be exceptions in a set of already
5523 exceptional situations. */
5524 if (Ekind (gnat_param) == E_Out_Parameter
5527 || (mech != By_Descriptor
5528 && mech != By_Short_Descriptor
5529 && !POINTER_TYPE_P (gnu_param_type)
5530 && !AGGREGATE_TYPE_P (gnu_param_type)))
5531 && !(Is_Array_Type (Etype (gnat_param))
5532 && Is_Packed (Etype (gnat_param))
5533 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5534 return gnu_param_type;
5536 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5537 ro_param || by_ref || by_component_ptr);
5538 DECL_BY_REF_P (gnu_param) = by_ref;
5539 DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref;
5540 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5541 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5542 mech == By_Short_Descriptor);
5543 DECL_POINTS_TO_READONLY_P (gnu_param)
5544 = (ro_param && (by_ref || by_component_ptr));
5546 /* Save the alternate descriptor type, if any. */
5547 if (gnu_param_type_alt)
5548 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5550 /* If no Mechanism was specified, indicate what we're using, then
5551 back-annotate it. */
5552 if (mech == Default)
5553 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5555 Set_Mechanism (gnat_param, mech);
5559 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5562 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5564 while (Present (Corresponding_Discriminant (discr1)))
5565 discr1 = Corresponding_Discriminant (discr1);
5567 while (Present (Corresponding_Discriminant (discr2)))
5568 discr2 = Corresponding_Discriminant (discr2);
5571 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5574 /* Return true if the array type GNU_TYPE, which represents a dimension of
5575 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5578 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5580 /* If the array type is not the innermost dimension of the GNAT type,
5581 then it has a non-aliased component. */
5582 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5583 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5586 /* If the array type has an aliased component in the front-end sense,
5587 then it also has an aliased component in the back-end sense. */
5588 if (Has_Aliased_Components (gnat_type))
5591 /* If this is a derived type, then it has a non-aliased component if
5592 and only if its parent type also has one. */
5593 if (Is_Derived_Type (gnat_type))
5595 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5597 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5599 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5600 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5601 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5602 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5605 /* Otherwise, rely exclusively on properties of the element type. */
5606 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5609 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5612 compile_time_known_address_p (Node_Id gnat_address)
5614 /* Catch System'To_Address. */
5615 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5616 gnat_address = Expression (gnat_address);
5618 return Compile_Time_Known_Value (gnat_address);
5621 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5622 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5625 cannot_be_superflat_p (Node_Id gnat_range)
5627 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5628 Node_Id scalar_range;
5629 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5631 /* If the low bound is not constant, try to find an upper bound. */
5632 while (Nkind (gnat_lb) != N_Integer_Literal
5633 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5634 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5635 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5636 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5637 || Nkind (scalar_range) == N_Range))
5638 gnat_lb = High_Bound (scalar_range);
5640 /* If the high bound is not constant, try to find a lower bound. */
5641 while (Nkind (gnat_hb) != N_Integer_Literal
5642 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5643 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5644 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5645 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5646 || Nkind (scalar_range) == N_Range))
5647 gnat_hb = Low_Bound (scalar_range);
5649 /* If we have failed to find constant bounds, punt. */
5650 if (Nkind (gnat_lb) != N_Integer_Literal
5651 || Nkind (gnat_hb) != N_Integer_Literal)
5654 /* We need at least a signed 64-bit type to catch most cases. */
5655 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5656 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5657 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5660 /* If the low bound is the smallest integer, nothing can be smaller. */
5661 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5662 if (TREE_OVERFLOW (gnu_lb_minus_one))
5665 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5668 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5671 constructor_address_p (tree gnu_expr)
5673 while (TREE_CODE (gnu_expr) == NOP_EXPR
5674 || TREE_CODE (gnu_expr) == CONVERT_EXPR
5675 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5676 gnu_expr = TREE_OPERAND (gnu_expr, 0);
5678 return (TREE_CODE (gnu_expr) == ADDR_EXPR
5679 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5682 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5683 be elaborated at the point of its definition, but do nothing else. */
5686 elaborate_entity (Entity_Id gnat_entity)
5688 switch (Ekind (gnat_entity))
5690 case E_Signed_Integer_Subtype:
5691 case E_Modular_Integer_Subtype:
5692 case E_Enumeration_Subtype:
5693 case E_Ordinary_Fixed_Point_Subtype:
5694 case E_Decimal_Fixed_Point_Subtype:
5695 case E_Floating_Point_Subtype:
5697 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5698 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5700 /* ??? Tests to avoid Constraint_Error in static expressions
5701 are needed until after the front stops generating bogus
5702 conversions on bounds of real types. */
5703 if (!Raises_Constraint_Error (gnat_lb))
5704 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5705 true, false, Needs_Debug_Info (gnat_entity));
5706 if (!Raises_Constraint_Error (gnat_hb))
5707 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5708 true, false, Needs_Debug_Info (gnat_entity));
5714 Node_Id full_definition = Declaration_Node (gnat_entity);
5715 Node_Id record_definition = Type_Definition (full_definition);
5717 /* If this is a record extension, go a level further to find the
5718 record definition. */
5719 if (Nkind (record_definition) == N_Derived_Type_Definition)
5720 record_definition = Record_Extension_Part (record_definition);
5724 case E_Record_Subtype:
5725 case E_Private_Subtype:
5726 case E_Limited_Private_Subtype:
5727 case E_Record_Subtype_With_Private:
5728 if (Is_Constrained (gnat_entity)
5729 && Has_Discriminants (gnat_entity)
5730 && Present (Discriminant_Constraint (gnat_entity)))
5732 Node_Id gnat_discriminant_expr;
5733 Entity_Id gnat_field;
5736 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5737 gnat_discriminant_expr
5738 = First_Elmt (Discriminant_Constraint (gnat_entity));
5739 Present (gnat_field);
5740 gnat_field = Next_Discriminant (gnat_field),
5741 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5742 /* ??? For now, ignore access discriminants. */
5743 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5744 elaborate_expression (Node (gnat_discriminant_expr),
5745 gnat_entity, get_entity_name (gnat_field),
5746 true, false, false);
5753 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5754 any entities on its entity chain similarly. */
5757 mark_out_of_scope (Entity_Id gnat_entity)
5759 Entity_Id gnat_sub_entity;
5760 unsigned int kind = Ekind (gnat_entity);
5762 /* If this has an entity list, process all in the list. */
5763 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5764 || IN (kind, Private_Kind)
5765 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5766 || kind == E_Function || kind == E_Generic_Function
5767 || kind == E_Generic_Package || kind == E_Generic_Procedure
5768 || kind == E_Loop || kind == E_Operator || kind == E_Package
5769 || kind == E_Package_Body || kind == E_Procedure
5770 || kind == E_Record_Type || kind == E_Record_Subtype
5771 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5772 for (gnat_sub_entity = First_Entity (gnat_entity);
5773 Present (gnat_sub_entity);
5774 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5775 if (Scope (gnat_sub_entity) == gnat_entity
5776 && gnat_sub_entity != gnat_entity)
5777 mark_out_of_scope (gnat_sub_entity);
5779 /* Now clear this if it has been defined, but only do so if it isn't
5780 a subprogram or parameter. We could refine this, but it isn't
5781 worth it. If this is statically allocated, it is supposed to
5782 hang around out of cope. */
5783 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5784 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5786 save_gnu_tree (gnat_entity, NULL_TREE, true);
5787 save_gnu_tree (gnat_entity, error_mark_node, true);
5791 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5792 If this is a multi-dimensional array type, do this recursively.
5795 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5796 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5797 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5800 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5802 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5803 of a one-dimensional array, since the padding has the same alias set
5804 as the field type, but if it's a multi-dimensional array, we need to
5805 see the inner types. */
5806 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5807 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5808 || TYPE_PADDING_P (gnu_old_type)))
5809 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5811 /* Unconstrained array types are deemed incomplete and would thus be given
5812 alias set 0. Retrieve the underlying array type. */
5813 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5815 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5816 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5818 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5820 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5821 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5822 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5823 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5827 case ALIAS_SET_COPY:
5828 /* The alias set shouldn't be copied between array types with different
5829 aliasing settings because this can break the aliasing relationship
5830 between the array type and its element type. */
5831 #ifndef ENABLE_CHECKING
5832 if (flag_strict_aliasing)
5834 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5835 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5836 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5837 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5839 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5842 case ALIAS_SET_SUBSET:
5843 case ALIAS_SET_SUPERSET:
5845 alias_set_type old_set = get_alias_set (gnu_old_type);
5846 alias_set_type new_set = get_alias_set (gnu_new_type);
5848 /* Do nothing if the alias sets conflict. This ensures that we
5849 never call record_alias_subset several times for the same pair
5850 or at all for alias set 0. */
5851 if (!alias_sets_conflict_p (old_set, new_set))
5853 if (op == ALIAS_SET_SUBSET)
5854 record_alias_subset (old_set, new_set);
5856 record_alias_subset (new_set, old_set);
5865 record_component_aliases (gnu_new_type);
5868 /* Return true if the size represented by GNU_SIZE can be handled by an
5869 allocation. If STATIC_P is true, consider only what can be done with a
5870 static allocation. */
5873 allocatable_size_p (tree gnu_size, bool static_p)
5875 HOST_WIDE_INT our_size;
5877 /* If this is not a static allocation, the only case we want to forbid
5878 is an overflowing size. That will be converted into a raise a
5881 return !(TREE_CODE (gnu_size) == INTEGER_CST
5882 && TREE_OVERFLOW (gnu_size));
5884 /* Otherwise, we need to deal with both variable sizes and constant
5885 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5886 since assemblers may not like very large sizes. */
5887 if (!host_integerp (gnu_size, 1))
5890 our_size = tree_low_cst (gnu_size, 1);
5891 return (int) our_size == our_size;
5894 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5895 NAME, ARGS and ERROR_POINT. */
5898 prepend_one_attribute_to (struct attrib ** attr_list,
5899 enum attr_type attr_type,
5902 Node_Id attr_error_point)
5904 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5906 attr->type = attr_type;
5907 attr->name = attr_name;
5908 attr->args = attr_args;
5909 attr->error_point = attr_error_point;
5911 attr->next = *attr_list;
5915 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5918 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5922 /* Attributes are stored as Representation Item pragmas. */
5924 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5925 gnat_temp = Next_Rep_Item (gnat_temp))
5926 if (Nkind (gnat_temp) == N_Pragma)
5928 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5929 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5930 enum attr_type etype;
5932 /* Map the kind of pragma at hand. Skip if this is not one
5933 we know how to handle. */
5935 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5937 case Pragma_Machine_Attribute:
5938 etype = ATTR_MACHINE_ATTRIBUTE;
5941 case Pragma_Linker_Alias:
5942 etype = ATTR_LINK_ALIAS;
5945 case Pragma_Linker_Section:
5946 etype = ATTR_LINK_SECTION;
5949 case Pragma_Linker_Constructor:
5950 etype = ATTR_LINK_CONSTRUCTOR;
5953 case Pragma_Linker_Destructor:
5954 etype = ATTR_LINK_DESTRUCTOR;
5957 case Pragma_Weak_External:
5958 etype = ATTR_WEAK_EXTERNAL;
5961 case Pragma_Thread_Local_Storage:
5962 etype = ATTR_THREAD_LOCAL_STORAGE;
5969 /* See what arguments we have and turn them into GCC trees for
5970 attribute handlers. These expect identifier for strings. We
5971 handle at most two arguments, static expressions only. */
5973 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5975 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5976 Node_Id gnat_arg1 = Empty;
5978 if (Present (gnat_arg0)
5979 && Is_Static_Expression (Expression (gnat_arg0)))
5981 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5983 if (TREE_CODE (gnu_arg0) == STRING_CST)
5984 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5986 gnat_arg1 = Next (gnat_arg0);
5989 if (Present (gnat_arg1)
5990 && Is_Static_Expression (Expression (gnat_arg1)))
5992 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5994 if (TREE_CODE (gnu_arg1) == STRING_CST)
5995 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
5999 /* Prepend to the list now. Make a list of the argument we might
6000 have, as GCC expects it. */
6001 prepend_one_attribute_to
6004 (gnu_arg1 != NULL_TREE)
6005 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6006 Present (Next (First (gnat_assoc)))
6007 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
6011 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6012 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6013 return the GCC tree to use for that expression. GNU_NAME is the suffix
6014 to use if a variable needs to be created and DEFINITION is true if this
6015 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6016 otherwise, we are just elaborating the expression for side-effects. If
6017 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6018 isn't needed for code generation. */
6021 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
6022 bool definition, bool need_value, bool need_debug)
6026 /* If we already elaborated this expression (e.g. it was involved
6027 in the definition of a private type), use the old value. */
6028 if (present_gnu_tree (gnat_expr))
6029 return get_gnu_tree (gnat_expr);
6031 /* If we don't need a value and this is static or a discriminant,
6032 we don't need to do anything. */
6034 && (Is_OK_Static_Expression (gnat_expr)
6035 || (Nkind (gnat_expr) == N_Identifier
6036 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6039 /* If it's a static expression, we don't need a variable for debugging. */
6040 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6043 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6044 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
6045 gnu_name, definition, need_debug);
6047 /* Save the expression in case we try to elaborate this entity again. Since
6048 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6049 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6050 save_gnu_tree (gnat_expr, gnu_expr, true);
6052 return need_value ? gnu_expr : error_mark_node;
6055 /* Similar, but take a GNU expression and always return a result. */
6058 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6059 bool definition, bool need_debug)
6061 const bool expr_global_p = Is_Public (gnat_entity) || global_bindings_p ();
6062 bool expr_variable_p, use_variable;
6064 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6065 reference will have been replaced with a COMPONENT_REF when the type
6066 is being elaborated. However, there are some cases involving child
6067 types where we will. So convert it to a COMPONENT_REF. We hope it
6068 will be at the highest level of the expression in these cases. */
6069 if (TREE_CODE (gnu_expr) == FIELD_DECL)
6070 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
6071 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
6072 gnu_expr, NULL_TREE);
6074 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6075 that an expression cannot contain both a discriminant and a variable. */
6076 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6079 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6080 a variable that is initialized to contain the expression when the package
6081 containing the definition is elaborated. If this entity is defined at top
6082 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6083 if this is necessary. */
6084 if (CONSTANT_CLASS_P (gnu_expr))
6085 expr_variable_p = false;
6088 /* Skip any conversions and simple arithmetics to see if the expression
6089 is based on a read-only variable.
6090 ??? This really should remain read-only, but we have to think about
6091 the typing of the tree here. */
6093 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
6095 if (handled_component_p (inner))
6097 HOST_WIDE_INT bitsize, bitpos;
6099 enum machine_mode mode;
6100 int unsignedp, volatilep;
6102 inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
6103 &mode, &unsignedp, &volatilep, false);
6104 /* If the offset is variable, err on the side of caution. */
6111 && TREE_CODE (inner) == VAR_DECL
6112 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6115 /* We only need to use the variable if we are in a global context since GCC
6116 can do the right thing in the local case. However, when not optimizing,
6117 use it for bounds of loop iteration scheme to avoid code duplication. */
6118 use_variable = expr_variable_p
6121 && Is_Itype (gnat_entity)
6122 && Nkind (Associated_Node_For_Itype (gnat_entity))
6123 == N_Loop_Parameter_Specification));
6125 /* Now create it, possibly only for debugging purposes. */
6126 if (use_variable || need_debug)
6129 = create_var_decl (create_concat_name (gnat_entity,
6130 IDENTIFIER_POINTER (gnu_name)),
6131 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
6132 !need_debug, Is_Public (gnat_entity),
6133 !definition, expr_global_p, NULL, gnat_entity);
6139 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6142 /* Similar, but take an alignment factor and make it explicit in the tree. */
6145 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6146 bool definition, bool need_debug, unsigned int align)
6148 tree unit_align = size_int (align / BITS_PER_UNIT);
6150 size_binop (MULT_EXPR,
6151 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6154 gnat_entity, gnu_name, definition,
6159 /* Create a record type that contains a SIZE bytes long field of TYPE with a
6160 starting bit position so that it is aligned to ALIGN bits, and leaving at
6161 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
6162 record is guaranteed to get. */
6165 make_aligning_type (tree type, unsigned int align, tree size,
6166 unsigned int base_align, int room)
6168 /* We will be crafting a record type with one field at a position set to be
6169 the next multiple of ALIGN past record'address + room bytes. We use a
6170 record placeholder to express record'address. */
6171 tree record_type = make_node (RECORD_TYPE);
6172 tree record = build0 (PLACEHOLDER_EXPR, record_type);
6175 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
6177 /* The diagram below summarizes the shape of what we manipulate:
6179 <--------- pos ---------->
6180 { +------------+-------------+-----------------+
6181 record =>{ |############| ... | field (type) |
6182 { +------------+-------------+-----------------+
6183 |<-- room -->|<- voffset ->|<---- size ----->|
6186 record_addr vblock_addr
6188 Every length is in sizetype bytes there, except "pos" which has to be
6189 set as a bit position in the GCC tree for the record. */
6190 tree room_st = size_int (room);
6191 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
6192 tree voffset_st, pos, field;
6194 tree name = TYPE_NAME (type);
6196 if (TREE_CODE (name) == TYPE_DECL)
6197 name = DECL_NAME (name);
6198 name = concat_name (name, "ALIGN");
6199 TYPE_NAME (record_type) = name;
6201 /* Compute VOFFSET and then POS. The next byte position multiple of some
6202 alignment after some address is obtained by "and"ing the alignment minus
6203 1 with the two's complement of the address. */
6204 voffset_st = size_binop (BIT_AND_EXPR,
6205 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st),
6206 size_int ((align / BITS_PER_UNIT) - 1));
6208 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
6209 pos = size_binop (MULT_EXPR,
6210 convert (bitsizetype,
6211 size_binop (PLUS_EXPR, room_st, voffset_st)),
6214 /* Craft the GCC record representation. We exceptionally do everything
6215 manually here because 1) our generic circuitry is not quite ready to
6216 handle the complex position/size expressions we are setting up, 2) we
6217 have a strong simplifying factor at hand: we know the maximum possible
6218 value of voffset, and 3) we have to set/reset at least the sizes in
6219 accordance with this maximum value anyway, as we need them to convey
6220 what should be "alloc"ated for this type.
6222 Use -1 as the 'addressable' indication for the field to prevent the
6223 creation of a bitfield. We don't need one, it would have damaging
6224 consequences on the alignment computation, and create_field_decl would
6225 make one without this special argument, for instance because of the
6226 complex position expression. */
6227 field = create_field_decl (get_identifier ("F"), type, record_type, size,
6229 TYPE_FIELDS (record_type) = field;
6231 TYPE_ALIGN (record_type) = base_align;
6232 TYPE_USER_ALIGN (record_type) = 1;
6234 TYPE_SIZE (record_type)
6235 = size_binop (PLUS_EXPR,
6236 size_binop (MULT_EXPR, convert (bitsizetype, size),
6238 bitsize_int (align + room * BITS_PER_UNIT));
6239 TYPE_SIZE_UNIT (record_type)
6240 = size_binop (PLUS_EXPR, size,
6241 size_int (room + align / BITS_PER_UNIT));
6243 SET_TYPE_MODE (record_type, BLKmode);
6244 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
6246 /* Declare it now since it will never be declared otherwise. This is
6247 necessary to ensure that its subtrees are properly marked. */
6248 create_type_decl (name, record_type, NULL, true, false, Empty);
6253 /* Return the result of rounding T up to ALIGN. */
6255 static inline unsigned HOST_WIDE_INT
6256 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
6264 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
6265 as the field type of a packed record if IN_RECORD is true, or as the
6266 component type of a packed array if IN_RECORD is false. See if we can
6267 rewrite it either as a type that has a non-BLKmode, which we can pack
6268 tighter in the packed record case, or as a smaller type. If so, return
6269 the new type. If not, return the original type. */
6272 make_packable_type (tree type, bool in_record)
6274 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
6275 unsigned HOST_WIDE_INT new_size;
6276 tree new_type, old_field, field_list = NULL_TREE;
6278 /* No point in doing anything if the size is zero. */
6282 new_type = make_node (TREE_CODE (type));
6284 /* Copy the name and flags from the old type to that of the new.
6285 Note that we rely on the pointer equality created here for
6286 TYPE_NAME to look through conversions in various places. */
6287 TYPE_NAME (new_type) = TYPE_NAME (type);
6288 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
6289 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
6290 if (TREE_CODE (type) == RECORD_TYPE)
6291 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
6293 /* If we are in a record and have a small size, set the alignment to
6294 try for an integral mode. Otherwise set it to try for a smaller
6295 type with BLKmode. */
6296 if (in_record && size <= MAX_FIXED_MODE_SIZE)
6298 TYPE_ALIGN (new_type) = ceil_alignment (size);
6299 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
6303 unsigned HOST_WIDE_INT align;
6305 /* Do not try to shrink the size if the RM size is not constant. */
6306 if (TYPE_CONTAINS_TEMPLATE_P (type)
6307 || !host_integerp (TYPE_ADA_SIZE (type), 1))
6310 /* Round the RM size up to a unit boundary to get the minimal size
6311 for a BLKmode record. Give up if it's already the size. */
6312 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
6313 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
6314 if (new_size == size)
6317 align = new_size & -new_size;
6318 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
6321 TYPE_USER_ALIGN (new_type) = 1;
6323 /* Now copy the fields, keeping the position and size as we don't want
6324 to change the layout by propagating the packedness downwards. */
6325 for (old_field = TYPE_FIELDS (type); old_field;
6326 old_field = DECL_CHAIN (old_field))
6328 tree new_field_type = TREE_TYPE (old_field);
6329 tree new_field, new_size;
6331 if ((TREE_CODE (new_field_type) == RECORD_TYPE
6332 || TREE_CODE (new_field_type) == UNION_TYPE
6333 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6334 && !TYPE_FAT_POINTER_P (new_field_type)
6335 && host_integerp (TYPE_SIZE (new_field_type), 1))
6336 new_field_type = make_packable_type (new_field_type, true);
6338 /* However, for the last field in a not already packed record type
6339 that is of an aggregate type, we need to use the RM size in the
6340 packable version of the record type, see finish_record_type. */
6341 if (!DECL_CHAIN (old_field)
6342 && !TYPE_PACKED (type)
6343 && (TREE_CODE (new_field_type) == RECORD_TYPE
6344 || TREE_CODE (new_field_type) == UNION_TYPE
6345 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6346 && !TYPE_FAT_POINTER_P (new_field_type)
6347 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6348 && TYPE_ADA_SIZE (new_field_type))
6349 new_size = TYPE_ADA_SIZE (new_field_type);
6351 new_size = DECL_SIZE (old_field);
6354 = create_field_decl (DECL_NAME (old_field), new_field_type, new_type,
6355 new_size, bit_position (old_field),
6357 !DECL_NONADDRESSABLE_P (old_field));
6359 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6360 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
6361 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6362 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6364 DECL_CHAIN (new_field) = field_list;
6365 field_list = new_field;
6368 finish_record_type (new_type, nreverse (field_list), 2, false);
6369 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6370 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
6371 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
6373 /* If this is a padding record, we never want to make the size smaller
6374 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6375 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6377 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6378 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6383 TYPE_SIZE (new_type) = bitsize_int (new_size);
6384 TYPE_SIZE_UNIT (new_type)
6385 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6388 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6389 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6391 compute_record_mode (new_type);
6393 /* Try harder to get a packable type if necessary, for example
6394 in case the record itself contains a BLKmode field. */
6395 if (in_record && TYPE_MODE (new_type) == BLKmode)
6396 SET_TYPE_MODE (new_type,
6397 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6399 /* If neither the mode nor the size has shrunk, return the old type. */
6400 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6406 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6407 if needed. We have already verified that SIZE and TYPE are large enough.
6408 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6409 IS_COMPONENT_TYPE is true if this is being done for the component type
6410 of an array. IS_USER_TYPE is true if we must complete the original type.
6411 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6412 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6413 it's set to the RM size of the original type. */
6416 maybe_pad_type (tree type, tree size, unsigned int align,
6417 Entity_Id gnat_entity, bool is_component_type,
6418 bool is_user_type, bool definition, bool same_rm_size)
6420 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6421 tree orig_size = TYPE_SIZE (type);
6424 /* If TYPE is a padded type, see if it agrees with any size and alignment
6425 we were given. If so, return the original type. Otherwise, strip
6426 off the padding, since we will either be returning the inner type
6427 or repadding it. If no size or alignment is specified, use that of
6428 the original padded type. */
6429 if (TYPE_IS_PADDING_P (type))
6432 || operand_equal_p (round_up (size,
6433 MAX (align, TYPE_ALIGN (type))),
6434 round_up (TYPE_SIZE (type),
6435 MAX (align, TYPE_ALIGN (type))),
6437 && (align == 0 || align == TYPE_ALIGN (type)))
6441 size = TYPE_SIZE (type);
6443 align = TYPE_ALIGN (type);
6445 type = TREE_TYPE (TYPE_FIELDS (type));
6446 orig_size = TYPE_SIZE (type);
6449 /* If the size is either not being changed or is being made smaller (which
6450 is not done here and is only valid for bitfields anyway), show the size
6451 isn't changing. Likewise, clear the alignment if it isn't being
6452 changed. Then return if we aren't doing anything. */
6454 && (operand_equal_p (size, orig_size, 0)
6455 || (TREE_CODE (orig_size) == INTEGER_CST
6456 && tree_int_cst_lt (size, orig_size))))
6459 if (align == TYPE_ALIGN (type))
6462 if (align == 0 && !size)
6465 /* If requested, complete the original type and give it a name. */
6467 create_type_decl (get_entity_name (gnat_entity), type,
6468 NULL, !Comes_From_Source (gnat_entity),
6470 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6471 && DECL_IGNORED_P (TYPE_NAME (type))),
6474 /* We used to modify the record in place in some cases, but that could
6475 generate incorrect debugging information. So make a new record
6477 record = make_node (RECORD_TYPE);
6478 TYPE_PADDING_P (record) = 1;
6480 if (Present (gnat_entity))
6481 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6483 TYPE_VOLATILE (record)
6484 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6486 TYPE_ALIGN (record) = align;
6487 TYPE_SIZE (record) = size ? size : orig_size;
6488 TYPE_SIZE_UNIT (record)
6489 = convert (sizetype,
6490 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6491 bitsize_unit_node));
6493 /* If we are changing the alignment and the input type is a record with
6494 BLKmode and a small constant size, try to make a form that has an
6495 integral mode. This might allow the padding record to also have an
6496 integral mode, which will be much more efficient. There is no point
6497 in doing so if a size is specified unless it is also a small constant
6498 size and it is incorrect to do so if we cannot guarantee that the mode
6499 will be naturally aligned since the field must always be addressable.
6501 ??? This might not always be a win when done for a stand-alone object:
6502 since the nominal and the effective type of the object will now have
6503 different modes, a VIEW_CONVERT_EXPR will be required for converting
6504 between them and it might be hard to overcome afterwards, including
6505 at the RTL level when the stand-alone object is accessed as a whole. */
6507 && TREE_CODE (type) == RECORD_TYPE
6508 && TYPE_MODE (type) == BLKmode
6509 && TREE_CODE (orig_size) == INTEGER_CST
6510 && !TREE_OVERFLOW (orig_size)
6511 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6513 || (TREE_CODE (size) == INTEGER_CST
6514 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6516 tree packable_type = make_packable_type (type, true);
6517 if (TYPE_MODE (packable_type) != BLKmode
6518 && align >= TYPE_ALIGN (packable_type))
6519 type = packable_type;
6522 /* Now create the field with the original size. */
6523 field = create_field_decl (get_identifier ("F"), type, record, orig_size,
6524 bitsize_zero_node, 0, 1);
6525 DECL_INTERNAL_P (field) = 1;
6527 /* Do not emit debug info until after the auxiliary record is built. */
6528 finish_record_type (record, field, 1, false);
6530 /* Set the same size for its RM size if requested; otherwise reuse
6531 the RM size of the original type. */
6532 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6534 /* Unless debugging information isn't being written for the input type,
6535 write a record that shows what we are a subtype of and also make a
6536 variable that indicates our size, if still variable. */
6537 if (TREE_CODE (orig_size) != INTEGER_CST
6538 && TYPE_NAME (record)
6540 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6541 && DECL_IGNORED_P (TYPE_NAME (type))))
6543 tree marker = make_node (RECORD_TYPE);
6544 tree name = TYPE_NAME (record);
6545 tree orig_name = TYPE_NAME (type);
6547 if (TREE_CODE (name) == TYPE_DECL)
6548 name = DECL_NAME (name);
6550 if (TREE_CODE (orig_name) == TYPE_DECL)
6551 orig_name = DECL_NAME (orig_name);
6553 TYPE_NAME (marker) = concat_name (name, "XVS");
6554 finish_record_type (marker,
6555 create_field_decl (orig_name,
6556 build_reference_type (type),
6557 marker, NULL_TREE, NULL_TREE,
6561 add_parallel_type (TYPE_STUB_DECL (record), marker);
6563 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6564 TYPE_SIZE_UNIT (marker)
6565 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6566 TYPE_SIZE_UNIT (record), false, false, false,
6567 false, NULL, gnat_entity);
6570 rest_of_record_type_compilation (record);
6572 /* If the size was widened explicitly, maybe give a warning. Take the
6573 original size as the maximum size of the input if there was an
6574 unconstrained record involved and round it up to the specified alignment,
6575 if one was specified. */
6576 if (CONTAINS_PLACEHOLDER_P (orig_size))
6577 orig_size = max_size (orig_size, true);
6580 orig_size = round_up (orig_size, align);
6582 if (Present (gnat_entity)
6584 && TREE_CODE (size) != MAX_EXPR
6585 && TREE_CODE (size) != COND_EXPR
6586 && !operand_equal_p (size, orig_size, 0)
6587 && !(TREE_CODE (size) == INTEGER_CST
6588 && TREE_CODE (orig_size) == INTEGER_CST
6589 && (TREE_OVERFLOW (size)
6590 || TREE_OVERFLOW (orig_size)
6591 || tree_int_cst_lt (size, orig_size))))
6593 Node_Id gnat_error_node = Empty;
6595 if (Is_Packed_Array_Type (gnat_entity))
6596 gnat_entity = Original_Array_Type (gnat_entity);
6598 if ((Ekind (gnat_entity) == E_Component
6599 || Ekind (gnat_entity) == E_Discriminant)
6600 && Present (Component_Clause (gnat_entity)))
6601 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6602 else if (Present (Size_Clause (gnat_entity)))
6603 gnat_error_node = Expression (Size_Clause (gnat_entity));
6605 /* Generate message only for entities that come from source, since
6606 if we have an entity created by expansion, the message will be
6607 generated for some other corresponding source entity. */
6608 if (Comes_From_Source (gnat_entity))
6610 if (Present (gnat_error_node))
6611 post_error_ne_tree ("{^ }bits of & unused?",
6612 gnat_error_node, gnat_entity,
6613 size_diffop (size, orig_size));
6614 else if (is_component_type)
6615 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6616 gnat_entity, gnat_entity,
6617 size_diffop (size, orig_size));
6624 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6625 the value passed against the list of choices. */
6628 choices_to_gnu (tree operand, Node_Id choices)
6632 tree result = boolean_false_node;
6633 tree this_test, low = 0, high = 0, single = 0;
6635 for (choice = First (choices); Present (choice); choice = Next (choice))
6637 switch (Nkind (choice))
6640 low = gnat_to_gnu (Low_Bound (choice));
6641 high = gnat_to_gnu (High_Bound (choice));
6644 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6645 build_binary_op (GE_EXPR, boolean_type_node,
6647 build_binary_op (LE_EXPR, boolean_type_node,
6652 case N_Subtype_Indication:
6653 gnat_temp = Range_Expression (Constraint (choice));
6654 low = gnat_to_gnu (Low_Bound (gnat_temp));
6655 high = gnat_to_gnu (High_Bound (gnat_temp));
6658 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6659 build_binary_op (GE_EXPR, boolean_type_node,
6661 build_binary_op (LE_EXPR, boolean_type_node,
6666 case N_Expanded_Name:
6667 /* This represents either a subtype range, an enumeration
6668 literal, or a constant Ekind says which. If an enumeration
6669 literal or constant, fall through to the next case. */
6670 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6671 && Ekind (Entity (choice)) != E_Constant)
6673 tree type = gnat_to_gnu_type (Entity (choice));
6675 low = TYPE_MIN_VALUE (type);
6676 high = TYPE_MAX_VALUE (type);
6679 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6680 build_binary_op (GE_EXPR, boolean_type_node,
6682 build_binary_op (LE_EXPR, boolean_type_node,
6687 /* ... fall through ... */
6689 case N_Character_Literal:
6690 case N_Integer_Literal:
6691 single = gnat_to_gnu (choice);
6692 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6696 case N_Others_Choice:
6697 this_test = boolean_true_node;
6704 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6711 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6712 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6715 adjust_packed (tree field_type, tree record_type, int packed)
6717 /* If the field contains an item of variable size, we cannot pack it
6718 because we cannot create temporaries of non-fixed size in case
6719 we need to take the address of the field. See addressable_p and
6720 the notes on the addressability issues for further details. */
6721 if (is_variable_size (field_type))
6724 /* If the alignment of the record is specified and the field type
6725 is over-aligned, request Storage_Unit alignment for the field. */
6728 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6737 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6738 placed in GNU_RECORD_TYPE.
6740 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6741 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6742 record has a specified alignment.
6744 DEFINITION is true if this field is for a record being defined.
6746 DEBUG_INFO_P is true if we need to write debug information for types
6747 that we may create in the process. */
6750 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6751 bool definition, bool debug_info_p)
6753 const Entity_Id gnat_field_type = Etype (gnat_field);
6754 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6755 tree gnu_field_id = get_entity_name (gnat_field);
6756 tree gnu_field, gnu_size, gnu_pos;
6758 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6759 bool needs_strict_alignment
6761 || Is_Aliased (gnat_field)
6762 || Strict_Alignment (gnat_field_type));
6764 /* If this field requires strict alignment, we cannot pack it because
6765 it would very likely be under-aligned in the record. */
6766 if (needs_strict_alignment)
6769 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6771 /* If a size is specified, use it. Otherwise, if the record type is packed,
6772 use the official RM size. See "Handling of Type'Size Values" in Einfo
6773 for further details. */
6774 if (Known_Static_Esize (gnat_field))
6775 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6776 gnat_field, FIELD_DECL, false, true);
6777 else if (packed == 1)
6778 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6779 gnat_field, FIELD_DECL, false, true);
6781 gnu_size = NULL_TREE;
6783 /* If we have a specified size that is smaller than that of the field's type,
6784 or a position is specified, and the field's type is a record that doesn't
6785 require strict alignment, see if we can get either an integral mode form
6786 of the type or a smaller form. If we can, show a size was specified for
6787 the field if there wasn't one already, so we know to make this a bitfield
6788 and avoid making things wider.
6790 Changing to an integral mode form is useful when the record is packed as
6791 we can then place the field at a non-byte-aligned position and so achieve
6792 tighter packing. This is in addition required if the field shares a byte
6793 with another field and the front-end lets the back-end handle the access
6794 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6796 Changing to a smaller form is required if the specified size is smaller
6797 than that of the field's type and the type contains sub-fields that are
6798 padded, in order to avoid generating accesses to these sub-fields that
6799 are wider than the field.
6801 We avoid the transformation if it is not required or potentially useful,
6802 as it might entail an increase of the field's alignment and have ripple
6803 effects on the outer record type. A typical case is a field known to be
6804 byte-aligned and not to share a byte with another field. */
6805 if (!needs_strict_alignment
6806 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6807 && !TYPE_FAT_POINTER_P (gnu_field_type)
6808 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6811 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6812 || (Present (Component_Clause (gnat_field))
6813 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6814 % BITS_PER_UNIT == 0
6815 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6817 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6818 if (gnu_packable_type != gnu_field_type)
6820 gnu_field_type = gnu_packable_type;
6822 gnu_size = rm_size (gnu_field_type);
6826 /* If we are packing the record and the field is BLKmode, round the
6827 size up to a byte boundary. */
6828 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6829 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6831 if (Present (Component_Clause (gnat_field)))
6833 Entity_Id gnat_parent
6834 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6836 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6837 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6838 gnat_field, FIELD_DECL, false, true);
6840 /* Ensure the position does not overlap with the parent subtype, if there
6841 is one. This test is omitted if the parent of the tagged type has a
6842 full rep clause since, in this case, component clauses are allowed to
6843 overlay the space allocated for the parent type and the front-end has
6844 checked that there are no overlapping components. */
6845 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6847 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6849 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6850 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6853 ("offset of& must be beyond parent{, minimum allowed is ^}",
6854 First_Bit (Component_Clause (gnat_field)), gnat_field,
6855 TYPE_SIZE_UNIT (gnu_parent));
6859 /* If this field needs strict alignment, ensure the record is
6860 sufficiently aligned and that that position and size are
6861 consistent with the alignment. */
6862 if (needs_strict_alignment)
6864 TYPE_ALIGN (gnu_record_type)
6865 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6868 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6870 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
6872 ("atomic field& must be natural size of type{ (^)}",
6873 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6874 TYPE_SIZE (gnu_field_type));
6876 else if (Is_Aliased (gnat_field))
6878 ("size of aliased field& must be ^ bits",
6879 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6880 TYPE_SIZE (gnu_field_type));
6882 else if (Strict_Alignment (gnat_field_type))
6884 ("size of & with aliased or tagged components not ^ bits",
6885 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6886 TYPE_SIZE (gnu_field_type));
6888 gnu_size = NULL_TREE;
6891 if (!integer_zerop (size_binop
6892 (TRUNC_MOD_EXPR, gnu_pos,
6893 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6897 ("position of volatile field& must be multiple of ^ bits",
6898 First_Bit (Component_Clause (gnat_field)), gnat_field,
6899 TYPE_ALIGN (gnu_field_type));
6901 else if (Is_Aliased (gnat_field))
6903 ("position of aliased field& must be multiple of ^ bits",
6904 First_Bit (Component_Clause (gnat_field)), gnat_field,
6905 TYPE_ALIGN (gnu_field_type));
6907 else if (Strict_Alignment (gnat_field_type))
6909 ("position of & with aliased or tagged components not multiple of ^ bits",
6910 First_Bit (Component_Clause (gnat_field)), gnat_field,
6911 TYPE_ALIGN (gnu_field_type));
6916 gnu_pos = NULL_TREE;
6920 if (Is_Atomic (gnat_field))
6921 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6924 /* If the record has rep clauses and this is the tag field, make a rep
6925 clause for it as well. */
6926 else if (Has_Specified_Layout (Scope (gnat_field))
6927 && Chars (gnat_field) == Name_uTag)
6929 gnu_pos = bitsize_zero_node;
6930 gnu_size = TYPE_SIZE (gnu_field_type);
6934 gnu_pos = NULL_TREE;
6936 /* We need to make the size the maximum for the type if it is
6937 self-referential and an unconstrained type. In that case, we can't
6938 pack the field since we can't make a copy to align it. */
6939 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6941 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6942 && !Is_Constrained (Underlying_Type (gnat_field_type)))
6944 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6948 /* If a size is specified, adjust the field's type to it. */
6951 tree orig_field_type;
6953 /* If the field's type is justified modular, we would need to remove
6954 the wrapper to (better) meet the layout requirements. However we
6955 can do so only if the field is not aliased to preserve the unique
6956 layout and if the prescribed size is not greater than that of the
6957 packed array to preserve the justification. */
6958 if (!needs_strict_alignment
6959 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6960 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6961 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6963 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6966 = make_type_from_size (gnu_field_type, gnu_size,
6967 Has_Biased_Representation (gnat_field));
6969 orig_field_type = gnu_field_type;
6970 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6971 false, false, definition, true);
6973 /* If a padding record was made, declare it now since it will never be
6974 declared otherwise. This is necessary to ensure that its subtrees
6975 are properly marked. */
6976 if (gnu_field_type != orig_field_type
6977 && !DECL_P (TYPE_NAME (gnu_field_type)))
6978 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6979 true, debug_info_p, gnat_field);
6982 /* Otherwise (or if there was an error), don't specify a position. */
6984 gnu_pos = NULL_TREE;
6986 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6987 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6989 /* Now create the decl for the field. */
6991 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6992 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
6993 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6994 TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
6996 if (Ekind (gnat_field) == E_Discriminant)
6997 DECL_DISCRIMINANT_NUMBER (gnu_field)
6998 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7003 /* Return true if TYPE is a type with variable size, a padding type with a
7004 field of variable size or is a record that has a field such a field. */
7007 is_variable_size (tree type)
7011 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7014 if (TYPE_IS_PADDING_P (type)
7015 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7018 if (TREE_CODE (type) != RECORD_TYPE
7019 && TREE_CODE (type) != UNION_TYPE
7020 && TREE_CODE (type) != QUAL_UNION_TYPE)
7023 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7024 if (is_variable_size (TREE_TYPE (field)))
7030 /* qsort comparer for the bit positions of two record components. */
7033 compare_field_bitpos (const PTR rt1, const PTR rt2)
7035 const_tree const field1 = * (const_tree const *) rt1;
7036 const_tree const field2 = * (const_tree const *) rt2;
7038 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7040 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7043 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
7044 the result as the field list of GNU_RECORD_TYPE and finish it up. When
7045 called from gnat_to_gnu_entity during the processing of a record type
7046 definition, the GCC node for the parent, if any, will be the single field
7047 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7048 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7049 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7051 PACKED is 1 if this is for a packed record, -1 if this is for a record
7052 with Component_Alignment of Storage_Unit, -2 if this is for a record
7053 with a specified alignment.
7055 DEFINITION is true if we are defining this record type.
7057 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7058 out the record. This means the alignment only serves to force fields to
7059 be bitfields, but not to require the record to be that aligned. This is
7062 ALL_REP is true if a rep clause is present for all the fields.
7064 UNCHECKED_UNION is true if we are building this type for a record with a
7065 Pragma Unchecked_Union.
7067 DEBUG_INFO is true if we need to write debug information about the type.
7069 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7070 mean that its contents may be unused as well, only the container itself.
7072 REORDER is true if we are permitted to reorder components of this type.
7074 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7075 with a rep clause is to be added; in this case, that is all that should
7076 be done with such fields. */
7079 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
7080 tree gnu_field_list, int packed, bool definition,
7081 bool cancel_alignment, bool all_rep,
7082 bool unchecked_union, bool debug_info,
7083 bool maybe_unused, bool reorder,
7084 tree *p_gnu_rep_list)
7086 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7087 bool layout_with_rep = false;
7088 Node_Id component_decl, variant_part;
7089 tree gnu_field, gnu_next, gnu_last;
7090 tree gnu_variant_part = NULL_TREE;
7091 tree gnu_rep_list = NULL_TREE;
7092 tree gnu_var_list = NULL_TREE;
7093 tree gnu_self_list = NULL_TREE;
7095 /* For each component referenced in a component declaration create a GCC
7096 field and add it to the list, skipping pragmas in the GNAT list. */
7097 gnu_last = tree_last (gnu_field_list);
7098 if (Present (Component_Items (gnat_component_list)))
7100 = First_Non_Pragma (Component_Items (gnat_component_list));
7101 Present (component_decl);
7102 component_decl = Next_Non_Pragma (component_decl))
7104 Entity_Id gnat_field = Defining_Entity (component_decl);
7105 Name_Id gnat_name = Chars (gnat_field);
7107 /* If present, the _Parent field must have been created as the single
7108 field of the record type. Put it before any other fields. */
7109 if (gnat_name == Name_uParent)
7111 gnu_field = TYPE_FIELDS (gnu_record_type);
7112 gnu_field_list = chainon (gnu_field_list, gnu_field);
7116 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7117 definition, debug_info);
7119 /* If this is the _Tag field, put it before any other fields. */
7120 if (gnat_name == Name_uTag)
7121 gnu_field_list = chainon (gnu_field_list, gnu_field);
7123 /* If this is the _Controller field, put it before the other
7124 fields except for the _Tag or _Parent field. */
7125 else if (gnat_name == Name_uController && gnu_last)
7127 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7128 DECL_CHAIN (gnu_last) = gnu_field;
7131 /* If this is a regular field, put it after the other fields. */
7134 DECL_CHAIN (gnu_field) = gnu_field_list;
7135 gnu_field_list = gnu_field;
7137 gnu_last = gnu_field;
7141 save_gnu_tree (gnat_field, gnu_field, false);
7144 /* At the end of the component list there may be a variant part. */
7145 variant_part = Variant_Part (gnat_component_list);
7147 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7148 mutually exclusive and should go in the same memory. To do this we need
7149 to treat each variant as a record whose elements are created from the
7150 component list for the variant. So here we create the records from the
7151 lists for the variants and put them all into the QUAL_UNION_TYPE.
7152 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7153 use GNU_RECORD_TYPE if there are no fields so far. */
7154 if (Present (variant_part))
7156 Node_Id gnat_discr = Name (variant_part), variant;
7157 tree gnu_discr = gnat_to_gnu (gnat_discr);
7158 tree gnu_name = TYPE_NAME (gnu_record_type);
7160 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7162 tree gnu_union_type, gnu_union_name;
7163 tree gnu_variant_list = NULL_TREE;
7165 if (TREE_CODE (gnu_name) == TYPE_DECL)
7166 gnu_name = DECL_NAME (gnu_name);
7169 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7171 /* Reuse an enclosing union if all fields are in the variant part
7172 and there is no representation clause on the record, to match
7173 the layout of C unions. There is an associated check below. */
7175 && TREE_CODE (gnu_record_type) == UNION_TYPE
7176 && !TYPE_PACKED (gnu_record_type))
7177 gnu_union_type = gnu_record_type;
7181 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7183 TYPE_NAME (gnu_union_type) = gnu_union_name;
7184 TYPE_ALIGN (gnu_union_type) = 0;
7185 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7188 for (variant = First_Non_Pragma (Variants (variant_part));
7190 variant = Next_Non_Pragma (variant))
7192 tree gnu_variant_type = make_node (RECORD_TYPE);
7193 tree gnu_inner_name;
7196 Get_Variant_Encoding (variant);
7197 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7198 TYPE_NAME (gnu_variant_type)
7199 = concat_name (gnu_union_name,
7200 IDENTIFIER_POINTER (gnu_inner_name));
7202 /* Set the alignment of the inner type in case we need to make
7203 inner objects into bitfields, but then clear it out so the
7204 record actually gets only the alignment required. */
7205 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
7206 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7208 /* Similarly, if the outer record has a size specified and all
7209 fields have record rep clauses, we can propagate the size
7210 into the variant part. */
7211 if (all_rep_and_size)
7213 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7214 TYPE_SIZE_UNIT (gnu_variant_type)
7215 = TYPE_SIZE_UNIT (gnu_record_type);
7218 /* Add the fields into the record type for the variant. Note that
7219 we aren't sure to really use it at this point, see below. */
7220 components_to_record (gnu_variant_type, Component_List (variant),
7221 NULL_TREE, packed, definition,
7222 !all_rep_and_size, all_rep,
7223 unchecked_union, debug_info,
7224 true, reorder, &gnu_rep_list);
7226 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7228 Set_Present_Expr (variant, annotate_value (gnu_qual));
7230 /* If this is an Unchecked_Union and we have exactly one field,
7231 use this field directly to match the layout of C unions. */
7233 && TYPE_FIELDS (gnu_variant_type)
7234 && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type)))
7235 gnu_field = TYPE_FIELDS (gnu_variant_type);
7238 /* Deal with packedness like in gnat_to_gnu_field. */
7240 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7242 /* Finalize the record type now. We used to throw away
7243 empty records but we no longer do that because we need
7244 them to generate complete debug info for the variant;
7245 otherwise, the union type definition will be lacking
7246 the fields associated with these empty variants. */
7247 rest_of_record_type_compilation (gnu_variant_type);
7248 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7249 NULL, true, debug_info, gnat_component_list);
7252 = create_field_decl (gnu_inner_name, gnu_variant_type,
7255 ? TYPE_SIZE (gnu_variant_type) : 0,
7257 ? bitsize_zero_node : 0,
7260 DECL_INTERNAL_P (gnu_field) = 1;
7262 if (!unchecked_union)
7263 DECL_QUALIFIER (gnu_field) = gnu_qual;
7266 DECL_CHAIN (gnu_field) = gnu_variant_list;
7267 gnu_variant_list = gnu_field;
7270 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7271 if (gnu_variant_list)
7273 int union_field_packed;
7275 if (all_rep_and_size)
7277 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7278 TYPE_SIZE_UNIT (gnu_union_type)
7279 = TYPE_SIZE_UNIT (gnu_record_type);
7282 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7283 all_rep_and_size ? 1 : 0, debug_info);
7285 /* If GNU_UNION_TYPE is our record type, it means we must have an
7286 Unchecked_Union with no fields. Verify that and, if so, just
7288 if (gnu_union_type == gnu_record_type)
7290 gcc_assert (unchecked_union
7296 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
7297 NULL, true, debug_info, gnat_component_list);
7299 /* Deal with packedness like in gnat_to_gnu_field. */
7301 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7304 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7305 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
7306 all_rep ? bitsize_zero_node : 0,
7307 union_field_packed, 0);
7309 DECL_INTERNAL_P (gnu_variant_part) = 1;
7310 DECL_CHAIN (gnu_variant_part) = gnu_field_list;
7311 gnu_field_list = gnu_variant_part;
7315 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7316 permitted to reorder components, self-referential sizes or variable sizes.
7317 If they do, pull them out and put them onto the appropriate list. We have
7318 to do this in a separate pass since we want to handle the discriminants
7319 but can't play with them until we've used them in debugging data above.
7321 ??? If we reorder them, debugging information will be wrong but there is
7322 nothing that can be done about this at the moment. */
7323 gnu_last = NULL_TREE;
7325 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7328 DECL_CHAIN (gnu_last) = gnu_next; \
7330 gnu_field_list = gnu_next; \
7332 DECL_CHAIN (gnu_field) = (LIST); \
7333 (LIST) = gnu_field; \
7336 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7338 gnu_next = DECL_CHAIN (gnu_field);
7340 if (DECL_FIELD_OFFSET (gnu_field))
7342 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7348 /* Pull out the variant part and put it onto GNU_SELF_LIST. */
7349 if (gnu_field == gnu_variant_part)
7351 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7355 /* Skip internal fields and fields with fixed size. */
7356 if (!DECL_INTERNAL_P (gnu_field)
7357 && !(DECL_SIZE (gnu_field)
7358 && TREE_CODE (DECL_SIZE (gnu_field)) == INTEGER_CST))
7360 tree type_size = TYPE_SIZE (TREE_TYPE (gnu_field));
7362 if (CONTAINS_PLACEHOLDER_P (type_size))
7364 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7368 if (TREE_CODE (type_size) != INTEGER_CST)
7370 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7376 gnu_last = gnu_field;
7379 #undef MOVE_FROM_FIELD_LIST_TO
7381 /* If permitted, we reorder the components as follows:
7383 1) all fixed length fields,
7384 2) all fields whose length doesn't depend on discriminants,
7385 3) all fields whose length depends on discriminants,
7386 4) the variant part,
7388 within the record and within each variant recursively. */
7391 = chainon (nreverse (gnu_self_list),
7392 chainon (nreverse (gnu_var_list), gnu_field_list));
7394 /* If we have any fields in our rep'ed field list and it is not the case that
7395 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7396 set it and ignore these fields. */
7397 if (gnu_rep_list && p_gnu_rep_list && !all_rep)
7398 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7400 /* Otherwise, sort the fields by bit position and put them into their own
7401 record, before the others, if we also have fields without rep clauses. */
7402 else if (gnu_rep_list)
7405 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7406 int i, len = list_length (gnu_rep_list);
7407 tree *gnu_arr = XALLOCAVEC (tree, len);
7409 for (gnu_field = gnu_rep_list, i = 0;
7411 gnu_field = DECL_CHAIN (gnu_field), i++)
7412 gnu_arr[i] = gnu_field;
7414 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7416 /* Put the fields in the list in order of increasing position, which
7417 means we start from the end. */
7418 gnu_rep_list = NULL_TREE;
7419 for (i = len - 1; i >= 0; i--)
7421 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7422 gnu_rep_list = gnu_arr[i];
7423 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7428 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7430 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7431 gnu_record_type, NULL_TREE, NULL_TREE, 0, 1);
7432 DECL_INTERNAL_P (gnu_field) = 1;
7433 gnu_field_list = chainon (gnu_field_list, gnu_field);
7437 layout_with_rep = true;
7438 gnu_field_list = nreverse (gnu_rep_list);
7442 if (cancel_alignment)
7443 TYPE_ALIGN (gnu_record_type) = 0;
7445 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7446 layout_with_rep ? 1 : 0, debug_info && !maybe_unused);
7449 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7450 placed into an Esize, Component_Bit_Offset, or Component_Size value
7451 in the GNAT tree. */
7454 annotate_value (tree gnu_size)
7457 Node_Ref_Or_Val ops[3], ret;
7458 struct tree_int_map **h = NULL;
7461 /* See if we've already saved the value for this node. */
7462 if (EXPR_P (gnu_size))
7464 struct tree_int_map in;
7465 if (!annotate_value_cache)
7466 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7467 tree_int_map_eq, 0);
7468 in.base.from = gnu_size;
7469 h = (struct tree_int_map **)
7470 htab_find_slot (annotate_value_cache, &in, INSERT);
7473 return (Node_Ref_Or_Val) (*h)->to;
7476 /* If we do not return inside this switch, TCODE will be set to the
7477 code to use for a Create_Node operand and LEN (set above) will be
7478 the number of recursive calls for us to make. */
7480 switch (TREE_CODE (gnu_size))
7483 if (TREE_OVERFLOW (gnu_size))
7486 /* This may come from a conversion from some smaller type, so ensure
7487 this is in bitsizetype. */
7488 gnu_size = convert (bitsizetype, gnu_size);
7490 /* For a negative value, build NEGATE_EXPR of the opposite. Such values
7491 appear in expressions containing aligning patterns. Note that, since
7492 sizetype is sign-extended but nonetheless unsigned, we don't directly
7493 use tree_int_cst_sgn. */
7494 if (TREE_INT_CST_HIGH (gnu_size) < 0)
7496 tree op_size = fold_build1 (NEGATE_EXPR, bitsizetype, gnu_size);
7497 return annotate_value (build1 (NEGATE_EXPR, bitsizetype, op_size));
7500 return UI_From_gnu (gnu_size);
7503 /* The only case we handle here is a simple discriminant reference. */
7504 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7505 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7506 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7507 return Create_Node (Discrim_Val,
7508 annotate_value (DECL_DISCRIMINANT_NUMBER
7509 (TREE_OPERAND (gnu_size, 1))),
7514 CASE_CONVERT: case NON_LVALUE_EXPR:
7515 return annotate_value (TREE_OPERAND (gnu_size, 0));
7517 /* Now just list the operations we handle. */
7518 case COND_EXPR: tcode = Cond_Expr; break;
7519 case PLUS_EXPR: tcode = Plus_Expr; break;
7520 case MINUS_EXPR: tcode = Minus_Expr; break;
7521 case MULT_EXPR: tcode = Mult_Expr; break;
7522 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7523 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7524 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7525 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7526 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7527 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7528 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7529 case NEGATE_EXPR: tcode = Negate_Expr; break;
7530 case MIN_EXPR: tcode = Min_Expr; break;
7531 case MAX_EXPR: tcode = Max_Expr; break;
7532 case ABS_EXPR: tcode = Abs_Expr; break;
7533 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7534 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7535 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7536 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7537 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7538 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7539 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7540 case LT_EXPR: tcode = Lt_Expr; break;
7541 case LE_EXPR: tcode = Le_Expr; break;
7542 case GT_EXPR: tcode = Gt_Expr; break;
7543 case GE_EXPR: tcode = Ge_Expr; break;
7544 case EQ_EXPR: tcode = Eq_Expr; break;
7545 case NE_EXPR: tcode = Ne_Expr; break;
7549 tree t = maybe_inline_call_in_expr (gnu_size);
7551 return annotate_value (t);
7554 /* Fall through... */
7560 /* Now get each of the operands that's relevant for this code. If any
7561 cannot be expressed as a repinfo node, say we can't. */
7562 for (i = 0; i < 3; i++)
7565 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7567 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7568 if (ops[i] == No_Uint)
7572 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7574 /* Save the result in the cache. */
7577 *h = ggc_alloc_tree_int_map ();
7578 (*h)->base.from = gnu_size;
7585 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7586 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7587 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7588 BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
7589 true if the object is used by double reference. */
7592 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref,
7598 gnu_type = TREE_TYPE (gnu_type);
7600 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7601 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7603 gnu_type = TREE_TYPE (gnu_type);
7606 if (Unknown_Esize (gnat_entity))
7608 if (TREE_CODE (gnu_type) == RECORD_TYPE
7609 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7610 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7612 size = TYPE_SIZE (gnu_type);
7615 Set_Esize (gnat_entity, annotate_value (size));
7618 if (Unknown_Alignment (gnat_entity))
7619 Set_Alignment (gnat_entity,
7620 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7623 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7624 Return NULL_TREE if there is no such element in the list. */
7627 purpose_member_field (const_tree elem, tree list)
7631 tree field = TREE_PURPOSE (list);
7632 if (SAME_FIELD_P (field, elem))
7634 list = TREE_CHAIN (list);
7639 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7640 set Component_Bit_Offset and Esize of the components to the position and
7641 size used by Gigi. */
7644 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7646 Entity_Id gnat_field;
7649 /* We operate by first making a list of all fields and their position (we
7650 can get the size easily) and then update all the sizes in the tree. */
7652 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7653 BIGGEST_ALIGNMENT, NULL_TREE);
7655 for (gnat_field = First_Entity (gnat_entity);
7656 Present (gnat_field);
7657 gnat_field = Next_Entity (gnat_field))
7658 if (Ekind (gnat_field) == E_Component
7659 || (Ekind (gnat_field) == E_Discriminant
7660 && !Is_Unchecked_Union (Scope (gnat_field))))
7662 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7668 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7670 /* In this mode the tag and parent components are not
7671 generated, so we add the appropriate offset to each
7672 component. For a component appearing in the current
7673 extension, the offset is the size of the parent. */
7674 if (Is_Derived_Type (gnat_entity)
7675 && Original_Record_Component (gnat_field) == gnat_field)
7677 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7680 parent_offset = bitsize_int (POINTER_SIZE);
7683 parent_offset = bitsize_zero_node;
7685 Set_Component_Bit_Offset
7688 (size_binop (PLUS_EXPR,
7689 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7690 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7693 Set_Esize (gnat_field,
7694 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7696 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7698 /* If there is no entry, this is an inherited component whose
7699 position is the same as in the parent type. */
7700 Set_Component_Bit_Offset
7702 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7704 Set_Esize (gnat_field,
7705 Esize (Original_Record_Component (gnat_field)));
7710 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7711 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7712 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7713 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7714 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7715 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7716 pre-existing list to be chained to the newly created entries. */
7719 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7720 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7724 for (gnu_field = TYPE_FIELDS (gnu_type);
7726 gnu_field = DECL_CHAIN (gnu_field))
7728 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7729 DECL_FIELD_BIT_OFFSET (gnu_field));
7730 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7731 DECL_FIELD_OFFSET (gnu_field));
7732 unsigned int our_offset_align
7733 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7734 tree v = make_tree_vec (3);
7736 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7737 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7738 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7739 gnu_list = tree_cons (gnu_field, v, gnu_list);
7741 /* Recurse on internal fields, flattening the nested fields except for
7742 those in the variant part, if requested. */
7743 if (DECL_INTERNAL_P (gnu_field))
7745 tree gnu_field_type = TREE_TYPE (gnu_field);
7746 if (do_not_flatten_variant
7747 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7749 = build_position_list (gnu_field_type, do_not_flatten_variant,
7750 size_zero_node, bitsize_zero_node,
7751 BIGGEST_ALIGNMENT, gnu_list);
7754 = build_position_list (gnu_field_type, do_not_flatten_variant,
7755 gnu_our_offset, gnu_our_bitpos,
7756 our_offset_align, gnu_list);
7763 /* Return a VEC describing the substitutions needed to reflect the
7764 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7765 be in any order. The values in an element of the VEC are in the form
7766 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7767 a definition of GNAT_SUBTYPE. */
7769 static VEC(subst_pair,heap) *
7770 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7772 VEC(subst_pair,heap) *gnu_vec = NULL;
7773 Entity_Id gnat_discrim;
7776 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7777 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7778 Present (gnat_discrim);
7779 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7780 gnat_value = Next_Elmt (gnat_value))
7781 /* Ignore access discriminants. */
7782 if (!Is_Access_Type (Etype (Node (gnat_value))))
7784 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7785 tree replacement = convert (TREE_TYPE (gnu_field),
7786 elaborate_expression
7787 (Node (gnat_value), gnat_subtype,
7788 get_entity_name (gnat_discrim),
7789 definition, true, false));
7790 subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL);
7791 s->discriminant = gnu_field;
7792 s->replacement = replacement;
7798 /* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
7799 variants of QUAL_UNION_TYPE that are still relevant after applying
7800 the substitutions described in SUBST_LIST. VARIANT_LIST is a
7801 pre-existing VEC onto which newly created entries should be
7804 static VEC(variant_desc,heap) *
7805 build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list,
7806 VEC(variant_desc,heap) *variant_list)
7810 for (gnu_field = TYPE_FIELDS (qual_union_type);
7812 gnu_field = DECL_CHAIN (gnu_field))
7814 tree qual = DECL_QUALIFIER (gnu_field);
7818 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
7819 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
7821 /* If the new qualifier is not unconditionally false, its variant may
7822 still be accessed. */
7823 if (!integer_zerop (qual))
7826 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7828 v = VEC_safe_push (variant_desc, heap, variant_list, NULL);
7829 v->type = variant_type;
7830 v->field = gnu_field;
7832 v->record = NULL_TREE;
7834 /* Recurse on the variant subpart of the variant, if any. */
7835 variant_subpart = get_variant_part (variant_type);
7836 if (variant_subpart)
7837 variant_list = build_variant_list (TREE_TYPE (variant_subpart),
7838 subst_list, variant_list);
7840 /* If the new qualifier is unconditionally true, the subsequent
7841 variants cannot be accessed. */
7842 if (integer_onep (qual))
7847 return variant_list;
7850 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7851 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7852 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7853 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7854 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7855 true if we are being called to process the Component_Size of GNAT_OBJECT;
7856 this is used only for error messages. ZERO_OK is true if a size of zero
7857 is permitted; if ZERO_OK is false, it means that a size of zero should be
7858 treated as an unspecified size. */
7861 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7862 enum tree_code kind, bool component_p, bool zero_ok)
7864 Node_Id gnat_error_node;
7865 tree type_size, size;
7867 /* Return 0 if no size was specified. */
7868 if (uint_size == No_Uint)
7871 /* Ignore a negative size since that corresponds to our back-annotation. */
7872 if (UI_Lt (uint_size, Uint_0))
7875 /* Find the node to use for error messages. */
7876 if ((Ekind (gnat_object) == E_Component
7877 || Ekind (gnat_object) == E_Discriminant)
7878 && Present (Component_Clause (gnat_object)))
7879 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7880 else if (Present (Size_Clause (gnat_object)))
7881 gnat_error_node = Expression (Size_Clause (gnat_object));
7883 gnat_error_node = gnat_object;
7885 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7886 but cannot be represented in bitsizetype. */
7887 size = UI_To_gnu (uint_size, bitsizetype);
7888 if (TREE_OVERFLOW (size))
7891 post_error_ne ("component size for& is too large", gnat_error_node,
7894 post_error_ne ("size for& is too large", gnat_error_node,
7899 /* Ignore a zero size if it is not permitted. */
7900 if (!zero_ok && integer_zerop (size))
7903 /* The size of objects is always a multiple of a byte. */
7904 if (kind == VAR_DECL
7905 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7908 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7909 gnat_error_node, gnat_object);
7911 post_error_ne ("size for& is not a multiple of Storage_Unit",
7912 gnat_error_node, gnat_object);
7916 /* If this is an integral type or a packed array type, the front-end has
7917 already verified the size, so we need not do it here (which would mean
7918 checking against the bounds). However, if this is an aliased object,
7919 it may not be smaller than the type of the object. */
7920 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7921 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7924 /* If the object is a record that contains a template, add the size of the
7925 template to the specified size. */
7926 if (TREE_CODE (gnu_type) == RECORD_TYPE
7927 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7928 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7930 if (kind == VAR_DECL
7931 /* If a type needs strict alignment, a component of this type in
7932 a packed record cannot be packed and thus uses the type size. */
7933 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7934 type_size = TYPE_SIZE (gnu_type);
7936 type_size = rm_size (gnu_type);
7938 /* Modify the size of a discriminated type to be the maximum size. */
7939 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7940 type_size = max_size (type_size, true);
7942 /* If this is an access type or a fat pointer, the minimum size is that given
7943 by the smallest integral mode that's valid for pointers. */
7944 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7946 enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7947 while (!targetm.valid_pointer_mode (p_mode))
7948 p_mode = GET_MODE_WIDER_MODE (p_mode);
7949 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7952 /* Issue an error either if the default size of the object isn't a constant
7953 or if the new size is smaller than it. */
7954 if (TREE_CODE (type_size) != INTEGER_CST
7955 || TREE_OVERFLOW (type_size)
7956 || tree_int_cst_lt (size, type_size))
7960 ("component size for& too small{, minimum allowed is ^}",
7961 gnat_error_node, gnat_object, type_size);
7964 ("size for& too small{, minimum allowed is ^}",
7965 gnat_error_node, gnat_object, type_size);
7972 /* Similarly, but both validate and process a value of RM size. This routine
7973 is only called for types. */
7976 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7978 Node_Id gnat_attr_node;
7979 tree old_size, size;
7981 /* Do nothing if no size was specified. */
7982 if (uint_size == No_Uint)
7985 /* Ignore a negative size since that corresponds to our back-annotation. */
7986 if (UI_Lt (uint_size, Uint_0))
7989 /* Only issue an error if a Value_Size clause was explicitly given.
7990 Otherwise, we'd be duplicating an error on the Size clause. */
7992 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7994 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7995 but cannot be represented in bitsizetype. */
7996 size = UI_To_gnu (uint_size, bitsizetype);
7997 if (TREE_OVERFLOW (size))
7999 if (Present (gnat_attr_node))
8000 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8005 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8006 exists, or this is an integer type, in which case the front-end will
8007 have always set it. */
8008 if (No (gnat_attr_node)
8009 && integer_zerop (size)
8010 && !Has_Size_Clause (gnat_entity)
8011 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8014 old_size = rm_size (gnu_type);
8016 /* If the old size is self-referential, get the maximum size. */
8017 if (CONTAINS_PLACEHOLDER_P (old_size))
8018 old_size = max_size (old_size, true);
8020 /* Issue an error either if the old size of the object isn't a constant or
8021 if the new size is smaller than it. The front-end has already verified
8022 this for scalar and packed array types. */
8023 if (TREE_CODE (old_size) != INTEGER_CST
8024 || TREE_OVERFLOW (old_size)
8025 || (AGGREGATE_TYPE_P (gnu_type)
8026 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8027 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8028 && !(TYPE_IS_PADDING_P (gnu_type)
8029 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8030 && TYPE_PACKED_ARRAY_TYPE_P
8031 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8032 && tree_int_cst_lt (size, old_size)))
8034 if (Present (gnat_attr_node))
8036 ("Value_Size for& too small{, minimum allowed is ^}",
8037 gnat_attr_node, gnat_entity, old_size);
8041 /* Otherwise, set the RM size proper for integral types... */
8042 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8043 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8044 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8045 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8046 SET_TYPE_RM_SIZE (gnu_type, size);
8048 /* ...or the Ada size for record and union types. */
8049 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
8050 || TREE_CODE (gnu_type) == UNION_TYPE
8051 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8052 && !TYPE_FAT_POINTER_P (gnu_type))
8053 SET_TYPE_ADA_SIZE (gnu_type, size);
8056 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
8057 If TYPE is the best type, return it. Otherwise, make a new type. We
8058 only support new integral and pointer types. FOR_BIASED is true if
8059 we are making a biased type. */
8062 make_type_from_size (tree type, tree size_tree, bool for_biased)
8064 unsigned HOST_WIDE_INT size;
8068 /* If size indicates an error, just return TYPE to avoid propagating
8069 the error. Likewise if it's too large to represent. */
8070 if (!size_tree || !host_integerp (size_tree, 1))
8073 size = tree_low_cst (size_tree, 1);
8075 switch (TREE_CODE (type))
8080 biased_p = (TREE_CODE (type) == INTEGER_TYPE
8081 && TYPE_BIASED_REPRESENTATION_P (type));
8083 /* Integer types with precision 0 are forbidden. */
8087 /* Only do something if the type is not a packed array type and
8088 doesn't already have the proper size. */
8089 if (TYPE_PACKED_ARRAY_TYPE_P (type)
8090 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
8093 biased_p |= for_biased;
8094 if (size > LONG_LONG_TYPE_SIZE)
8095 size = LONG_LONG_TYPE_SIZE;
8097 if (TYPE_UNSIGNED (type) || biased_p)
8098 new_type = make_unsigned_type (size);
8100 new_type = make_signed_type (size);
8101 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
8102 SET_TYPE_RM_MIN_VALUE (new_type,
8103 convert (TREE_TYPE (new_type),
8104 TYPE_MIN_VALUE (type)));
8105 SET_TYPE_RM_MAX_VALUE (new_type,
8106 convert (TREE_TYPE (new_type),
8107 TYPE_MAX_VALUE (type)));
8108 /* Copy the name to show that it's essentially the same type and
8109 not a subrange type. */
8110 TYPE_NAME (new_type) = TYPE_NAME (type);
8111 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
8112 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
8116 /* Do something if this is a fat pointer, in which case we
8117 may need to return the thin pointer. */
8118 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
8120 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
8121 if (!targetm.valid_pointer_mode (p_mode))
8124 build_pointer_type_for_mode
8125 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
8131 /* Only do something if this is a thin pointer, in which case we
8132 may need to return the fat pointer. */
8133 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
8135 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
8145 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8146 a type or object whose present alignment is ALIGN. If this alignment is
8147 valid, return it. Otherwise, give an error and return ALIGN. */
8150 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8152 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8153 unsigned int new_align;
8154 Node_Id gnat_error_node;
8156 /* Don't worry about checking alignment if alignment was not specified
8157 by the source program and we already posted an error for this entity. */
8158 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8161 /* Post the error on the alignment clause if any. Note, for the implicit
8162 base type of an array type, the alignment clause is on the first
8164 if (Present (Alignment_Clause (gnat_entity)))
8165 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8167 else if (Is_Itype (gnat_entity)
8168 && Is_Array_Type (gnat_entity)
8169 && Etype (gnat_entity) == gnat_entity
8170 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8172 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8175 gnat_error_node = gnat_entity;
8177 /* Within GCC, an alignment is an integer, so we must make sure a value is
8178 specified that fits in that range. Also, there is an upper bound to
8179 alignments we can support/allow. */
8180 if (!UI_Is_In_Int_Range (alignment)
8181 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8182 post_error_ne_num ("largest supported alignment for& is ^",
8183 gnat_error_node, gnat_entity, max_allowed_alignment);
8184 else if (!(Present (Alignment_Clause (gnat_entity))
8185 && From_At_Mod (Alignment_Clause (gnat_entity)))
8186 && new_align * BITS_PER_UNIT < align)
8188 unsigned int double_align;
8189 bool is_capped_double, align_clause;
8191 /* If the default alignment of "double" or larger scalar types is
8192 specifically capped and the new alignment is above the cap, do
8193 not post an error and change the alignment only if there is an
8194 alignment clause; this makes it possible to have the associated
8195 GCC type overaligned by default for performance reasons. */
8196 if ((double_align = double_float_alignment) > 0)
8199 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8201 = is_double_float_or_array (gnat_type, &align_clause);
8203 else if ((double_align = double_scalar_alignment) > 0)
8206 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8208 = is_double_scalar_or_array (gnat_type, &align_clause);
8211 is_capped_double = align_clause = false;
8213 if (is_capped_double && new_align >= double_align)
8216 align = new_align * BITS_PER_UNIT;
8220 if (is_capped_double)
8221 align = double_align * BITS_PER_UNIT;
8223 post_error_ne_num ("alignment for& must be at least ^",
8224 gnat_error_node, gnat_entity,
8225 align / BITS_PER_UNIT);
8230 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8231 if (new_align > align)
8238 /* Return the smallest alignment not less than SIZE. */
8241 ceil_alignment (unsigned HOST_WIDE_INT size)
8243 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
8246 /* Verify that OBJECT, a type or decl, is something we can implement
8247 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8248 if we require atomic components. */
8251 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
8253 Node_Id gnat_error_point = gnat_entity;
8255 enum machine_mode mode;
8259 /* There are three case of what OBJECT can be. It can be a type, in which
8260 case we take the size, alignment and mode from the type. It can be a
8261 declaration that was indirect, in which case the relevant values are
8262 that of the type being pointed to, or it can be a normal declaration,
8263 in which case the values are of the decl. The code below assumes that
8264 OBJECT is either a type or a decl. */
8265 if (TYPE_P (object))
8267 /* If this is an anonymous base type, nothing to check. Error will be
8268 reported on the source type. */
8269 if (!Comes_From_Source (gnat_entity))
8272 mode = TYPE_MODE (object);
8273 align = TYPE_ALIGN (object);
8274 size = TYPE_SIZE (object);
8276 else if (DECL_BY_REF_P (object))
8278 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
8279 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
8280 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
8284 mode = DECL_MODE (object);
8285 align = DECL_ALIGN (object);
8286 size = DECL_SIZE (object);
8289 /* Consider all floating-point types atomic and any types that that are
8290 represented by integers no wider than a machine word. */
8291 if (GET_MODE_CLASS (mode) == MODE_FLOAT
8292 || ((GET_MODE_CLASS (mode) == MODE_INT
8293 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
8294 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8297 /* For the moment, also allow anything that has an alignment equal
8298 to its size and which is smaller than a word. */
8299 if (size && TREE_CODE (size) == INTEGER_CST
8300 && compare_tree_int (size, align) == 0
8301 && align <= BITS_PER_WORD)
8304 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
8305 gnat_node = Next_Rep_Item (gnat_node))
8307 if (!comp_p && Nkind (gnat_node) == N_Pragma
8308 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8310 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8311 else if (comp_p && Nkind (gnat_node) == N_Pragma
8312 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8313 == Pragma_Atomic_Components))
8314 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8318 post_error_ne ("atomic access to component of & cannot be guaranteed",
8319 gnat_error_point, gnat_entity);
8321 post_error_ne ("atomic access to & cannot be guaranteed",
8322 gnat_error_point, gnat_entity);
8326 /* Helper for the intrin compatibility checks family. Evaluate whether
8327 two types are definitely incompatible. */
8330 intrin_types_incompatible_p (tree t1, tree t2)
8332 enum tree_code code;
8334 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8337 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8340 if (TREE_CODE (t1) != TREE_CODE (t2))
8343 code = TREE_CODE (t1);
8349 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8352 case REFERENCE_TYPE:
8353 /* Assume designated types are ok. We'd need to account for char * and
8354 void * variants to do better, which could rapidly get messy and isn't
8355 clearly worth the effort. */
8365 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8366 on the Ada/builtin argument lists for the INB binding. */
8369 intrin_arglists_compatible_p (intrin_binding_t * inb)
8371 function_args_iterator ada_iter, btin_iter;
8373 function_args_iter_init (&ada_iter, inb->ada_fntype);
8374 function_args_iter_init (&btin_iter, inb->btin_fntype);
8376 /* Sequence position of the last argument we checked. */
8381 tree ada_type = function_args_iter_cond (&ada_iter);
8382 tree btin_type = function_args_iter_cond (&btin_iter);
8384 /* If we've exhausted both lists simultaneously, we're done. */
8385 if (ada_type == NULL_TREE && btin_type == NULL_TREE)
8388 /* If one list is shorter than the other, they fail to match. */
8389 if (ada_type == NULL_TREE || btin_type == NULL_TREE)
8392 /* If we're done with the Ada args and not with the internal builtin
8393 args, or the other way around, complain. */
8394 if (ada_type == void_type_node
8395 && btin_type != void_type_node)
8397 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8401 if (btin_type == void_type_node
8402 && ada_type != void_type_node)
8404 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8405 inb->gnat_entity, inb->gnat_entity, argpos);
8409 /* Otherwise, check that types match for the current argument. */
8411 if (intrin_types_incompatible_p (ada_type, btin_type))
8413 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8414 inb->gnat_entity, inb->gnat_entity, argpos);
8419 function_args_iter_next (&ada_iter);
8420 function_args_iter_next (&btin_iter);
8426 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8427 on the Ada/builtin return values for the INB binding. */
8430 intrin_return_compatible_p (intrin_binding_t * inb)
8432 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8433 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8435 /* Accept function imported as procedure, common and convenient. */
8436 if (VOID_TYPE_P (ada_return_type)
8437 && !VOID_TYPE_P (btin_return_type))
8440 /* Check return types compatibility otherwise. Note that this
8441 handles void/void as well. */
8442 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8444 post_error ("?intrinsic binding type mismatch on return value!",
8452 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8453 compatible. Issue relevant warnings when they are not.
8455 This is intended as a light check to diagnose the most obvious cases, not
8456 as a full fledged type compatibility predicate. It is the programmer's
8457 responsibility to ensure correctness of the Ada declarations in Imports,
8458 especially when binding straight to a compiler internal. */
8461 intrin_profiles_compatible_p (intrin_binding_t * inb)
8463 /* Check compatibility on return values and argument lists, each responsible
8464 for posting warnings as appropriate. Ensure use of the proper sloc for
8467 bool arglists_compatible_p, return_compatible_p;
8468 location_t saved_location = input_location;
8470 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8472 return_compatible_p = intrin_return_compatible_p (inb);
8473 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8475 input_location = saved_location;
8477 return return_compatible_p && arglists_compatible_p;
8480 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8481 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8482 specified size for this field. POS_LIST is a position list describing
8483 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8487 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8488 tree size, tree pos_list,
8489 VEC(subst_pair,heap) *subst_list)
8491 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8492 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8493 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
8494 tree new_pos, new_field;
8498 if (CONTAINS_PLACEHOLDER_P (pos))
8499 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8500 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8502 /* If the position is now a constant, we can set it as the position of the
8503 field when we make it. Otherwise, we need to deal with it specially. */
8504 if (TREE_CONSTANT (pos))
8505 new_pos = bit_from_pos (pos, bitpos);
8507 new_pos = NULL_TREE;
8510 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8511 size, new_pos, DECL_PACKED (old_field),
8512 !DECL_NONADDRESSABLE_P (old_field));
8516 normalize_offset (&pos, &bitpos, offset_align);
8517 DECL_FIELD_OFFSET (new_field) = pos;
8518 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8519 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8520 DECL_SIZE (new_field) = size;
8521 DECL_SIZE_UNIT (new_field)
8522 = convert (sizetype,
8523 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8524 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8527 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8528 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8529 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8530 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8535 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8538 get_rep_part (tree record_type)
8540 tree field = TYPE_FIELDS (record_type);
8542 /* The REP part is the first field, internal, another record, and its name
8543 doesn't start with an underscore (i.e. is not generated by the FE). */
8544 if (DECL_INTERNAL_P (field)
8545 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8546 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8552 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8555 get_variant_part (tree record_type)
8559 /* The variant part is the only internal field that is a qualified union. */
8560 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8561 if (DECL_INTERNAL_P (field)
8562 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8568 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8569 the list of variants to be used and RECORD_TYPE is the type of the parent.
8570 POS_LIST is a position list describing the layout of fields present in
8571 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8575 create_variant_part_from (tree old_variant_part,
8576 VEC(variant_desc,heap) *variant_list,
8577 tree record_type, tree pos_list,
8578 VEC(subst_pair,heap) *subst_list)
8580 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8581 tree old_union_type = TREE_TYPE (old_variant_part);
8582 tree new_union_type, new_variant_part;
8583 tree union_field_list = NULL_TREE;
8587 /* First create the type of the variant part from that of the old one. */
8588 new_union_type = make_node (QUAL_UNION_TYPE);
8589 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8591 /* If the position of the variant part is constant, subtract it from the
8592 size of the type of the parent to get the new size. This manual CSE
8593 reduces the code size when not optimizing. */
8594 if (TREE_CODE (offset) == INTEGER_CST)
8596 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8597 tree first_bit = bit_from_pos (offset, bitpos);
8598 TYPE_SIZE (new_union_type)
8599 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8600 TYPE_SIZE_UNIT (new_union_type)
8601 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8602 byte_from_pos (offset, bitpos));
8603 SET_TYPE_ADA_SIZE (new_union_type,
8604 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8606 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8607 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8610 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8612 /* Now finish up the new variants and populate the union type. */
8613 FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v)
8615 tree old_field = v->field, new_field;
8616 tree old_variant, old_variant_subpart, new_variant, field_list;
8618 /* Skip variants that don't belong to this nesting level. */
8619 if (DECL_CONTEXT (old_field) != old_union_type)
8622 /* Retrieve the list of fields already added to the new variant. */
8623 new_variant = v->record;
8624 field_list = TYPE_FIELDS (new_variant);
8626 /* If the old variant had a variant subpart, we need to create a new
8627 variant subpart and add it to the field list. */
8628 old_variant = v->type;
8629 old_variant_subpart = get_variant_part (old_variant);
8630 if (old_variant_subpart)
8632 tree new_variant_subpart
8633 = create_variant_part_from (old_variant_subpart, variant_list,
8634 new_variant, pos_list, subst_list);
8635 DECL_CHAIN (new_variant_subpart) = field_list;
8636 field_list = new_variant_subpart;
8639 /* Finish up the new variant and create the field. No need for debug
8640 info thanks to the XVS type. */
8641 finish_record_type (new_variant, nreverse (field_list), 2, false);
8642 compute_record_mode (new_variant);
8643 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8644 true, false, Empty);
8647 = create_field_decl_from (old_field, new_variant, new_union_type,
8648 TYPE_SIZE (new_variant),
8649 pos_list, subst_list);
8650 DECL_QUALIFIER (new_field) = v->qual;
8651 DECL_INTERNAL_P (new_field) = 1;
8652 DECL_CHAIN (new_field) = union_field_list;
8653 union_field_list = new_field;
8656 /* Finish up the union type and create the variant part. No need for debug
8657 info thanks to the XVS type. */
8658 finish_record_type (new_union_type, union_field_list, 2, false);
8659 compute_record_mode (new_union_type);
8660 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8661 true, false, Empty);
8664 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8665 TYPE_SIZE (new_union_type),
8666 pos_list, subst_list);
8667 DECL_INTERNAL_P (new_variant_part) = 1;
8669 /* With multiple discriminants it is possible for an inner variant to be
8670 statically selected while outer ones are not; in this case, the list
8671 of fields of the inner variant is not flattened and we end up with a
8672 qualified union with a single member. Drop the useless container. */
8673 if (!DECL_CHAIN (union_field_list))
8675 DECL_CONTEXT (union_field_list) = record_type;
8676 DECL_FIELD_OFFSET (union_field_list)
8677 = DECL_FIELD_OFFSET (new_variant_part);
8678 DECL_FIELD_BIT_OFFSET (union_field_list)
8679 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8680 SET_DECL_OFFSET_ALIGN (union_field_list,
8681 DECL_OFFSET_ALIGN (new_variant_part));
8682 new_variant_part = union_field_list;
8685 return new_variant_part;
8688 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8689 which are both RECORD_TYPE, after applying the substitutions described
8693 copy_and_substitute_in_size (tree new_type, tree old_type,
8694 VEC(subst_pair,heap) *subst_list)
8699 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8700 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8701 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8702 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8703 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8705 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8706 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8707 TYPE_SIZE (new_type)
8708 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8709 s->discriminant, s->replacement);
8711 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8712 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8713 TYPE_SIZE_UNIT (new_type)
8714 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8715 s->discriminant, s->replacement);
8717 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8718 FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
8720 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8721 s->discriminant, s->replacement));
8723 /* Finalize the size. */
8724 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8725 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8728 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8729 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8730 updated by replacing F with R.
8732 The function doesn't update the layout of the type, i.e. it assumes
8733 that the substitution is purely formal. That's why the replacement
8734 value R must itself contain a PLACEHOLDER_EXPR. */
8737 substitute_in_type (tree t, tree f, tree r)
8741 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8743 switch (TREE_CODE (t))
8750 /* First the domain types of arrays. */
8751 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8752 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8754 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8755 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8757 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8761 TYPE_GCC_MIN_VALUE (nt) = low;
8762 TYPE_GCC_MAX_VALUE (nt) = high;
8764 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8766 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8771 /* Then the subtypes. */
8772 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8773 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8775 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8776 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8778 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8782 SET_TYPE_RM_MIN_VALUE (nt, low);
8783 SET_TYPE_RM_MAX_VALUE (nt, high);
8791 nt = substitute_in_type (TREE_TYPE (t), f, r);
8792 if (nt == TREE_TYPE (t))
8795 return build_complex_type (nt);
8798 /* These should never show up here. */
8803 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8804 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8806 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8809 nt = build_nonshared_array_type (component, domain);
8810 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8811 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8812 SET_TYPE_MODE (nt, TYPE_MODE (t));
8813 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8814 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8815 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8816 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8817 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8823 case QUAL_UNION_TYPE:
8825 bool changed_field = false;
8828 /* Start out with no fields, make new fields, and chain them
8829 in. If we haven't actually changed the type of any field,
8830 discard everything we've done and return the old type. */
8832 TYPE_FIELDS (nt) = NULL_TREE;
8834 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
8836 tree new_field = copy_node (field), new_n;
8838 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8839 if (new_n != TREE_TYPE (field))
8841 TREE_TYPE (new_field) = new_n;
8842 changed_field = true;
8845 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8846 if (new_n != DECL_FIELD_OFFSET (field))
8848 DECL_FIELD_OFFSET (new_field) = new_n;
8849 changed_field = true;
8852 /* Do the substitution inside the qualifier, if any. */
8853 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8855 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8856 if (new_n != DECL_QUALIFIER (field))
8858 DECL_QUALIFIER (new_field) = new_n;
8859 changed_field = true;
8863 DECL_CONTEXT (new_field) = nt;
8864 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
8866 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
8867 TYPE_FIELDS (nt) = new_field;
8873 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8874 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8875 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8876 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8885 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8886 needed to represent the object. */
8889 rm_size (tree gnu_type)
8891 /* For integral types, we store the RM size explicitly. */
8892 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8893 return TYPE_RM_SIZE (gnu_type);
8895 /* Return the RM size of the actual data plus the size of the template. */
8896 if (TREE_CODE (gnu_type) == RECORD_TYPE
8897 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8899 size_binop (PLUS_EXPR,
8900 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
8901 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8903 /* For record types, we store the size explicitly. */
8904 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8905 || TREE_CODE (gnu_type) == UNION_TYPE
8906 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8907 && !TYPE_FAT_POINTER_P (gnu_type)
8908 && TYPE_ADA_SIZE (gnu_type))
8909 return TYPE_ADA_SIZE (gnu_type);
8911 /* For other types, this is just the size. */
8912 return TYPE_SIZE (gnu_type);
8915 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8916 fully-qualified name, possibly with type information encoding.
8917 Otherwise, return the name. */
8920 get_entity_name (Entity_Id gnat_entity)
8922 Get_Encoded_Name (gnat_entity);
8923 return get_identifier_with_length (Name_Buffer, Name_Len);
8926 /* Return an identifier representing the external name to be used for
8927 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8928 and the specified suffix. */
8931 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8933 Entity_Kind kind = Ekind (gnat_entity);
8937 String_Template temp = {1, strlen (suffix)};
8938 Fat_Pointer fp = {suffix, &temp};
8939 Get_External_Name_With_Suffix (gnat_entity, fp);
8942 Get_External_Name (gnat_entity, 0);
8944 /* A variable using the Stdcall convention lives in a DLL. We adjust
8945 its name to use the jump table, the _imp__NAME contains the address
8946 for the NAME variable. */
8947 if ((kind == E_Variable || kind == E_Constant)
8948 && Has_Stdcall_Convention (gnat_entity))
8950 const int len = 6 + Name_Len;
8951 char *new_name = (char *) alloca (len + 1);
8952 strcpy (new_name, "_imp__");
8953 strcat (new_name, Name_Buffer);
8954 return get_identifier_with_length (new_name, len);
8957 return get_identifier_with_length (Name_Buffer, Name_Len);
8960 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8961 string, return a new IDENTIFIER_NODE that is the concatenation of
8962 the name followed by "___" and the specified suffix. */
8965 concat_name (tree gnu_name, const char *suffix)
8967 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8968 char *new_name = (char *) alloca (len + 1);
8969 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8970 strcat (new_name, "___");
8971 strcat (new_name, suffix);
8972 return get_identifier_with_length (new_name, len);
8975 #include "gt-ada-decl.h"
OSDN Git Service
