1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2016, 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"
31 #include "stringpool.h"
32 #include "diagnostic-core.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
36 #include "tree-inline.h"
54 /* "stdcall" and "thiscall" conventions should be processed in a specific way
55 on 32-bit x86/Windows only. The macros below are helpers to avoid having
56 to check for a Windows specific attribute throughout this unit. */
58 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
60 #define Has_Stdcall_Convention(E) \
61 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
62 #define Has_Thiscall_Convention(E) \
63 (!TARGET_64BIT && is_cplusplus_method (E))
65 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
66 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
69 #define Has_Stdcall_Convention(E) 0
70 #define Has_Thiscall_Convention(E) 0
73 #define STDCALL_PREFIX "_imp__"
75 /* Stack realignment is necessary for functions with foreign conventions when
76 the ABI doesn't mandate as much as what the compiler assumes - that is, up
77 to PREFERRED_STACK_BOUNDARY.
79 Such realignment can be requested with a dedicated function type attribute
80 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
81 characterize the situations where the attribute should be set. We rely on
82 compiler configuration settings for 'main' to decide. */
84 #ifdef MAIN_STACK_BOUNDARY
85 #define FOREIGN_FORCE_REALIGN_STACK \
86 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
88 #define FOREIGN_FORCE_REALIGN_STACK 0
93 struct incomplete *next;
98 /* These variables are used to defer recursively expanding incomplete types
99 while we are processing an array, a record or a subprogram type. */
100 static int defer_incomplete_level = 0;
101 static struct incomplete *defer_incomplete_list;
103 /* This variable is used to delay expanding From_Limited_With types until the
105 static struct incomplete *defer_limited_with;
107 typedef struct subst_pair_d {
113 typedef struct variant_desc_d {
114 /* The type of the variant. */
117 /* The associated field. */
120 /* The value of the qualifier. */
123 /* The type of the variant after transformation. */
128 /* A hash table used to cache the result of annotate_value. */
130 struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
132 static inline hashval_t
133 hash (tree_int_map *m)
135 return htab_hash_pointer (m->base.from);
139 equal (tree_int_map *a, tree_int_map *b)
141 return a->base.from == b->base.from;
145 keep_cache_entry (tree_int_map *&m)
147 return ggc_marked_p (m->base.from);
151 static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
153 static void prepend_one_attribute (struct attrib **,
154 enum attrib_type, tree, tree, Node_Id);
155 static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
156 static void prepend_attributes (struct attrib **, Entity_Id);
157 static tree elaborate_expression (Node_Id, Entity_Id, const char *, bool, bool,
159 static bool type_has_variable_size (tree);
160 static tree elaborate_expression_1 (tree, Entity_Id, const char *, bool, bool);
161 static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
163 static tree elaborate_reference (tree, Entity_Id, bool, tree *);
164 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
165 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
167 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
168 static bool is_from_limited_with_of_main (Entity_Id);
169 static tree change_qualified_type (tree, int);
170 static bool same_discriminant_p (Entity_Id, Entity_Id);
171 static bool array_type_has_nonaliased_component (tree, Entity_Id);
172 static bool compile_time_known_address_p (Node_Id);
173 static bool cannot_be_superflat (Node_Id);
174 static bool constructor_address_p (tree);
175 static bool allocatable_size_p (tree, bool);
176 static bool initial_value_needs_conversion (tree, tree);
177 static int compare_field_bitpos (const PTR, const PTR);
178 static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
179 bool, bool, bool, bool, bool, tree, tree *);
180 static Uint annotate_value (tree);
181 static void annotate_rep (Entity_Id, tree);
182 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
183 static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
184 static vec<variant_desc> build_variant_list (tree,
187 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
188 static void set_rm_size (Uint, tree, Entity_Id);
189 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
190 static void check_ok_for_atomic_type (tree, Entity_Id, bool);
191 static tree create_field_decl_from (tree, tree, tree, tree, tree,
193 static tree create_rep_part (tree, tree, tree);
194 static tree get_rep_part (tree);
195 static tree create_variant_part_from (tree, vec<variant_desc> , tree,
196 tree, vec<subst_pair> );
197 static void copy_and_substitute_in_size (tree, tree, vec<subst_pair> );
198 static void associate_original_type_to_packed_array (tree, Entity_Id);
199 static const char *get_entity_char (Entity_Id);
201 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
202 to pass around calls performing profile compatibility checks. */
205 Entity_Id gnat_entity; /* The Ada subprogram entity. */
206 tree ada_fntype; /* The corresponding GCC type node. */
207 tree btin_fntype; /* The GCC builtin function type node. */
210 static bool intrin_profiles_compatible_p (intrin_binding_t *);
212 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
213 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
214 and associate the ..._DECL node with the input GNAT defining identifier.
216 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
217 initial value (in GCC tree form). This is optional for a variable. For
218 a renamed entity, GNU_EXPR gives the object being renamed.
220 DEFINITION is nonzero if this call is intended for a definition. This is
221 used for separate compilation where it is necessary to know whether an
222 external declaration or a definition must be created if the GCC equivalent
223 was not created previously. The value of 1 is normally used for a nonzero
224 DEFINITION, but a value of 2 is used in special circumstances, defined in
228 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
230 /* Contains the kind of the input GNAT node. */
231 const Entity_Kind kind = Ekind (gnat_entity);
232 /* True if this is a type. */
233 const bool is_type = IN (kind, Type_Kind);
234 /* True if this is an artificial entity. */
235 const bool artificial_p = !Comes_From_Source (gnat_entity);
236 /* True if debug info is requested for this entity. */
237 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
238 /* True if this entity is to be considered as imported. */
239 const bool imported_p
240 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
241 /* For a type, contains the equivalent GNAT node to be used in gigi. */
242 Entity_Id gnat_equiv_type = Empty;
243 /* Temporary used to walk the GNAT tree. */
245 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
246 This node will be associated with the GNAT node by calling at the end
247 of the `switch' statement. */
248 tree gnu_decl = NULL_TREE;
249 /* Contains the GCC type to be used for the GCC node. */
250 tree gnu_type = NULL_TREE;
251 /* Contains the GCC size tree to be used for the GCC node. */
252 tree gnu_size = NULL_TREE;
253 /* Contains the GCC name to be used for the GCC node. */
254 tree gnu_entity_name;
255 /* True if we have already saved gnu_decl as a GNAT association. */
257 /* True if we incremented defer_incomplete_level. */
258 bool this_deferred = false;
259 /* True if we incremented force_global. */
260 bool this_global = false;
261 /* True if we should check to see if elaborated during processing. */
262 bool maybe_present = false;
263 /* True if we made GNU_DECL and its type here. */
264 bool this_made_decl = false;
265 /* Size and alignment of the GCC node, if meaningful. */
266 unsigned int esize = 0, align = 0;
267 /* Contains the list of attributes directly attached to the entity. */
268 struct attrib *attr_list = NULL;
270 /* Since a use of an Itype is a definition, process it as such if it
271 is not in a with'ed unit. */
274 && Is_Itype (gnat_entity)
275 && !present_gnu_tree (gnat_entity)
276 && In_Extended_Main_Code_Unit (gnat_entity))
278 /* Ensure that we are in a subprogram mentioned in the Scope chain of
279 this entity, our current scope is global, or we encountered a task
280 or entry (where we can't currently accurately check scoping). */
281 if (!current_function_decl
282 || DECL_ELABORATION_PROC_P (current_function_decl))
284 process_type (gnat_entity);
285 return get_gnu_tree (gnat_entity);
288 for (gnat_temp = Scope (gnat_entity);
290 gnat_temp = Scope (gnat_temp))
292 if (Is_Type (gnat_temp))
293 gnat_temp = Underlying_Type (gnat_temp);
295 if (Ekind (gnat_temp) == E_Subprogram_Body)
297 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
299 if (IN (Ekind (gnat_temp), Subprogram_Kind)
300 && Present (Protected_Body_Subprogram (gnat_temp)))
301 gnat_temp = Protected_Body_Subprogram (gnat_temp);
303 if (Ekind (gnat_temp) == E_Entry
304 || Ekind (gnat_temp) == E_Entry_Family
305 || Ekind (gnat_temp) == E_Task_Type
306 || (IN (Ekind (gnat_temp), Subprogram_Kind)
307 && present_gnu_tree (gnat_temp)
308 && (current_function_decl
309 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
311 process_type (gnat_entity);
312 return get_gnu_tree (gnat_entity);
316 /* This abort means the Itype has an incorrect scope, i.e. that its
317 scope does not correspond to the subprogram it is declared in. */
321 /* If we've already processed this entity, return what we got last time.
322 If we are defining the node, we should not have already processed it.
323 In that case, we will abort below when we try to save a new GCC tree
324 for this object. We also need to handle the case of getting a dummy
325 type when a Full_View exists but be careful so as not to trigger its
326 premature elaboration. */
327 if ((!definition || (is_type && imported_p))
328 && present_gnu_tree (gnat_entity))
330 gnu_decl = get_gnu_tree (gnat_entity);
332 if (TREE_CODE (gnu_decl) == TYPE_DECL
333 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
334 && IN (kind, Incomplete_Or_Private_Kind)
335 && Present (Full_View (gnat_entity))
336 && (present_gnu_tree (Full_View (gnat_entity))
337 || No (Freeze_Node (Full_View (gnat_entity)))))
340 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
341 save_gnu_tree (gnat_entity, NULL_TREE, false);
342 save_gnu_tree (gnat_entity, gnu_decl, false);
348 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
349 must be specified unless it was specified by the programmer. Exceptions
350 are for access-to-protected-subprogram types and all access subtypes, as
351 another GNAT type is used to lay out the GCC type for them. */
353 || Known_Esize (gnat_entity)
354 || Has_Size_Clause (gnat_entity)
355 || (!IN (kind, Numeric_Kind)
356 && !IN (kind, Enumeration_Kind)
357 && (!IN (kind, Access_Kind)
358 || kind == E_Access_Protected_Subprogram_Type
359 || kind == E_Anonymous_Access_Protected_Subprogram_Type
360 || kind == E_Access_Subtype
361 || type_annotate_only)));
363 /* The RM size must be specified for all discrete and fixed-point types. */
364 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
365 && Unknown_RM_Size (gnat_entity)));
367 /* If we get here, it means we have not yet done anything with this entity.
368 If we are not defining it, it must be a type or an entity that is defined
369 elsewhere or externally, otherwise we should have defined it already. */
370 gcc_assert (definition
371 || type_annotate_only
373 || kind == E_Discriminant
374 || kind == E_Component
376 || (kind == E_Constant && Present (Full_View (gnat_entity)))
377 || Is_Public (gnat_entity));
379 /* Get the name of the entity and set up the line number and filename of
380 the original definition for use in any decl we make. Make sure we do not
381 inherit another source location. */
382 gnu_entity_name = get_entity_name (gnat_entity);
383 if (Sloc (gnat_entity) != No_Location
384 && !renaming_from_generic_instantiation_p (gnat_entity))
385 Sloc_to_locus (Sloc (gnat_entity), &input_location);
387 /* For cases when we are not defining (i.e., we are referencing from
388 another compilation unit) public entities, show we are at global level
389 for the purpose of computing scopes. Don't do this for components or
390 discriminants since the relevant test is whether or not the record is
393 && kind != E_Component
394 && kind != E_Discriminant
395 && Is_Public (gnat_entity)
396 && !Is_Statically_Allocated (gnat_entity))
397 force_global++, this_global = true;
399 /* Handle any attributes directly attached to the entity. */
400 if (Has_Gigi_Rep_Item (gnat_entity))
401 prepend_attributes (&attr_list, gnat_entity);
403 /* Do some common processing for types. */
406 /* Compute the equivalent type to be used in gigi. */
407 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
409 /* Machine_Attributes on types are expected to be propagated to
410 subtypes. The corresponding Gigi_Rep_Items are only attached
411 to the first subtype though, so we handle the propagation here. */
412 if (Base_Type (gnat_entity) != gnat_entity
413 && !Is_First_Subtype (gnat_entity)
414 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
415 prepend_attributes (&attr_list,
416 First_Subtype (Base_Type (gnat_entity)));
418 /* Compute a default value for the size of an elementary type. */
419 if (Known_Esize (gnat_entity) && Is_Elementary_Type (gnat_entity))
421 unsigned int max_esize;
423 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity)));
424 esize = UI_To_Int (Esize (gnat_entity));
426 if (IN (kind, Float_Kind))
427 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
428 else if (IN (kind, Access_Kind))
429 max_esize = POINTER_SIZE * 2;
431 max_esize = LONG_LONG_TYPE_SIZE;
433 if (esize > max_esize)
443 /* The GNAT record where the component was defined. */
444 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
446 /* If the entity is a discriminant of an extended tagged type used to
447 rename a discriminant of the parent type, return the latter. */
448 if (Is_Tagged_Type (gnat_record)
449 && Present (Corresponding_Discriminant (gnat_entity)))
452 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
453 gnu_expr, definition);
458 /* If the entity is an inherited component (in the case of extended
459 tagged record types), just return the original entity, which must
460 be a FIELD_DECL. Likewise for discriminants. If the entity is a
461 non-girder discriminant (in the case of derived untagged record
462 types), return the stored discriminant it renames. */
463 else if (Present (Original_Record_Component (gnat_entity))
464 && Original_Record_Component (gnat_entity) != gnat_entity)
467 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
468 gnu_expr, definition);
473 /* Otherwise, if we are not defining this and we have no GCC type
474 for the containing record, make one for it. Then we should
475 have made our own equivalent. */
476 else if (!definition && !present_gnu_tree (gnat_record))
478 /* ??? If this is in a record whose scope is a protected
479 type and we have an Original_Record_Component, use it.
480 This is a workaround for major problems in protected type
482 Entity_Id Scop = Scope (Scope (gnat_entity));
483 if (Is_Protected_Type (Underlying_Type (Scop))
484 && Present (Original_Record_Component (gnat_entity)))
487 = gnat_to_gnu_entity (Original_Record_Component
494 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
495 gnu_decl = get_gnu_tree (gnat_entity);
501 /* Here we have no GCC type and this is a reference rather than a
502 definition. This should never happen. Most likely the cause is
503 reference before declaration in the GNAT tree for gnat_entity. */
508 /* Ignore constant definitions already marked with the error node. See
509 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
511 && present_gnu_tree (gnat_entity)
512 && get_gnu_tree (gnat_entity) == error_mark_node)
514 maybe_present = true;
518 /* Ignore deferred constant definitions without address clause since
519 they are processed fully in the front-end. If No_Initialization
520 is set, this is not a deferred constant but a constant whose value
521 is built manually. And constants that are renamings are handled
525 && No (Address_Clause (gnat_entity))
526 && !No_Initialization (Declaration_Node (gnat_entity))
527 && No (Renamed_Object (gnat_entity)))
529 gnu_decl = error_mark_node;
534 /* If this is a use of a deferred constant without address clause,
535 get its full definition. */
537 && No (Address_Clause (gnat_entity))
538 && Present (Full_View (gnat_entity)))
541 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
546 /* If we have a constant that we are not defining, get the expression it
547 was defined to represent. This is necessary to avoid generating dumb
548 elaboration code in simple cases, but we may throw it away later if it
549 is not a constant. But do not retrieve it if it is an allocator since
550 the designated type might still be dummy at this point. */
552 && !No_Initialization (Declaration_Node (gnat_entity))
553 && Present (Expression (Declaration_Node (gnat_entity)))
554 && Nkind (Expression (Declaration_Node (gnat_entity)))
556 /* The expression may contain N_Expression_With_Actions nodes and
557 thus object declarations from other units. Discard them. */
559 = gnat_to_gnu_external (Expression (Declaration_Node (gnat_entity)));
561 /* ... fall through ... */
564 case E_Loop_Parameter:
565 case E_Out_Parameter:
568 /* Always create a variable for volatile objects and variables seen
569 constant but with a Linker_Section pragma. */
571 = ((kind == E_Constant || kind == E_Variable)
572 && Is_True_Constant (gnat_entity)
573 && !(kind == E_Variable
574 && Present (Linker_Section_Pragma (gnat_entity)))
575 && !Treat_As_Volatile (gnat_entity)
576 && (((Nkind (Declaration_Node (gnat_entity))
577 == N_Object_Declaration)
578 && Present (Expression (Declaration_Node (gnat_entity))))
579 || Present (Renamed_Object (gnat_entity))
581 bool inner_const_flag = const_flag;
582 bool static_flag = Is_Statically_Allocated (gnat_entity);
583 /* We implement RM 13.3(19) for exported and imported (non-constant)
584 objects by making them volatile. */
586 = (Treat_As_Volatile (gnat_entity)
587 || (!const_flag && (Is_Exported (gnat_entity) || imported_p)));
588 bool mutable_p = false;
589 bool used_by_ref = false;
590 tree gnu_ext_name = NULL_TREE;
591 tree renamed_obj = NULL_TREE;
592 tree gnu_object_size;
594 /* We need to translate the renamed object even though we are only
595 referencing the renaming. But it may contain a call for which
596 we'll generate a temporary to hold the return value and which
597 is part of the definition of the renaming, so discard it. */
598 if (Present (Renamed_Object (gnat_entity)) && !definition)
600 if (kind == E_Exception)
601 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
604 gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
607 /* Get the type after elaborating the renamed object. */
608 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
610 /* If this is a standard exception definition, then use the standard
611 exception type. This is necessary to make sure that imported and
612 exported views of exceptions are properly merged in LTO mode. */
613 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
614 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
615 gnu_type = except_type_node;
617 /* For a debug renaming declaration, build a debug-only entity. */
618 if (Present (Debug_Renaming_Link (gnat_entity)))
620 /* Force a non-null value to make sure the symbol is retained. */
621 tree value = build1 (INDIRECT_REF, gnu_type,
623 build_pointer_type (gnu_type),
624 integer_minus_one_node));
625 gnu_decl = build_decl (input_location,
626 VAR_DECL, gnu_entity_name, gnu_type);
627 SET_DECL_VALUE_EXPR (gnu_decl, value);
628 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
629 gnat_pushdecl (gnu_decl, gnat_entity);
633 /* If this is a loop variable, its type should be the base type.
634 This is because the code for processing a loop determines whether
635 a normal loop end test can be done by comparing the bounds of the
636 loop against those of the base type, which is presumed to be the
637 size used for computation. But this is not correct when the size
638 of the subtype is smaller than the type. */
639 if (kind == E_Loop_Parameter)
640 gnu_type = get_base_type (gnu_type);
642 /* Reject non-renamed objects whose type is an unconstrained array or
643 any object whose type is a dummy type or void. */
644 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
645 && No (Renamed_Object (gnat_entity)))
646 || TYPE_IS_DUMMY_P (gnu_type)
647 || TREE_CODE (gnu_type) == VOID_TYPE)
649 gcc_assert (type_annotate_only);
652 return error_mark_node;
655 /* If an alignment is specified, use it if valid. Note that exceptions
656 are objects but don't have an alignment. We must do this before we
657 validate the size, since the alignment can affect the size. */
658 if (kind != E_Exception && Known_Alignment (gnat_entity))
660 gcc_assert (Present (Alignment (gnat_entity)));
662 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
663 TYPE_ALIGN (gnu_type));
665 /* No point in changing the type if there is an address clause
666 as the final type of the object will be a reference type. */
667 if (Present (Address_Clause (gnat_entity)))
671 tree orig_type = gnu_type;
674 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
675 false, false, definition, true);
677 /* If a padding record was made, declare it now since it will
678 never be declared otherwise. This is necessary to ensure
679 that its subtrees are properly marked. */
680 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
681 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
682 debug_info_p, gnat_entity);
686 /* If we are defining the object, see if it has a Size and validate it
687 if so. If we are not defining the object and a Size clause applies,
688 simply retrieve the value. We don't want to ignore the clause and
689 it is expected to have been validated already. Then get the new
692 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
693 gnat_entity, VAR_DECL, false,
694 Has_Size_Clause (gnat_entity));
695 else if (Has_Size_Clause (gnat_entity))
696 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
701 = make_type_from_size (gnu_type, gnu_size,
702 Has_Biased_Representation (gnat_entity));
704 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
705 gnu_size = NULL_TREE;
708 /* If this object has self-referential size, it must be a record with
709 a default discriminant. We are supposed to allocate an object of
710 the maximum size in this case, unless it is a constant with an
711 initializing expression, in which case we can get the size from
712 that. Note that the resulting size may still be a variable, so
713 this may end up with an indirect allocation. */
714 if (No (Renamed_Object (gnat_entity))
715 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
717 if (gnu_expr && kind == E_Constant)
719 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
720 if (CONTAINS_PLACEHOLDER_P (size))
722 /* If the initializing expression is itself a constant,
723 despite having a nominal type with self-referential
724 size, we can get the size directly from it. */
725 if (TREE_CODE (gnu_expr) == COMPONENT_REF
727 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
728 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
729 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
730 || DECL_READONLY_ONCE_ELAB
731 (TREE_OPERAND (gnu_expr, 0))))
732 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
735 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
740 /* We may have no GNU_EXPR because No_Initialization is
741 set even though there's an Expression. */
742 else if (kind == E_Constant
743 && (Nkind (Declaration_Node (gnat_entity))
744 == N_Object_Declaration)
745 && Present (Expression (Declaration_Node (gnat_entity))))
747 = TYPE_SIZE (gnat_to_gnu_type
749 (Expression (Declaration_Node (gnat_entity)))));
752 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
756 /* If we are at global level and the size isn't constant, call
757 elaborate_expression_1 to make a variable for it rather than
758 calculating it each time. */
759 if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
760 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
761 "SIZE", definition, false);
764 /* If the size is zero byte, make it one byte since some linkers have
765 troubles with zero-sized objects. If the object will have a
766 template, that will make it nonzero so don't bother. Also avoid
767 doing that for an object renaming or an object with an address
768 clause, as we would lose useful information on the view size
769 (e.g. for null array slices) and we are not allocating the object
772 && integer_zerop (gnu_size)
773 && !TREE_OVERFLOW (gnu_size))
774 || (TYPE_SIZE (gnu_type)
775 && integer_zerop (TYPE_SIZE (gnu_type))
776 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
777 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
778 && No (Renamed_Object (gnat_entity))
779 && No (Address_Clause (gnat_entity)))
780 gnu_size = bitsize_unit_node;
782 /* If this is an object with no specified size and alignment, and
783 if either it is atomic or we are not optimizing alignment for
784 space and it is composite and not an exception, an Out parameter
785 or a reference to another object, and the size of its type is a
786 constant, set the alignment to the smallest one which is not
787 smaller than the size, with an appropriate cap. */
788 if (!gnu_size && align == 0
789 && (Is_Atomic_Or_VFA (gnat_entity)
790 || (!Optimize_Alignment_Space (gnat_entity)
791 && kind != E_Exception
792 && kind != E_Out_Parameter
793 && Is_Composite_Type (Etype (gnat_entity))
794 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
795 && !Is_Exported (gnat_entity)
797 && No (Renamed_Object (gnat_entity))
798 && No (Address_Clause (gnat_entity))))
799 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
801 unsigned int size_cap, align_cap;
803 /* No point in promoting the alignment if this doesn't prevent
804 BLKmode access to the object, in particular block copy, as
805 this will for example disable the NRV optimization for it.
806 No point in jumping through all the hoops needed in order
807 to support BIGGEST_ALIGNMENT if we don't really have to.
808 So we cap to the smallest alignment that corresponds to
809 a known efficient memory access pattern of the target. */
810 if (Is_Atomic_Or_VFA (gnat_entity))
813 align_cap = BIGGEST_ALIGNMENT;
817 size_cap = MAX_FIXED_MODE_SIZE;
818 align_cap = get_mode_alignment (ptr_mode);
821 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
822 || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
824 else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
827 align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
829 /* But make sure not to under-align the object. */
830 if (align <= TYPE_ALIGN (gnu_type))
833 /* And honor the minimum valid atomic alignment, if any. */
834 #ifdef MINIMUM_ATOMIC_ALIGNMENT
835 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
836 align = MINIMUM_ATOMIC_ALIGNMENT;
840 /* If the object is set to have atomic components, find the component
841 type and validate it.
843 ??? Note that we ignore Has_Volatile_Components on objects; it's
844 not at all clear what to do in that case. */
845 if (Has_Atomic_Components (gnat_entity))
847 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
848 ? TREE_TYPE (gnu_type) : gnu_type);
850 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
851 && TYPE_MULTI_ARRAY_P (gnu_inner))
852 gnu_inner = TREE_TYPE (gnu_inner);
854 check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
857 /* If this is an aliased object with an unconstrained array nominal
858 subtype, make a type that includes the template. We will either
859 allocate or create a variable of that type, see below. */
860 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
861 && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
862 && !type_annotate_only)
865 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
867 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
869 concat_name (gnu_entity_name,
874 /* ??? If this is an object of CW type initialized to a value, try to
875 ensure that the object is sufficient aligned for this value, but
876 without pessimizing the allocation. This is a kludge necessary
877 because we don't support dynamic alignment. */
879 && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype
880 && No (Renamed_Object (gnat_entity))
881 && No (Address_Clause (gnat_entity)))
882 align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
884 #ifdef MINIMUM_ATOMIC_ALIGNMENT
885 /* If the size is a constant and no alignment is specified, force
886 the alignment to be the minimum valid atomic alignment. The
887 restriction on constant size avoids problems with variable-size
888 temporaries; if the size is variable, there's no issue with
889 atomic access. Also don't do this for a constant, since it isn't
890 necessary and can interfere with constant replacement. Finally,
891 do not do it for Out parameters since that creates an
892 size inconsistency with In parameters. */
894 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
895 && !FLOAT_TYPE_P (gnu_type)
896 && !const_flag && No (Renamed_Object (gnat_entity))
897 && !imported_p && No (Address_Clause (gnat_entity))
898 && kind != E_Out_Parameter
899 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
900 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
901 align = MINIMUM_ATOMIC_ALIGNMENT;
904 /* Make a new type with the desired size and alignment, if needed.
905 But do not take into account alignment promotions to compute the
906 size of the object. */
907 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
908 if (gnu_size || align > 0)
910 tree orig_type = gnu_type;
912 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
913 false, false, definition, true);
915 /* If a padding record was made, declare it now since it will
916 never be declared otherwise. This is necessary to ensure
917 that its subtrees are properly marked. */
918 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
919 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
920 debug_info_p, gnat_entity);
923 /* Now check if the type of the object allows atomic access. */
924 if (Is_Atomic_Or_VFA (gnat_entity))
925 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
927 /* If this is a renaming, avoid as much as possible to create a new
928 object. However, in some cases, creating it is required because
929 renaming can be applied to objects that are not names in Ada.
930 This processing needs to be applied to the raw expression so as
931 to make it more likely to rename the underlying object. */
932 if (Present (Renamed_Object (gnat_entity)))
934 /* If the renamed object had padding, strip off the reference to
935 the inner object and reset our type. */
936 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
937 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
938 /* Strip useless conversions around the object. */
939 || gnat_useless_type_conversion (gnu_expr))
941 gnu_expr = TREE_OPERAND (gnu_expr, 0);
942 gnu_type = TREE_TYPE (gnu_expr);
945 /* Or else, if the renamed object has an unconstrained type with
946 default discriminant, use the padded type. */
947 else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
948 gnu_type = TREE_TYPE (gnu_expr);
950 /* Case 1: if this is a constant renaming stemming from a function
951 call, treat it as a normal object whose initial value is what
952 is being renamed. RM 3.3 says that the result of evaluating a
953 function call is a constant object. Therefore, it can be the
954 inner object of a constant renaming and the renaming must be
955 fully instantiated, i.e. it cannot be a reference to (part of)
956 an existing object. And treat other rvalues (addresses, null
957 expressions, constructors and literals) the same way. */
958 tree inner = gnu_expr;
959 while (handled_component_p (inner) || CONVERT_EXPR_P (inner))
960 inner = TREE_OPERAND (inner, 0);
961 /* Expand_Dispatching_Call can prepend a comparison of the tags
962 before the call to "=". */
963 if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
964 || TREE_CODE (inner) == COMPOUND_EXPR)
965 inner = TREE_OPERAND (inner, 1);
966 if ((TREE_CODE (inner) == CALL_EXPR
967 && !call_is_atomic_load (inner))
968 || TREE_CODE (inner) == ADDR_EXPR
969 || TREE_CODE (inner) == NULL_EXPR
970 || TREE_CODE (inner) == PLUS_EXPR
971 || TREE_CODE (inner) == CONSTRUCTOR
972 || CONSTANT_CLASS_P (inner)
973 /* We need to detect the case where a temporary is created to
974 hold the return value, since we cannot safely rename it at
975 top level as it lives only in the elaboration routine. */
976 || (TREE_CODE (inner) == VAR_DECL
977 && DECL_RETURN_VALUE_P (inner))
978 /* We also need to detect the case where the front-end creates
979 a dangling 'reference to a function call at top level and
980 substitutes it in the renaming, for example:
982 q__b : boolean renames r__f.e (1);
984 can be rewritten into:
986 q__R1s : constant q__A2s := r__f'reference;
988 q__b : boolean renames q__R1s.all.e (1);
990 We cannot safely rename the rewritten expression since the
991 underlying object lives only in the elaboration routine. */
992 || (TREE_CODE (inner) == INDIRECT_REF
994 = remove_conversions (TREE_OPERAND (inner, 0), true))
995 && TREE_CODE (inner) == VAR_DECL
996 && DECL_RETURN_VALUE_P (inner)))
999 /* Case 2: if the renaming entity need not be materialized, use
1000 the elaborated renamed expression for the renaming. But this
1001 means that the caller is responsible for evaluating the address
1002 of the renaming in the correct place for the definition case to
1003 instantiate the SAVE_EXPRs. */
1004 else if (!Materialize_Entity (gnat_entity))
1006 tree init = NULL_TREE;
1009 = elaborate_reference (gnu_expr, gnat_entity, definition,
1012 /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
1013 correct place for this case. */
1016 /* No DECL_EXPR will be created so the expression needs to be
1017 marked manually because it will likely be shared. */
1018 if (global_bindings_p ())
1019 MARK_VISITED (gnu_decl);
1021 /* This assertion will fail if the renamed object isn't aligned
1022 enough as to make it possible to honor the alignment set on
1026 unsigned int ralign = DECL_P (gnu_decl)
1027 ? DECL_ALIGN (gnu_decl)
1028 : TYPE_ALIGN (TREE_TYPE (gnu_decl));
1029 gcc_assert (ralign >= align);
1032 save_gnu_tree (gnat_entity, gnu_decl, true);
1034 annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
1038 /* Case 3: otherwise, make a constant pointer to the object we
1039 are renaming and attach the object to the pointer after it is
1040 elaborated. The object will be referenced directly instead
1041 of indirectly via the pointer to avoid aliasing problems with
1042 non-addressable entities. The pointer is called a "renaming"
1043 pointer in this case. Note that we also need to preserve the
1044 volatility of the renamed object through the indirection. */
1047 tree init = NULL_TREE;
1049 if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
1051 = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1052 gnu_type = build_reference_type (gnu_type);
1055 volatile_flag = false;
1056 inner_const_flag = TREE_READONLY (gnu_expr);
1057 gnu_size = NULL_TREE;
1060 = elaborate_reference (gnu_expr, gnat_entity, definition,
1063 /* The expression needs to be marked manually because it will
1064 likely be shared, even for a definition since the ADDR_EXPR
1065 built below can cause the first few nodes to be folded. */
1066 if (global_bindings_p ())
1067 MARK_VISITED (renamed_obj);
1069 if (type_annotate_only
1070 && TREE_CODE (renamed_obj) == ERROR_MARK)
1071 gnu_expr = NULL_TREE;
1075 = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
1078 = build_compound_expr (TREE_TYPE (gnu_expr), init,
1084 /* If we are defining an aliased object whose nominal subtype is
1085 unconstrained, the object is a record that contains both the
1086 template and the object. If there is an initializer, it will
1087 have already been converted to the right type, but we need to
1088 create the template if there is no initializer. */
1091 && TREE_CODE (gnu_type) == RECORD_TYPE
1092 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1093 /* Beware that padding might have been introduced above. */
1094 || (TYPE_PADDING_P (gnu_type)
1095 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1097 && TYPE_CONTAINS_TEMPLATE_P
1098 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1101 = TYPE_PADDING_P (gnu_type)
1102 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1103 : TYPE_FIELDS (gnu_type);
1104 vec<constructor_elt, va_gc> *v;
1106 tree t = build_template (TREE_TYPE (template_field),
1107 TREE_TYPE (DECL_CHAIN (template_field)),
1109 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1110 gnu_expr = gnat_build_constructor (gnu_type, v);
1113 /* Convert the expression to the type of the object if need be. */
1114 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1115 gnu_expr = convert (gnu_type, gnu_expr);
1117 /* If this is a pointer that doesn't have an initializing expression,
1118 initialize it to NULL, unless the object is declared imported as
1121 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1123 && !Is_Imported (gnat_entity))
1124 gnu_expr = integer_zero_node;
1126 /* If we are defining the object and it has an Address clause, we must
1127 either get the address expression from the saved GCC tree for the
1128 object if it has a Freeze node, or elaborate the address expression
1129 here since the front-end has guaranteed that the elaboration has no
1130 effects in this case. */
1131 if (definition && Present (Address_Clause (gnat_entity)))
1133 const Node_Id gnat_clause = Address_Clause (gnat_entity);
1134 Node_Id gnat_expr = Expression (gnat_clause);
1136 = present_gnu_tree (gnat_entity)
1137 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1139 save_gnu_tree (gnat_entity, NULL_TREE, false);
1141 /* Convert the type of the object to a reference type that can
1142 alias everything as per RM 13.3(19). */
1143 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1144 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1146 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1147 gnu_address = convert (gnu_type, gnu_address);
1150 = (!Is_Public (gnat_entity)
1151 || compile_time_known_address_p (gnat_expr));
1152 volatile_flag = false;
1153 gnu_size = NULL_TREE;
1155 /* If this is an aliased object with an unconstrained array nominal
1156 subtype, then it can overlay only another aliased object with an
1157 unconstrained array nominal subtype and compatible template. */
1158 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
1159 && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
1160 && !type_annotate_only)
1162 tree rec_type = TREE_TYPE (gnu_type);
1163 tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
1165 /* This is the pattern built for a regular object. */
1166 if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1167 && TREE_OPERAND (gnu_address, 1) == off)
1168 gnu_address = TREE_OPERAND (gnu_address, 0);
1169 /* This is the pattern built for an overaligned object. */
1170 else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1171 && TREE_CODE (TREE_OPERAND (gnu_address, 1))
1173 && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
1176 = build2 (POINTER_PLUS_EXPR, gnu_type,
1177 TREE_OPERAND (gnu_address, 0),
1178 TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
1181 post_error_ne ("aliased object& with unconstrained array "
1182 "nominal subtype", gnat_clause,
1184 post_error ("\\can overlay only aliased object with "
1185 "compatible subtype", gnat_clause);
1189 /* If we don't have an initializing expression for the underlying
1190 variable, the initializing expression for the pointer is the
1191 specified address. Otherwise, we have to make a COMPOUND_EXPR
1192 to assign both the address and the initial value. */
1194 gnu_expr = gnu_address;
1197 = build2 (COMPOUND_EXPR, gnu_type,
1198 build_binary_op (INIT_EXPR, NULL_TREE,
1199 build_unary_op (INDIRECT_REF,
1206 /* If it has an address clause and we are not defining it, mark it
1207 as an indirect object. Likewise for Stdcall objects that are
1209 if ((!definition && Present (Address_Clause (gnat_entity)))
1210 || (imported_p && Has_Stdcall_Convention (gnat_entity)))
1212 /* Convert the type of the object to a reference type that can
1213 alias everything as per RM 13.3(19). */
1214 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1215 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1217 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1220 volatile_flag = false;
1221 gnu_size = NULL_TREE;
1223 /* No point in taking the address of an initializing expression
1224 that isn't going to be used. */
1225 gnu_expr = NULL_TREE;
1227 /* If it has an address clause whose value is known at compile
1228 time, make the object a CONST_DECL. This will avoid a
1229 useless dereference. */
1230 if (Present (Address_Clause (gnat_entity)))
1232 Node_Id gnat_address
1233 = Expression (Address_Clause (gnat_entity));
1235 if (compile_time_known_address_p (gnat_address))
1237 gnu_expr = gnat_to_gnu (gnat_address);
1243 /* If we are at top level and this object is of variable size,
1244 make the actual type a hidden pointer to the real type and
1245 make the initializer be a memory allocation and initialization.
1246 Likewise for objects we aren't defining (presumed to be
1247 external references from other packages), but there we do
1248 not set up an initialization.
1250 If the object's size overflows, make an allocator too, so that
1251 Storage_Error gets raised. Note that we will never free
1252 such memory, so we presume it never will get allocated. */
1253 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1254 global_bindings_p ()
1258 && !allocatable_size_p (convert (sizetype,
1260 (CEIL_DIV_EXPR, gnu_size,
1261 bitsize_unit_node)),
1262 global_bindings_p ()
1266 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1267 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1268 gnu_type = build_reference_type (gnu_type);
1271 volatile_flag = false;
1272 gnu_size = NULL_TREE;
1274 /* In case this was a aliased object whose nominal subtype is
1275 unconstrained, the pointer above will be a thin pointer and
1276 build_allocator will automatically make the template.
1278 If we have a template initializer only (that we made above),
1279 pretend there is none and rely on what build_allocator creates
1280 again anyway. Otherwise (if we have a full initializer), get
1281 the data part and feed that to build_allocator.
1283 If we are elaborating a mutable object, tell build_allocator to
1284 ignore a possibly simpler size from the initializer, if any, as
1285 we must allocate the maximum possible size in this case. */
1286 if (definition && !imported_p)
1288 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1290 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1291 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1294 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1296 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1297 && vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr)) == 1)
1298 gnu_expr = NULL_TREE;
1301 = build_component_ref
1303 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1307 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1308 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
1309 post_error ("?`Storage_Error` will be raised at run time!",
1313 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1314 Empty, Empty, gnat_entity, mutable_p);
1317 gnu_expr = NULL_TREE;
1320 /* If this object would go into the stack and has an alignment larger
1321 than the largest stack alignment the back-end can honor, resort to
1322 a variable of "aligning type". */
1324 && !global_bindings_p ()
1327 && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1329 /* Create the new variable. No need for extra room before the
1330 aligned field as this is in automatic storage. */
1332 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1333 TYPE_SIZE_UNIT (gnu_type),
1334 BIGGEST_ALIGNMENT, 0, gnat_entity);
1336 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1337 NULL_TREE, gnu_new_type, NULL_TREE,
1338 false, false, false, false, false,
1339 true, debug_info_p, NULL, gnat_entity);
1341 /* Initialize the aligned field if we have an initializer. */
1344 (build_binary_op (INIT_EXPR, NULL_TREE,
1346 (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1351 /* And setup this entity as a reference to the aligned field. */
1352 gnu_type = build_reference_type (gnu_type);
1355 (ADDR_EXPR, NULL_TREE,
1356 build_component_ref (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1358 TREE_CONSTANT (gnu_expr) = 1;
1362 volatile_flag = false;
1363 gnu_size = NULL_TREE;
1366 /* If this is an aliased object with an unconstrained array nominal
1367 subtype, we make its type a thin reference, i.e. the reference
1368 counterpart of a thin pointer, so it points to the array part.
1369 This is aimed to make it easier for the debugger to decode the
1370 object. Note that we have to do it this late because of the
1371 couple of allocation adjustments that might be made above. */
1372 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
1373 && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
1374 && !type_annotate_only)
1376 /* In case the object with the template has already been allocated
1377 just above, we have nothing to do here. */
1378 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1380 /* This variable is a GNAT encoding used by Workbench: let it
1381 go through the debugging information but mark it as
1382 artificial: users are not interested in it. */
1384 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1385 NULL_TREE, gnu_type, gnu_expr,
1386 const_flag, Is_Public (gnat_entity),
1387 imported_p || !definition, static_flag,
1388 volatile_flag, true, debug_info_p,
1390 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1391 TREE_CONSTANT (gnu_expr) = 1;
1395 volatile_flag = false;
1396 inner_const_flag = TREE_READONLY (gnu_unc_var);
1397 gnu_size = NULL_TREE;
1401 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
1403 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1407 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
1409 /* Convert the expression to the type of the object if need be. */
1410 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1411 gnu_expr = convert (gnu_type, gnu_expr);
1413 /* If this name is external or a name was specified, use it, but don't
1414 use the Interface_Name with an address clause (see cd30005). */
1415 if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity))
1416 || (Present (Interface_Name (gnat_entity))
1417 && No (Address_Clause (gnat_entity))))
1418 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1420 /* If this is an aggregate constant initialized to a constant, force it
1421 to be statically allocated. This saves an initialization copy. */
1424 && gnu_expr && TREE_CONSTANT (gnu_expr)
1425 && AGGREGATE_TYPE_P (gnu_type)
1426 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
1427 && !(TYPE_IS_PADDING_P (gnu_type)
1428 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1429 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1432 /* Deal with a pragma Linker_Section on a constant or variable. */
1433 if ((kind == E_Constant || kind == E_Variable)
1434 && Present (Linker_Section_Pragma (gnat_entity)))
1435 prepend_one_attribute_pragma (&attr_list,
1436 Linker_Section_Pragma (gnat_entity));
1438 /* Now create the variable or the constant and set various flags. */
1440 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1441 gnu_expr, const_flag, Is_Public (gnat_entity),
1442 imported_p || !definition, static_flag,
1443 volatile_flag, artificial_p, debug_info_p,
1444 attr_list, gnat_entity, !renamed_obj);
1445 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1446 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1447 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1449 /* If we are defining an Out parameter and optimization isn't enabled,
1450 create a fake PARM_DECL for debugging purposes and make it point to
1451 the VAR_DECL. Suppress debug info for the latter but make sure it
1452 will live in memory so that it can be accessed from within the
1453 debugger through the PARM_DECL. */
1454 if (kind == E_Out_Parameter
1458 && !flag_generate_lto)
1460 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1461 gnat_pushdecl (param, gnat_entity);
1462 SET_DECL_VALUE_EXPR (param, gnu_decl);
1463 DECL_HAS_VALUE_EXPR_P (param) = 1;
1464 DECL_IGNORED_P (gnu_decl) = 1;
1465 TREE_ADDRESSABLE (gnu_decl) = 1;
1468 /* If this is a loop parameter, set the corresponding flag. */
1469 else if (kind == E_Loop_Parameter)
1470 DECL_LOOP_PARM_P (gnu_decl) = 1;
1472 /* If this is a renaming pointer, attach the renamed object to it. */
1474 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1476 /* If this is a constant and we are defining it or it generates a real
1477 symbol at the object level and we are referencing it, we may want
1478 or need to have a true variable to represent it:
1479 - if optimization isn't enabled, for debugging purposes,
1480 - if the constant is public and not overlaid on something else,
1481 - if its address is taken,
1482 - if either itself or its type is aliased. */
1483 if (TREE_CODE (gnu_decl) == CONST_DECL
1484 && (definition || Sloc (gnat_entity) > Standard_Location)
1485 && ((!optimize && debug_info_p)
1486 || (Is_Public (gnat_entity)
1487 && No (Address_Clause (gnat_entity)))
1488 || Address_Taken (gnat_entity)
1489 || Is_Aliased (gnat_entity)
1490 || Is_Aliased (Etype (gnat_entity))))
1493 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1494 gnu_expr, true, Is_Public (gnat_entity),
1495 !definition, static_flag, volatile_flag,
1496 artificial_p, debug_info_p, attr_list,
1497 gnat_entity, false);
1499 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1502 /* If this is a constant, even if we don't need a true variable, we
1503 may need to avoid returning the initializer in every case. That
1504 can happen for the address of a (constant) constructor because,
1505 upon dereferencing it, the constructor will be reinjected in the
1506 tree, which may not be valid in every case; see lvalue_required_p
1507 for more details. */
1508 if (TREE_CODE (gnu_decl) == CONST_DECL)
1509 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1511 /* If this object is declared in a block that contains a block with an
1512 exception handler, and we aren't using the GCC exception mechanism,
1513 we must force this variable in memory in order to avoid an invalid
1515 if (Front_End_Exceptions ()
1516 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1517 TREE_ADDRESSABLE (gnu_decl) = 1;
1519 /* If this is a local variable with non-BLKmode and aggregate type,
1520 and optimization isn't enabled, then force it in memory so that
1521 a register won't be allocated to it with possible subparts left
1522 uninitialized and reaching the register allocator. */
1523 else if (TREE_CODE (gnu_decl) == VAR_DECL
1524 && !DECL_EXTERNAL (gnu_decl)
1525 && !TREE_STATIC (gnu_decl)
1526 && DECL_MODE (gnu_decl) != BLKmode
1527 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl))
1528 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl))
1530 TREE_ADDRESSABLE (gnu_decl) = 1;
1532 /* If we are defining an object with variable size or an object with
1533 fixed size that will be dynamically allocated, and we are using the
1534 front-end setjmp/longjmp exception mechanism, update the setjmp
1537 && Exception_Mechanism == Front_End_SJLJ
1538 && get_block_jmpbuf_decl ()
1539 && DECL_SIZE_UNIT (gnu_decl)
1540 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1541 || (flag_stack_check == GENERIC_STACK_CHECK
1542 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1543 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1544 add_stmt_with_node (build_call_n_expr
1545 (update_setjmp_buf_decl, 1,
1546 build_unary_op (ADDR_EXPR, NULL_TREE,
1547 get_block_jmpbuf_decl ())),
1550 /* Back-annotate Esize and Alignment of the object if not already
1551 known. Note that we pick the values of the type, not those of
1552 the object, to shield ourselves from low-level platform-dependent
1553 adjustments like alignment promotion. This is both consistent with
1554 all the treatment above, where alignment and size are set on the
1555 type of the object and not on the object directly, and makes it
1556 possible to support all confirming representation clauses. */
1557 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1563 /* Return a TYPE_DECL for "void" that we previously made. */
1564 gnu_decl = TYPE_NAME (void_type_node);
1567 case E_Enumeration_Type:
1568 /* A special case: for the types Character and Wide_Character in
1569 Standard, we do not list all the literals. So if the literals
1570 are not specified, make this an integer type. */
1571 if (No (First_Literal (gnat_entity)))
1573 if (esize == CHAR_TYPE_SIZE && flag_signed_char)
1574 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1576 gnu_type = make_unsigned_type (esize);
1577 TYPE_NAME (gnu_type) = gnu_entity_name;
1579 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1580 This is needed by the DWARF-2 back-end to distinguish between
1581 unsigned integer types and character types. */
1582 TYPE_STRING_FLAG (gnu_type) = 1;
1584 /* This flag is needed by the call just below. */
1585 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1587 finish_character_type (gnu_type);
1591 /* We have a list of enumeral constants in First_Literal. We make a
1592 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1593 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1594 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1595 value of the literal. But when we have a regular boolean type, we
1596 simplify this a little by using a BOOLEAN_TYPE. */
1597 const bool is_boolean = Is_Boolean_Type (gnat_entity)
1598 && !Has_Non_Standard_Rep (gnat_entity);
1599 const bool is_unsigned = Is_Unsigned_Type (gnat_entity);
1600 tree gnu_list = NULL_TREE;
1601 Entity_Id gnat_literal;
1603 gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1604 TYPE_PRECISION (gnu_type) = esize;
1605 TYPE_UNSIGNED (gnu_type) = is_unsigned;
1606 set_min_and_max_values_for_integral_type (gnu_type, esize,
1607 TYPE_SIGN (gnu_type));
1608 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
1609 layout_type (gnu_type);
1611 for (gnat_literal = First_Literal (gnat_entity);
1612 Present (gnat_literal);
1613 gnat_literal = Next_Literal (gnat_literal))
1616 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1617 /* Do not generate debug info for individual enumerators. */
1619 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1620 gnu_type, gnu_value, true, false, false,
1621 false, false, artificial_p, false,
1622 NULL, gnat_literal);
1623 save_gnu_tree (gnat_literal, gnu_literal, false);
1625 = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list);
1629 TYPE_VALUES (gnu_type) = nreverse (gnu_list);
1631 /* Note that the bounds are updated at the end of this function
1632 to avoid an infinite recursion since they refer to the type. */
1637 case E_Signed_Integer_Type:
1638 /* For integer types, just make a signed type the appropriate number
1640 gnu_type = make_signed_type (esize);
1643 case E_Ordinary_Fixed_Point_Type:
1644 case E_Decimal_Fixed_Point_Type:
1646 /* Small_Value is the scale factor. */
1647 const Ureal gnat_small_value = Small_Value (gnat_entity);
1648 tree scale_factor = NULL_TREE;
1650 gnu_type = make_signed_type (esize);
1652 /* Try to decode the scale factor and to save it for the fixed-point
1653 types debug hook. */
1655 /* There are various ways to describe the scale factor, however there
1656 are cases where back-end internals cannot hold it. In such cases,
1657 we output invalid scale factor for such cases (i.e. the 0/0
1658 rational constant) but we expect GNAT to output GNAT encodings,
1659 then. Thus, keep this in sync with
1660 Exp_Dbug.Is_Handled_Scale_Factor. */
1662 /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
1663 binary or decimal scale: it is easier to read for humans. */
1664 if (UI_Eq (Numerator (gnat_small_value), Uint_1)
1665 && (Rbase (gnat_small_value) == 2
1666 || Rbase (gnat_small_value) == 10))
1668 /* Given RM restrictions on 'Small values, we assume here that
1669 the denominator fits in an int. */
1670 const tree base = build_int_cst (integer_type_node,
1671 Rbase (gnat_small_value));
1673 = build_int_cst (integer_type_node,
1674 UI_To_Int (Denominator (gnat_small_value)));
1676 = build2 (RDIV_EXPR, integer_type_node,
1678 build2 (POWER_EXPR, integer_type_node,
1682 /* Default to arbitrary scale factors descriptions. */
1685 const Uint num = Norm_Num (gnat_small_value);
1686 const Uint den = Norm_Den (gnat_small_value);
1688 if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
1691 = build_int_cst (integer_type_node,
1692 UI_To_Int (Norm_Num (gnat_small_value)));
1694 = build_int_cst (integer_type_node,
1695 UI_To_Int (Norm_Den (gnat_small_value)));
1696 scale_factor = build2 (RDIV_EXPR, integer_type_node,
1700 /* If compiler internals cannot represent arbitrary scale
1701 factors, output an invalid scale factor so that debugger
1702 don't try to handle them but so that we still have a type
1703 in the output. Note that GNAT */
1704 scale_factor = integer_zero_node;
1707 TYPE_FIXED_POINT_P (gnu_type) = 1;
1708 SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor);
1712 case E_Modular_Integer_Type:
1714 /* For modular types, make the unsigned type of the proper number
1715 of bits and then set up the modulus, if required. */
1716 tree gnu_modulus, gnu_high = NULL_TREE;
1718 /* Packed Array Impl. Types are supposed to be subtypes only. */
1719 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity));
1721 gnu_type = make_unsigned_type (esize);
1723 /* Get the modulus in this type. If it overflows, assume it is because
1724 it is equal to 2**Esize. Note that there is no overflow checking
1725 done on unsigned type, so we detect the overflow by looking for
1726 a modulus of zero, which is otherwise invalid. */
1727 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1729 if (!integer_zerop (gnu_modulus))
1731 TYPE_MODULAR_P (gnu_type) = 1;
1732 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1733 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1734 build_int_cst (gnu_type, 1));
1737 /* If the upper bound is not maximal, make an extra subtype. */
1739 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1741 tree gnu_subtype = make_unsigned_type (esize);
1742 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1743 TREE_TYPE (gnu_subtype) = gnu_type;
1744 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1745 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1746 gnu_type = gnu_subtype;
1751 case E_Signed_Integer_Subtype:
1752 case E_Enumeration_Subtype:
1753 case E_Modular_Integer_Subtype:
1754 case E_Ordinary_Fixed_Point_Subtype:
1755 case E_Decimal_Fixed_Point_Subtype:
1757 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1758 not want to call create_range_type since we would like each subtype
1759 node to be distinct. ??? Historically this was in preparation for
1760 when memory aliasing is implemented, but that's obsolete now given
1761 the call to relate_alias_sets below.
1763 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1764 this fact is used by the arithmetic conversion functions.
1766 We elaborate the Ancestor_Subtype if it is not in the current unit
1767 and one of our bounds is non-static. We do this to ensure consistent
1768 naming in the case where several subtypes share the same bounds, by
1769 elaborating the first such subtype first, thus using its name. */
1772 && Present (Ancestor_Subtype (gnat_entity))
1773 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1774 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1775 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1776 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1778 /* Set the precision to the Esize except for bit-packed arrays. */
1779 if (Is_Packed_Array_Impl_Type (gnat_entity)
1780 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1781 esize = UI_To_Int (RM_Size (gnat_entity));
1783 /* First subtypes of Character are treated as Character; otherwise
1784 this should be an unsigned type if the base type is unsigned or
1785 if the lower bound is constant and non-negative or if the type
1787 if (kind == E_Enumeration_Subtype
1788 && No (First_Literal (Etype (gnat_entity)))
1789 && Esize (gnat_entity) == RM_Size (gnat_entity)
1790 && esize == CHAR_TYPE_SIZE
1791 && flag_signed_char)
1792 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1793 else if (Is_Unsigned_Type (Etype (gnat_entity))
1794 || Is_Unsigned_Type (gnat_entity)
1795 || Has_Biased_Representation (gnat_entity))
1796 gnu_type = make_unsigned_type (esize);
1798 gnu_type = make_signed_type (esize);
1799 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1801 SET_TYPE_RM_MIN_VALUE
1802 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
1803 gnat_entity, "L", definition, true,
1806 SET_TYPE_RM_MAX_VALUE
1807 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
1808 gnat_entity, "U", definition, true,
1811 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1812 = Has_Biased_Representation (gnat_entity);
1814 /* Do the same processing for Character subtypes as for types. */
1815 if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
1817 TYPE_NAME (gnu_type) = gnu_entity_name;
1818 TYPE_STRING_FLAG (gnu_type) = 1;
1819 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1820 finish_character_type (gnu_type);
1823 /* Inherit our alias set from what we're a subtype of. Subtypes
1824 are not different types and a pointer can designate any instance
1825 within a subtype hierarchy. */
1826 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1828 /* One of the above calls might have caused us to be elaborated,
1829 so don't blow up if so. */
1830 if (present_gnu_tree (gnat_entity))
1832 maybe_present = true;
1836 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1837 TYPE_STUB_DECL (gnu_type)
1838 = create_type_stub_decl (gnu_entity_name, gnu_type);
1840 /* For a packed array, make the original array type a parallel/debug
1842 if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
1843 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1847 /* We have to handle clauses that under-align the type specially. */
1848 if ((Present (Alignment_Clause (gnat_entity))
1849 || (Is_Packed_Array_Impl_Type (gnat_entity)
1851 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1852 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1854 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1855 if (align >= TYPE_ALIGN (gnu_type))
1859 /* If the type we are dealing with represents a bit-packed array,
1860 we need to have the bits left justified on big-endian targets
1861 and right justified on little-endian targets. We also need to
1862 ensure that when the value is read (e.g. for comparison of two
1863 such values), we only get the good bits, since the unused bits
1864 are uninitialized. Both goals are accomplished by wrapping up
1865 the modular type in an enclosing record type. */
1866 if (Is_Packed_Array_Impl_Type (gnat_entity)
1867 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1869 tree gnu_field_type, gnu_field;
1871 /* Set the RM size before wrapping up the original type. */
1872 SET_TYPE_RM_SIZE (gnu_type,
1873 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1874 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1876 /* Strip the ___XP suffix for standard DWARF. */
1877 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1878 gnu_entity_name = TYPE_NAME (gnu_type);
1880 /* Create a stripped-down declaration, mainly for debugging. */
1881 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1884 /* Now save it and build the enclosing record type. */
1885 gnu_field_type = gnu_type;
1887 gnu_type = make_node (RECORD_TYPE);
1888 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1889 TYPE_PACKED (gnu_type) = 1;
1890 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1891 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1892 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1894 /* Propagate the alignment of the modular type to the record type,
1895 unless there is an alignment clause that under-aligns the type.
1896 This means that bit-packed arrays are given "ceil" alignment for
1897 their size by default, which may seem counter-intuitive but makes
1898 it possible to overlay them on modular types easily. */
1899 SET_TYPE_ALIGN (gnu_type,
1900 align > 0 ? align : TYPE_ALIGN (gnu_field_type));
1902 /* Propagate the reverse storage order flag to the record type so
1903 that the required byte swapping is performed when retrieving the
1904 enclosed modular value. */
1905 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
1906 = Reverse_Storage_Order (Original_Array_Type (gnat_entity));
1908 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1910 /* Don't declare the field as addressable since we won't be taking
1911 its address and this would prevent create_field_decl from making
1914 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1915 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1917 /* Do not emit debug info until after the parallel type is added. */
1918 finish_record_type (gnu_type, gnu_field, 2, false);
1919 compute_record_mode (gnu_type);
1920 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1924 /* Make the original array type a parallel/debug type. */
1925 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1927 /* Since GNU_TYPE is a padding type around the packed array
1928 implementation type, the padded type is its debug type. */
1929 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1930 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
1932 rest_of_record_type_compilation (gnu_type);
1936 /* If the type we are dealing with has got a smaller alignment than the
1937 natural one, we need to wrap it up in a record type and misalign the
1938 latter; we reuse the padding machinery for this purpose. Note that,
1939 even if the record type is marked as packed because of misalignment,
1940 we don't pack the field so as to give it the size of the type. */
1943 tree gnu_field_type, gnu_field;
1945 /* Set the RM size before wrapping up the type. */
1946 SET_TYPE_RM_SIZE (gnu_type,
1947 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1949 /* Create a stripped-down declaration, mainly for debugging. */
1950 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1953 /* Now save it and build the enclosing record type. */
1954 gnu_field_type = gnu_type;
1956 gnu_type = make_node (RECORD_TYPE);
1957 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1958 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1959 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
1960 TYPE_PACKED (gnu_type) = 1;
1961 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1962 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1963 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1964 SET_TYPE_ALIGN (gnu_type, align);
1965 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1967 /* Don't declare the field as addressable since we won't be taking
1968 its address and this would prevent create_field_decl from making
1971 = create_field_decl (get_identifier ("F"), gnu_field_type,
1972 gnu_type, TYPE_SIZE (gnu_field_type),
1973 bitsize_zero_node, 0, 0);
1975 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1976 compute_record_mode (gnu_type);
1977 TYPE_PADDING_P (gnu_type) = 1;
1982 case E_Floating_Point_Type:
1983 /* The type of the Low and High bounds can be our type if this is
1984 a type from Standard, so set them at the end of the function. */
1985 gnu_type = make_node (REAL_TYPE);
1986 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1987 layout_type (gnu_type);
1990 case E_Floating_Point_Subtype:
1991 /* See the E_Signed_Integer_Subtype case for the rationale. */
1993 && Present (Ancestor_Subtype (gnat_entity))
1994 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1995 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1996 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1997 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1999 gnu_type = make_node (REAL_TYPE);
2000 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
2001 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
2002 TYPE_GCC_MIN_VALUE (gnu_type)
2003 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
2004 TYPE_GCC_MAX_VALUE (gnu_type)
2005 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
2006 layout_type (gnu_type);
2008 SET_TYPE_RM_MIN_VALUE
2009 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
2010 gnat_entity, "L", definition, true,
2013 SET_TYPE_RM_MAX_VALUE
2014 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
2015 gnat_entity, "U", definition, true,
2018 /* Inherit our alias set from what we're a subtype of, as for
2019 integer subtypes. */
2020 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
2022 /* One of the above calls might have caused us to be elaborated,
2023 so don't blow up if so. */
2024 maybe_present = true;
2027 /* Array Types and Subtypes
2029 Unconstrained array types are represented by E_Array_Type and
2030 constrained array types are represented by E_Array_Subtype. There
2031 are no actual objects of an unconstrained array type; all we have
2032 are pointers to that type.
2034 The following fields are defined on array types and subtypes:
2036 Component_Type Component type of the array.
2037 Number_Dimensions Number of dimensions (an int).
2038 First_Index Type of first index. */
2042 const bool convention_fortran_p
2043 = (Convention (gnat_entity) == Convention_Fortran);
2044 const int ndim = Number_Dimensions (gnat_entity);
2045 tree gnu_template_type;
2046 tree gnu_ptr_template;
2047 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
2048 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2049 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2050 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
2051 Entity_Id gnat_index, gnat_name;
2055 /* Create the type for the component now, as it simplifies breaking
2056 type reference loops. */
2058 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2059 if (present_gnu_tree (gnat_entity))
2061 /* As a side effect, the type may have been translated. */
2062 maybe_present = true;
2066 /* We complete an existing dummy fat pointer type in place. This both
2067 avoids further complex adjustments in update_pointer_to and yields
2068 better debugging information in DWARF by leveraging the support for
2069 incomplete declarations of "tagged" types in the DWARF back-end. */
2070 gnu_type = get_dummy_type (gnat_entity);
2071 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2073 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2074 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2075 /* Save the contents of the dummy type for update_pointer_to. */
2076 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2078 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2079 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2083 gnu_fat_type = make_node (RECORD_TYPE);
2084 gnu_template_type = make_node (RECORD_TYPE);
2085 gnu_ptr_template = build_pointer_type (gnu_template_type);
2088 /* Make a node for the array. If we are not defining the array
2089 suppress expanding incomplete types. */
2090 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2094 defer_incomplete_level++;
2095 this_deferred = true;
2098 /* Build the fat pointer type. Use a "void *" object instead of
2099 a pointer to the array type since we don't have the array type
2100 yet (it will reference the fat pointer via the bounds). */
2102 = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node,
2103 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2105 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
2106 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2108 if (COMPLETE_TYPE_P (gnu_fat_type))
2110 /* We are going to lay it out again so reset the alias set. */
2111 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
2112 TYPE_ALIAS_SET (gnu_fat_type) = -1;
2113 finish_fat_pointer_type (gnu_fat_type, tem);
2114 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
2115 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2117 TYPE_FIELDS (t) = tem;
2118 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2123 finish_fat_pointer_type (gnu_fat_type, tem);
2124 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2127 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2128 is the fat pointer. This will be used to access the individual
2129 fields once we build them. */
2130 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2131 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2132 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
2133 gnu_template_reference
2134 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2135 TREE_READONLY (gnu_template_reference) = 1;
2136 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2138 /* Now create the GCC type for each index and add the fields for that
2139 index to the template. */
2140 for (index = (convention_fortran_p ? ndim - 1 : 0),
2141 gnat_index = First_Index (gnat_entity);
2142 0 <= index && index < ndim;
2143 index += (convention_fortran_p ? - 1 : 1),
2144 gnat_index = Next_Index (gnat_index))
2146 char field_name[16];
2147 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2148 tree gnu_index_base_type
2149 = maybe_character_type (get_base_type (gnu_index_type));
2150 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2151 tree gnu_min, gnu_max, gnu_high;
2153 /* Make the FIELD_DECLs for the low and high bounds of this
2154 type and then make extractions of these fields from the
2156 sprintf (field_name, "LB%d", index);
2157 gnu_lb_field = create_field_decl (get_identifier (field_name),
2158 gnu_index_base_type,
2159 gnu_template_type, NULL_TREE,
2161 Sloc_to_locus (Sloc (gnat_entity),
2162 &DECL_SOURCE_LOCATION (gnu_lb_field));
2164 field_name[0] = 'U';
2165 gnu_hb_field = create_field_decl (get_identifier (field_name),
2166 gnu_index_base_type,
2167 gnu_template_type, NULL_TREE,
2169 Sloc_to_locus (Sloc (gnat_entity),
2170 &DECL_SOURCE_LOCATION (gnu_hb_field));
2172 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2174 /* We can't use build_component_ref here since the template type
2175 isn't complete yet. */
2176 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2177 gnu_template_reference, gnu_lb_field,
2179 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2180 gnu_template_reference, gnu_hb_field,
2182 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2184 gnu_min = convert (sizetype, gnu_orig_min);
2185 gnu_max = convert (sizetype, gnu_orig_max);
2187 /* Compute the size of this dimension. See the E_Array_Subtype
2188 case below for the rationale. */
2190 = build3 (COND_EXPR, sizetype,
2191 build2 (GE_EXPR, boolean_type_node,
2192 gnu_orig_max, gnu_orig_min),
2194 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2196 /* Make a range type with the new range in the Ada base type.
2197 Then make an index type with the size range in sizetype. */
2198 gnu_index_types[index]
2199 = create_index_type (gnu_min, gnu_high,
2200 create_range_type (gnu_index_base_type,
2205 /* Update the maximum size of the array in elements. */
2209 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2211 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2213 = size_binop (PLUS_EXPR, size_one_node,
2214 size_binop (MINUS_EXPR, gnu_max, gnu_min));
2216 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2217 && TREE_OVERFLOW (gnu_this_max))
2218 gnu_max_size = NULL_TREE;
2221 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2224 TYPE_NAME (gnu_index_types[index])
2225 = create_concat_name (gnat_entity, field_name);
2228 /* Install all the fields into the template. */
2229 TYPE_NAME (gnu_template_type)
2230 = create_concat_name (gnat_entity, "XUB");
2231 gnu_template_fields = NULL_TREE;
2232 for (index = 0; index < ndim; index++)
2234 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2235 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2237 TYPE_READONLY (gnu_template_type) = 1;
2239 /* If Component_Size is not already specified, annotate it with the
2240 size of the component. */
2241 if (Unknown_Component_Size (gnat_entity))
2242 Set_Component_Size (gnat_entity,
2243 annotate_value (TYPE_SIZE (comp_type)));
2245 /* Compute the maximum size of the array in units and bits. */
2248 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2249 TYPE_SIZE_UNIT (comp_type));
2250 gnu_max_size = size_binop (MULT_EXPR,
2251 convert (bitsizetype, gnu_max_size),
2252 TYPE_SIZE (comp_type));
2255 gnu_max_size_unit = NULL_TREE;
2257 /* Now build the array type. */
2259 for (index = ndim - 1; index >= 0; index--)
2261 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2262 if (index == ndim - 1)
2263 TYPE_REVERSE_STORAGE_ORDER (tem)
2264 = Reverse_Storage_Order (gnat_entity);
2265 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2266 if (array_type_has_nonaliased_component (tem, gnat_entity))
2267 TYPE_NONALIASED_COMPONENT (tem) = 1;
2270 /* If an alignment is specified, use it if valid. But ignore it
2271 for the original type of packed array types. If the alignment
2272 was requested with an explicit alignment clause, state so. */
2273 if (No (Packed_Array_Impl_Type (gnat_entity))
2274 && Known_Alignment (gnat_entity))
2276 SET_TYPE_ALIGN (tem,
2277 validate_alignment (Alignment (gnat_entity),
2280 if (Present (Alignment_Clause (gnat_entity)))
2281 TYPE_USER_ALIGN (tem) = 1;
2284 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2286 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2287 implementation types as such so that the debug information back-end
2288 can output the appropriate description for them. */
2290 = (Is_Packed (gnat_entity)
2291 || Is_Packed_Array_Impl_Type (gnat_entity));
2293 if (Treat_As_Volatile (gnat_entity))
2294 tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
2296 /* Adjust the type of the pointer-to-array field of the fat pointer
2297 and record the aliasing relationships if necessary. */
2298 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2299 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2300 record_component_aliases (gnu_fat_type);
2302 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2303 corresponding fat pointer. */
2304 TREE_TYPE (gnu_type) = gnu_fat_type;
2305 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2306 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2307 SET_TYPE_MODE (gnu_type, BLKmode);
2308 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
2310 /* If the maximum size doesn't overflow, use it. */
2312 && TREE_CODE (gnu_max_size) == INTEGER_CST
2313 && !TREE_OVERFLOW (gnu_max_size)
2314 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2315 && !TREE_OVERFLOW (gnu_max_size_unit))
2317 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2319 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2320 TYPE_SIZE_UNIT (tem));
2323 create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
2324 artificial_p, debug_info_p, gnat_entity);
2326 /* If told to generate GNAT encodings for them (GDB rely on them at the
2327 moment): give the fat pointer type a name. If this is a packed
2328 array, tell the debugger how to interpret the underlying bits. */
2329 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2330 gnat_name = Packed_Array_Impl_Type (gnat_entity);
2332 gnat_name = gnat_entity;
2334 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2335 ? get_entity_name (gnat_name)
2336 : create_concat_name (gnat_name, "XUP");
2337 create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
2340 /* Create the type to be designated by thin pointers: a record type for
2341 the array and its template. We used to shift the fields to have the
2342 template at a negative offset, but this was somewhat of a kludge; we
2343 now shift thin pointer values explicitly but only those which have a
2344 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
2345 Note that GDB can handle standard DWARF information for them, so we
2346 don't have to name them as a GNAT encoding, except if specifically
2349 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2350 ? get_entity_name (gnat_name)
2351 : create_concat_name (gnat_name, "XUT");
2352 tem = build_unc_object_type (gnu_template_type, tem, xut_name,
2355 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2356 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2360 case E_Array_Subtype:
2362 /* This is the actual data type for array variables. Multidimensional
2363 arrays are implemented as arrays of arrays. Note that arrays which
2364 have sparse enumeration subtypes as index components create sparse
2365 arrays, which is obviously space inefficient but so much easier to
2368 Also note that the subtype never refers to the unconstrained array
2369 type, which is somewhat at variance with Ada semantics.
2371 First check to see if this is simply a renaming of the array type.
2372 If so, the result is the array type. */
2374 gnu_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity)));
2375 if (!Is_Constrained (gnat_entity))
2379 Entity_Id gnat_index, gnat_base_index;
2380 const bool convention_fortran_p
2381 = (Convention (gnat_entity) == Convention_Fortran);
2382 const int ndim = Number_Dimensions (gnat_entity);
2383 tree gnu_base_type = gnu_type;
2384 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2385 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2386 bool need_index_type_struct = false;
2389 /* First create the GCC type for each index and find out whether
2390 special types are needed for debugging information. */
2391 for (index = (convention_fortran_p ? ndim - 1 : 0),
2392 gnat_index = First_Index (gnat_entity),
2394 = First_Index (Implementation_Base_Type (gnat_entity));
2395 0 <= index && index < ndim;
2396 index += (convention_fortran_p ? - 1 : 1),
2397 gnat_index = Next_Index (gnat_index),
2398 gnat_base_index = Next_Index (gnat_base_index))
2400 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2401 tree gnu_index_base_type
2402 = maybe_character_type (get_base_type (gnu_index_type));
2404 = convert (gnu_index_base_type,
2405 TYPE_MIN_VALUE (gnu_index_type));
2407 = convert (gnu_index_base_type,
2408 TYPE_MAX_VALUE (gnu_index_type));
2409 tree gnu_min = convert (sizetype, gnu_orig_min);
2410 tree gnu_max = convert (sizetype, gnu_orig_max);
2411 tree gnu_base_index_type
2412 = get_unpadded_type (Etype (gnat_base_index));
2413 tree gnu_base_index_base_type
2414 = maybe_character_type (get_base_type (gnu_base_index_type));
2415 tree gnu_base_orig_min
2416 = convert (gnu_base_index_base_type,
2417 TYPE_MIN_VALUE (gnu_base_index_type));
2418 tree gnu_base_orig_max
2419 = convert (gnu_base_index_base_type,
2420 TYPE_MAX_VALUE (gnu_base_index_type));
2423 /* See if the base array type is already flat. If it is, we
2424 are probably compiling an ACATS test but it will cause the
2425 code below to malfunction if we don't handle it specially. */
2426 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2427 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2428 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2430 gnu_min = size_one_node;
2431 gnu_max = size_zero_node;
2435 /* Similarly, if one of the values overflows in sizetype and the
2436 range is null, use 1..0 for the sizetype bounds. */
2437 else if (TREE_CODE (gnu_min) == INTEGER_CST
2438 && TREE_CODE (gnu_max) == INTEGER_CST
2439 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2440 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2442 gnu_min = size_one_node;
2443 gnu_max = size_zero_node;
2447 /* If the minimum and maximum values both overflow in sizetype,
2448 but the difference in the original type does not overflow in
2449 sizetype, ignore the overflow indication. */
2450 else if (TREE_CODE (gnu_min) == INTEGER_CST
2451 && TREE_CODE (gnu_max) == INTEGER_CST
2452 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2455 fold_build2 (MINUS_EXPR, gnu_index_type,
2459 TREE_OVERFLOW (gnu_min) = 0;
2460 TREE_OVERFLOW (gnu_max) = 0;
2464 /* Compute the size of this dimension in the general case. We
2465 need to provide GCC with an upper bound to use but have to
2466 deal with the "superflat" case. There are three ways to do
2467 this. If we can prove that the array can never be superflat,
2468 we can just use the high bound of the index type. */
2469 else if ((Nkind (gnat_index) == N_Range
2470 && cannot_be_superflat (gnat_index))
2471 /* Bit-Packed Array Impl. Types are never superflat. */
2472 || (Is_Packed_Array_Impl_Type (gnat_entity)
2473 && Is_Bit_Packed_Array
2474 (Original_Array_Type (gnat_entity))))
2477 /* Otherwise, if the high bound is constant but the low bound is
2478 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2479 lower bound. Note that the comparison must be done in the
2480 original type to avoid any overflow during the conversion. */
2481 else if (TREE_CODE (gnu_max) == INTEGER_CST
2482 && TREE_CODE (gnu_min) != INTEGER_CST)
2486 = build_cond_expr (sizetype,
2487 build_binary_op (GE_EXPR,
2492 int_const_binop (PLUS_EXPR, gnu_max,
2496 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2497 in all the other cases. Note that, here as well as above,
2498 the condition used in the comparison must be equivalent to
2499 the condition (length != 0). This is relied upon in order
2500 to optimize array comparisons in compare_arrays. Moreover
2501 we use int_const_binop for the shift by 1 if the bound is
2502 constant to avoid any unwanted overflow. */
2505 = build_cond_expr (sizetype,
2506 build_binary_op (GE_EXPR,
2511 TREE_CODE (gnu_min) == INTEGER_CST
2512 ? int_const_binop (MINUS_EXPR, gnu_min,
2514 : size_binop (MINUS_EXPR, gnu_min,
2517 /* Reuse the index type for the range type. Then make an index
2518 type with the size range in sizetype. */
2519 gnu_index_types[index]
2520 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2523 /* Update the maximum size of the array in elements. Here we
2524 see if any constraint on the index type of the base type
2525 can be used in the case of self-referential bound on the
2526 index type of the subtype. We look for a non-"infinite"
2527 and non-self-referential bound from any type involved and
2528 handle each bound separately. */
2531 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2532 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2533 tree gnu_base_base_min
2534 = convert (sizetype,
2535 TYPE_MIN_VALUE (gnu_base_index_base_type));
2536 tree gnu_base_base_max
2537 = convert (sizetype,
2538 TYPE_MAX_VALUE (gnu_base_index_base_type));
2540 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2541 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2542 && !TREE_OVERFLOW (gnu_base_min)))
2543 gnu_base_min = gnu_min;
2545 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2546 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2547 && !TREE_OVERFLOW (gnu_base_max)))
2548 gnu_base_max = gnu_max;
2550 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2551 && TREE_OVERFLOW (gnu_base_min))
2552 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2553 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2554 && TREE_OVERFLOW (gnu_base_max))
2555 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2556 gnu_max_size = NULL_TREE;
2561 /* Use int_const_binop if the bounds are constant to
2562 avoid any unwanted overflow. */
2563 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2564 && TREE_CODE (gnu_base_max) == INTEGER_CST)
2566 = int_const_binop (PLUS_EXPR, size_one_node,
2567 int_const_binop (MINUS_EXPR,
2572 = size_binop (PLUS_EXPR, size_one_node,
2573 size_binop (MINUS_EXPR,
2578 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2582 /* We need special types for debugging information to point to
2583 the index types if they have variable bounds, are not integer
2584 types, are biased or are wider than sizetype. These are GNAT
2585 encodings, so we have to include them only when all encodings
2587 if ((TREE_CODE (gnu_orig_min) != INTEGER_CST
2588 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2589 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2590 || (TREE_TYPE (gnu_index_type)
2591 && TREE_CODE (TREE_TYPE (gnu_index_type))
2593 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
2594 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2595 need_index_type_struct = true;
2598 /* Then flatten: create the array of arrays. For an array type
2599 used to implement a packed array, get the component type from
2600 the original array type since the representation clauses that
2601 can affect it are on the latter. */
2602 if (Is_Packed_Array_Impl_Type (gnat_entity)
2603 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2605 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2606 for (index = ndim - 1; index >= 0; index--)
2607 gnu_type = TREE_TYPE (gnu_type);
2609 /* One of the above calls might have caused us to be elaborated,
2610 so don't blow up if so. */
2611 if (present_gnu_tree (gnat_entity))
2613 maybe_present = true;
2619 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2622 /* One of the above calls might have caused us to be elaborated,
2623 so don't blow up if so. */
2624 if (present_gnu_tree (gnat_entity))
2626 maybe_present = true;
2631 /* Compute the maximum size of the array in units and bits. */
2634 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2635 TYPE_SIZE_UNIT (gnu_type));
2636 gnu_max_size = size_binop (MULT_EXPR,
2637 convert (bitsizetype, gnu_max_size),
2638 TYPE_SIZE (gnu_type));
2641 gnu_max_size_unit = NULL_TREE;
2643 /* Now build the array type. */
2644 for (index = ndim - 1; index >= 0; index --)
2646 gnu_type = build_nonshared_array_type (gnu_type,
2647 gnu_index_types[index]);
2648 if (index == ndim - 1)
2649 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
2650 = Reverse_Storage_Order (gnat_entity);
2651 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2652 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2653 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2656 /* Strip the ___XP suffix for standard DWARF. */
2657 if (Is_Packed_Array_Impl_Type (gnat_entity)
2658 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2660 Entity_Id gnat_original_array_type
2661 = Underlying_Type (Original_Array_Type (gnat_entity));
2664 = get_entity_name (gnat_original_array_type);
2667 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2668 TYPE_STUB_DECL (gnu_type)
2669 = create_type_stub_decl (gnu_entity_name, gnu_type);
2671 /* If we are at file level and this is a multi-dimensional array,
2672 we need to make a variable corresponding to the stride of the
2673 inner dimensions. */
2674 if (global_bindings_p () && ndim > 1)
2678 for (gnu_arr_type = TREE_TYPE (gnu_type), index = 1;
2679 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2680 gnu_arr_type = TREE_TYPE (gnu_arr_type), index++)
2682 tree eltype = TREE_TYPE (gnu_arr_type);
2683 char stride_name[32];
2685 sprintf (stride_name, "ST%d", index);
2686 TYPE_SIZE (gnu_arr_type)
2687 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2688 gnat_entity, stride_name,
2691 /* ??? For now, store the size as a multiple of the
2692 alignment of the element type in bytes so that we
2693 can see the alignment from the tree. */
2694 sprintf (stride_name, "ST%d_A_UNIT", index);
2695 TYPE_SIZE_UNIT (gnu_arr_type)
2696 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2697 gnat_entity, stride_name,
2699 TYPE_ALIGN (eltype));
2701 /* ??? create_type_decl is not invoked on the inner types so
2702 the MULT_EXPR node built above will never be marked. */
2703 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2707 /* If we need to write out a record type giving the names of the
2708 bounds for debugging purposes, do it now and make the record
2709 type a parallel type. This is not needed for a packed array
2710 since the bounds are conveyed by the original array type. */
2711 if (need_index_type_struct
2713 && !Is_Packed_Array_Impl_Type (gnat_entity))
2715 tree gnu_bound_rec = make_node (RECORD_TYPE);
2716 tree gnu_field_list = NULL_TREE;
2719 TYPE_NAME (gnu_bound_rec)
2720 = create_concat_name (gnat_entity, "XA");
2722 for (index = ndim - 1; index >= 0; index--)
2724 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2725 tree gnu_index_name = TYPE_IDENTIFIER (gnu_index);
2727 /* Make sure to reference the types themselves, and not just
2728 their names, as the debugger may fall back on them. */
2729 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2730 gnu_bound_rec, NULL_TREE,
2732 DECL_CHAIN (gnu_field) = gnu_field_list;
2733 gnu_field_list = gnu_field;
2736 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2737 add_parallel_type (gnu_type, gnu_bound_rec);
2740 /* If this is a packed array type, make the original array type a
2741 parallel/debug type. Otherwise, if such GNAT encodings are
2742 required, do it for the base array type if it isn't artificial to
2743 make sure it is kept in the debug info. */
2746 if (Is_Packed_Array_Impl_Type (gnat_entity))
2747 associate_original_type_to_packed_array (gnu_type,
2752 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2753 if (!DECL_ARTIFICIAL (gnu_base_decl)
2754 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2755 add_parallel_type (gnu_type,
2756 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2760 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2761 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2762 = (Is_Packed_Array_Impl_Type (gnat_entity)
2763 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2765 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2766 implementation types as such so that the debug information back-end
2767 can output the appropriate description for them. */
2768 TYPE_PACKED (gnu_type)
2769 = (Is_Packed (gnat_entity)
2770 || Is_Packed_Array_Impl_Type (gnat_entity));
2772 /* If the size is self-referential and the maximum size doesn't
2773 overflow, use it. */
2774 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2776 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2777 && TREE_OVERFLOW (gnu_max_size))
2778 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2779 && TREE_OVERFLOW (gnu_max_size_unit)))
2781 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2782 TYPE_SIZE (gnu_type));
2783 TYPE_SIZE_UNIT (gnu_type)
2784 = size_binop (MIN_EXPR, gnu_max_size_unit,
2785 TYPE_SIZE_UNIT (gnu_type));
2788 /* Set our alias set to that of our base type. This gives all
2789 array subtypes the same alias set. */
2790 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2792 /* If this is a packed type, make this type the same as the packed
2793 array type, but do some adjusting in the type first. */
2794 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2796 Entity_Id gnat_index;
2799 /* First finish the type we had been making so that we output
2800 debugging information for it. */
2801 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
2802 if (Treat_As_Volatile (gnat_entity))
2805 = TYPE_QUAL_VOLATILE
2806 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
2807 gnu_type = change_qualified_type (gnu_type, quals);
2809 /* Make it artificial only if the base type was artificial too.
2810 That's sort of "morally" true and will make it possible for
2811 the debugger to look it up by name in DWARF, which is needed
2812 in order to decode the packed array type. */
2814 = create_type_decl (gnu_entity_name, gnu_type,
2815 !Comes_From_Source (Etype (gnat_entity))
2816 && artificial_p, debug_info_p,
2819 /* Save it as our equivalent in case the call below elaborates
2821 save_gnu_tree (gnat_entity, gnu_decl, false);
2824 = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
2826 this_made_decl = true;
2827 gnu_type = TREE_TYPE (gnu_decl);
2829 save_gnu_tree (gnat_entity, NULL_TREE, false);
2831 gnu_inner = gnu_type;
2832 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2833 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2834 || TYPE_PADDING_P (gnu_inner)))
2835 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2837 /* We need to attach the index type to the type we just made so
2838 that the actual bounds can later be put into a template. */
2839 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2840 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2841 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2842 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2844 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2846 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2847 TYPE_MODULUS for modular types so we make an extra
2848 subtype if necessary. */
2849 if (TYPE_MODULAR_P (gnu_inner))
2852 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2853 TREE_TYPE (gnu_subtype) = gnu_inner;
2854 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2855 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2856 TYPE_MIN_VALUE (gnu_inner));
2857 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2858 TYPE_MAX_VALUE (gnu_inner));
2859 gnu_inner = gnu_subtype;
2862 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2864 /* Check for other cases of overloading. */
2865 gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2868 for (gnat_index = First_Index (gnat_entity);
2869 Present (gnat_index);
2870 gnat_index = Next_Index (gnat_index))
2871 SET_TYPE_ACTUAL_BOUNDS
2873 tree_cons (NULL_TREE,
2874 get_unpadded_type (Etype (gnat_index)),
2875 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2877 if (Convention (gnat_entity) != Convention_Fortran)
2878 SET_TYPE_ACTUAL_BOUNDS
2879 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2881 if (TREE_CODE (gnu_type) == RECORD_TYPE
2882 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2883 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2888 /* Abort if packed array with no Packed_Array_Impl_Type. */
2889 gcc_assert (!Is_Packed (gnat_entity));
2893 case E_String_Literal_Subtype:
2894 /* Create the type for a string literal. */
2896 Entity_Id gnat_full_type
2897 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2898 && Present (Full_View (Etype (gnat_entity)))
2899 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2900 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2901 tree gnu_string_array_type
2902 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2903 tree gnu_string_index_type
2904 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2905 (TYPE_DOMAIN (gnu_string_array_type))));
2906 tree gnu_lower_bound
2907 = convert (gnu_string_index_type,
2908 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2910 = UI_To_gnu (String_Literal_Length (gnat_entity),
2911 gnu_string_index_type);
2912 tree gnu_upper_bound
2913 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2915 int_const_binop (MINUS_EXPR, gnu_length,
2916 convert (gnu_string_index_type,
2917 integer_one_node)));
2919 = create_index_type (convert (sizetype, gnu_lower_bound),
2920 convert (sizetype, gnu_upper_bound),
2921 create_range_type (gnu_string_index_type,
2927 = build_nonshared_array_type (gnat_to_gnu_type
2928 (Component_Type (gnat_entity)),
2930 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2931 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2932 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2936 /* Record Types and Subtypes
2938 The following fields are defined on record types:
2940 Has_Discriminants True if the record has discriminants
2941 First_Discriminant Points to head of list of discriminants
2942 First_Entity Points to head of list of fields
2943 Is_Tagged_Type True if the record is tagged
2945 Implementation of Ada records and discriminated records:
2947 A record type definition is transformed into the equivalent of a C
2948 struct definition. The fields that are the discriminants which are
2949 found in the Full_Type_Declaration node and the elements of the
2950 Component_List found in the Record_Type_Definition node. The
2951 Component_List can be a recursive structure since each Variant of
2952 the Variant_Part of the Component_List has a Component_List.
2954 Processing of a record type definition comprises starting the list of
2955 field declarations here from the discriminants and the calling the
2956 function components_to_record to add the rest of the fields from the
2957 component list and return the gnu type node. The function
2958 components_to_record will call itself recursively as it traverses
2962 if (Has_Complex_Representation (gnat_entity))
2965 = build_complex_type
2967 (Etype (Defining_Entity
2968 (First (Component_Items
2971 (Declaration_Node (gnat_entity)))))))));
2977 Node_Id full_definition = Declaration_Node (gnat_entity);
2978 Node_Id record_definition = Type_Definition (full_definition);
2979 Node_Id gnat_constr;
2980 Entity_Id gnat_field;
2981 tree gnu_field, gnu_field_list = NULL_TREE;
2982 tree gnu_get_parent;
2983 /* Set PACKED in keeping with gnat_to_gnu_field. */
2985 = Is_Packed (gnat_entity)
2987 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2990 const bool has_align = Known_Alignment (gnat_entity);
2991 const bool has_discr = Has_Discriminants (gnat_entity);
2992 const bool has_rep = Has_Specified_Layout (gnat_entity);
2993 const bool is_extension
2994 = (Is_Tagged_Type (gnat_entity)
2995 && Nkind (record_definition) == N_Derived_Type_Definition);
2996 const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2997 bool all_rep = has_rep;
2999 /* See if all fields have a rep clause. Stop when we find one
3002 for (gnat_field = First_Entity (gnat_entity);
3003 Present (gnat_field);
3004 gnat_field = Next_Entity (gnat_field))
3005 if ((Ekind (gnat_field) == E_Component
3006 || Ekind (gnat_field) == E_Discriminant)
3007 && No (Component_Clause (gnat_field)))
3013 /* If this is a record extension, go a level further to find the
3014 record definition. Also, verify we have a Parent_Subtype. */
3017 if (!type_annotate_only
3018 || Present (Record_Extension_Part (record_definition)))
3019 record_definition = Record_Extension_Part (record_definition);
3021 gcc_assert (type_annotate_only
3022 || Present (Parent_Subtype (gnat_entity)));
3025 /* Make a node for the record. If we are not defining the record,
3026 suppress expanding incomplete types. */
3027 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
3028 TYPE_NAME (gnu_type) = gnu_entity_name;
3029 TYPE_PACKED (gnu_type) = (packed != 0) || has_align || has_rep;
3030 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3031 = Reverse_Storage_Order (gnat_entity);
3032 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3036 defer_incomplete_level++;
3037 this_deferred = true;
3040 /* If both a size and rep clause were specified, put the size on
3041 the record type now so that it can get the proper layout. */
3042 if (has_rep && Known_RM_Size (gnat_entity))
3043 TYPE_SIZE (gnu_type)
3044 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
3046 /* Always set the alignment on the record type here so that it can
3047 get the proper layout. */
3049 SET_TYPE_ALIGN (gnu_type,
3050 validate_alignment (Alignment (gnat_entity),
3054 SET_TYPE_ALIGN (gnu_type, 0);
3056 /* If a type needs strict alignment, the minimum size will be the
3057 type size instead of the RM size (see validate_size). Cap the
3058 alignment lest it causes this type size to become too large. */
3059 if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity))
3061 unsigned int max_size = UI_To_Int (RM_Size (gnat_entity));
3062 unsigned int max_align = max_size & -max_size;
3063 if (max_align < BIGGEST_ALIGNMENT)
3064 TYPE_MAX_ALIGN (gnu_type) = max_align;
3068 /* If we have a Parent_Subtype, make a field for the parent. If
3069 this record has rep clauses, force the position to zero. */
3070 if (Present (Parent_Subtype (gnat_entity)))
3072 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
3073 tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
3076 /* A major complexity here is that the parent subtype will
3077 reference our discriminants in its Stored_Constraint list.
3078 But those must reference the parent component of this record
3079 which is precisely of the parent subtype we have not built yet!
3080 To break the circle we first build a dummy COMPONENT_REF which
3081 represents the "get to the parent" operation and initialize
3082 each of those discriminants to a COMPONENT_REF of the above
3083 dummy parent referencing the corresponding discriminant of the
3084 base type of the parent subtype. */
3085 gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type,
3086 build0 (PLACEHOLDER_EXPR, gnu_type),
3087 build_decl (input_location,
3088 FIELD_DECL, NULL_TREE,
3089 gnu_dummy_parent_type),
3093 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3094 Present (gnat_field);
3095 gnat_field = Next_Stored_Discriminant (gnat_field))
3096 if (Present (Corresponding_Discriminant (gnat_field)))
3099 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3103 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3104 gnu_get_parent, gnu_field, NULL_TREE),
3108 /* Then we build the parent subtype. If it has discriminants but
3109 the type itself has unknown discriminants, this means that it
3110 doesn't contain information about how the discriminants are
3111 derived from those of the ancestor type, so it cannot be used
3112 directly. Instead it is built by cloning the parent subtype
3113 of the underlying record view of the type, for which the above
3114 derivation of discriminants has been made explicit. */
3115 if (Has_Discriminants (gnat_parent)
3116 && Has_Unknown_Discriminants (gnat_entity))
3118 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3120 /* If we are defining the type, the underlying record
3121 view must already have been elaborated at this point.
3122 Otherwise do it now as its parent subtype cannot be
3123 technically elaborated on its own. */
3125 gcc_assert (present_gnu_tree (gnat_uview));
3127 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
3129 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3131 /* Substitute the "get to the parent" of the type for that
3132 of its underlying record view in the cloned type. */
3133 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3134 Present (gnat_field);
3135 gnat_field = Next_Stored_Discriminant (gnat_field))
3136 if (Present (Corresponding_Discriminant (gnat_field)))
3138 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3140 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3141 gnu_get_parent, gnu_field, NULL_TREE);
3143 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3147 gnu_parent = gnat_to_gnu_type (gnat_parent);
3149 /* The parent field needs strict alignment so, if it is to
3150 be created with a component clause below, then we need
3151 to apply the same adjustment as in gnat_to_gnu_field. */
3152 if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
3153 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
3155 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3156 initially built. The discriminants must reference the fields
3157 of the parent subtype and not those of its base type for the
3158 placeholder machinery to properly work. */
3161 /* The actual parent subtype is the full view. */
3162 if (IN (Ekind (gnat_parent), Private_Kind))
3164 if (Present (Full_View (gnat_parent)))
3165 gnat_parent = Full_View (gnat_parent);
3167 gnat_parent = Underlying_Full_View (gnat_parent);
3170 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3171 Present (gnat_field);
3172 gnat_field = Next_Stored_Discriminant (gnat_field))
3173 if (Present (Corresponding_Discriminant (gnat_field)))
3176 for (field = First_Stored_Discriminant (gnat_parent);
3178 field = Next_Stored_Discriminant (field))
3179 if (same_discriminant_p (gnat_field, field))
3181 gcc_assert (Present (field));
3182 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3183 = gnat_to_gnu_field_decl (field);
3187 /* The "get to the parent" COMPONENT_REF must be given its
3189 TREE_TYPE (gnu_get_parent) = gnu_parent;
3191 /* ...and reference the _Parent field of this record. */
3193 = create_field_decl (parent_name_id,
3194 gnu_parent, gnu_type,
3196 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3198 ? bitsize_zero_node : NULL_TREE,
3200 DECL_INTERNAL_P (gnu_field) = 1;
3201 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3202 TYPE_FIELDS (gnu_type) = gnu_field;
3205 /* Make the fields for the discriminants and put them into the record
3206 unless it's an Unchecked_Union. */
3208 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3209 Present (gnat_field);
3210 gnat_field = Next_Stored_Discriminant (gnat_field))
3212 /* If this is a record extension and this discriminant is the
3213 renaming of another discriminant, we've handled it above. */
3214 if (Present (Parent_Subtype (gnat_entity))
3215 && Present (Corresponding_Discriminant (gnat_field)))
3218 /* However, if we are just annotating types, the Parent_Subtype
3219 doesn't exist so we need skip the discriminant altogether. */
3220 if (type_annotate_only
3221 && Is_Tagged_Type (gnat_entity)
3222 && Is_Derived_Type (gnat_entity)
3223 && Present (Corresponding_Discriminant (gnat_field)))
3227 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3230 /* Make an expression using a PLACEHOLDER_EXPR from the
3231 FIELD_DECL node just created and link that with the
3232 corresponding GNAT defining identifier. */
3233 save_gnu_tree (gnat_field,
3234 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3235 build0 (PLACEHOLDER_EXPR, gnu_type),
3236 gnu_field, NULL_TREE),
3239 if (!is_unchecked_union)
3241 DECL_CHAIN (gnu_field) = gnu_field_list;
3242 gnu_field_list = gnu_field;
3246 /* If we have a derived untagged type that renames discriminants in
3247 the root type, the (stored) discriminants are a just copy of the
3248 discriminants of the root type. This means that any constraints
3249 added by the renaming in the derivation are disregarded as far
3250 as the layout of the derived type is concerned. To rescue them,
3251 we change the type of the (stored) discriminants to a subtype
3252 with the bounds of the type of the visible discriminants. */
3255 && Stored_Constraint (gnat_entity) != No_Elist)
3256 for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
3257 gnat_constr != No_Elmt;
3258 gnat_constr = Next_Elmt (gnat_constr))
3259 if (Nkind (Node (gnat_constr)) == N_Identifier
3260 /* Ignore access discriminants. */
3261 && !Is_Access_Type (Etype (Node (gnat_constr)))
3262 && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
3264 Entity_Id gnat_discr = Entity (Node (gnat_constr));
3265 tree gnu_discr_type, gnu_ref;
3267 /* If the scope of the discriminant is not the record type,
3268 this means that we're processing the implicit full view
3269 of a type derived from a private discriminated type: in
3270 this case, the Stored_Constraint list is simply copied
3271 from the partial view, see Build_Derived_Private_Type.
3272 So we need to retrieve the corresponding discriminant
3273 of the implicit full view, otherwise we will abort. */
3274 if (Scope (gnat_discr) != gnat_entity)
3277 for (field = First_Entity (gnat_entity);
3279 field = Next_Entity (field))
3280 if (Ekind (field) == E_Discriminant
3281 && same_discriminant_p (gnat_discr, field))
3283 gcc_assert (Present (field));
3287 gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
3289 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
3292 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3293 just above for one of the stored discriminants. */
3294 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
3296 if (gnu_discr_type != TREE_TYPE (gnu_ref))
3298 const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref));
3300 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref))
3301 ? make_unsigned_type (prec) : make_signed_type (prec);
3302 TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref);
3303 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
3304 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
3305 TYPE_MIN_VALUE (gnu_discr_type));
3306 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
3307 TYPE_MAX_VALUE (gnu_discr_type));
3309 = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype;
3313 /* Add the fields into the record type and finish it up. */
3314 components_to_record (gnu_type, Component_List (record_definition),
3315 gnu_field_list, packed, definition, false,
3316 all_rep, is_unchecked_union,
3317 artificial_p, debug_info_p,
3318 false, OK_To_Reorder_Components (gnat_entity),
3319 all_rep ? NULL_TREE : bitsize_zero_node, NULL);
3321 /* Fill in locations of fields. */
3322 annotate_rep (gnat_entity, gnu_type);
3324 /* If there are any entities in the chain corresponding to components
3325 that we did not elaborate, ensure we elaborate their types if they
3327 for (gnat_temp = First_Entity (gnat_entity);
3328 Present (gnat_temp);
3329 gnat_temp = Next_Entity (gnat_temp))
3330 if ((Ekind (gnat_temp) == E_Component
3331 || Ekind (gnat_temp) == E_Discriminant)
3332 && Is_Itype (Etype (gnat_temp))
3333 && !present_gnu_tree (gnat_temp))
3334 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3336 /* If this is a record type associated with an exception definition,
3337 equate its fields to those of the standard exception type. This
3338 will make it possible to convert between them. */
3339 if (gnu_entity_name == exception_data_name_id)
3342 for (gnu_field = TYPE_FIELDS (gnu_type),
3343 gnu_std_field = TYPE_FIELDS (except_type_node);
3345 gnu_field = DECL_CHAIN (gnu_field),
3346 gnu_std_field = DECL_CHAIN (gnu_std_field))
3347 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3348 gcc_assert (!gnu_std_field);
3353 case E_Class_Wide_Subtype:
3354 /* If an equivalent type is present, that is what we should use.
3355 Otherwise, fall through to handle this like a record subtype
3356 since it may have constraints. */
3357 if (gnat_equiv_type != gnat_entity)
3359 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3360 maybe_present = true;
3364 /* ... fall through ... */
3366 case E_Record_Subtype:
3367 /* If Cloned_Subtype is Present it means this record subtype has
3368 identical layout to that type or subtype and we should use
3369 that GCC type for this one. The front end guarantees that
3370 the component list is shared. */
3371 if (Present (Cloned_Subtype (gnat_entity)))
3373 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3375 maybe_present = true;
3379 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3380 changing the type, make a new type with each field having the type of
3381 the field in the new subtype but the position computed by transforming
3382 every discriminant reference according to the constraints. We don't
3383 see any difference between private and non-private type here since
3384 derivations from types should have been deferred until the completion
3385 of the private type. */
3388 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3393 defer_incomplete_level++;
3394 this_deferred = true;
3398 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type));
3400 if (present_gnu_tree (gnat_entity))
3402 maybe_present = true;
3406 /* If this is a record subtype associated with a dispatch table,
3407 strip the suffix. This is necessary to make sure 2 different
3408 subtypes associated with the imported and exported views of a
3409 dispatch table are properly merged in LTO mode. */
3410 if (Is_Dispatch_Table_Entity (gnat_entity))
3413 Get_Encoded_Name (gnat_entity);
3414 p = strchr (Name_Buffer, '_');
3416 strcpy (p+2, "dtS");
3417 gnu_entity_name = get_identifier (Name_Buffer);
3420 /* When the subtype has discriminants and these discriminants affect
3421 the initial shape it has inherited, factor them in. But for an
3422 Unchecked_Union (it must be an Itype), just return the type.
3423 We can't just test Is_Constrained because private subtypes without
3424 discriminants of types with discriminants with default expressions
3425 are Is_Constrained but aren't constrained! */
3426 if (IN (Ekind (gnat_base_type), Record_Kind)
3427 && !Is_Unchecked_Union (gnat_base_type)
3428 && !Is_For_Access_Subtype (gnat_entity)
3429 && Has_Discriminants (gnat_entity)
3430 && Is_Constrained (gnat_entity)
3431 && Stored_Constraint (gnat_entity) != No_Elist)
3433 vec<subst_pair> gnu_subst_list
3434 = build_subst_list (gnat_entity, gnat_base_type, definition);
3435 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part;
3436 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3437 bool selected_variant = false, all_constant_pos = true;
3438 Entity_Id gnat_field;
3439 vec<variant_desc> gnu_variant_list;
3441 gnu_type = make_node (RECORD_TYPE);
3442 TYPE_NAME (gnu_type) = gnu_entity_name;
3443 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
3444 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_base_type);
3445 TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
3446 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3447 = Reverse_Storage_Order (gnat_entity);
3448 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3450 /* Set the size, alignment and alias set of the new type to
3451 match that of the old one, doing required substitutions. */
3452 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3455 if (TYPE_IS_PADDING_P (gnu_base_type))
3456 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3458 gnu_unpad_base_type = gnu_base_type;
3460 /* Look for REP and variant parts in the base type. */
3461 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3462 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3464 /* If there is a variant part, we must compute whether the
3465 constraints statically select a particular variant. If
3466 so, we simply drop the qualified union and flatten the
3467 list of fields. Otherwise we'll build a new qualified
3468 union for the variants that are still relevant. */
3469 if (gnu_variant_part)
3475 = build_variant_list (TREE_TYPE (gnu_variant_part),
3479 /* If all the qualifiers are unconditionally true, the
3480 innermost variant is statically selected. */
3481 selected_variant = true;
3482 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3483 if (!integer_onep (v->qual))
3485 selected_variant = false;
3489 /* Otherwise, create the new variants. */
3490 if (!selected_variant)
3491 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3493 tree old_variant = v->type;
3494 tree new_variant = make_node (RECORD_TYPE);
3496 = concat_name (DECL_NAME (gnu_variant_part),
3498 (DECL_NAME (v->field)));
3499 TYPE_NAME (new_variant)
3500 = concat_name (TYPE_NAME (gnu_type),
3501 IDENTIFIER_POINTER (suffix));
3502 TYPE_REVERSE_STORAGE_ORDER (new_variant)
3503 = TYPE_REVERSE_STORAGE_ORDER (gnu_type);
3504 copy_and_substitute_in_size (new_variant, old_variant,
3506 v->new_type = new_variant;
3511 gnu_variant_list.create (0);
3512 selected_variant = false;
3515 /* Make a list of fields and their position in the base type. */
3517 = build_position_list (gnu_unpad_base_type,
3518 gnu_variant_list.exists ()
3519 && !selected_variant,
3520 size_zero_node, bitsize_zero_node,
3521 BIGGEST_ALIGNMENT, NULL_TREE);
3523 /* Now go down every component in the subtype and compute its
3524 size and position from those of the component in the base
3525 type and from the constraints of the subtype. */
3526 for (gnat_field = First_Entity (gnat_entity);
3527 Present (gnat_field);
3528 gnat_field = Next_Entity (gnat_field))
3529 if ((Ekind (gnat_field) == E_Component
3530 || Ekind (gnat_field) == E_Discriminant)
3531 && !(Present (Corresponding_Discriminant (gnat_field))
3532 && Is_Tagged_Type (gnat_base_type))
3534 (Scope (Original_Record_Component (gnat_field)))
3537 Name_Id gnat_name = Chars (gnat_field);
3538 Entity_Id gnat_old_field
3539 = Original_Record_Component (gnat_field);
3541 = gnat_to_gnu_field_decl (gnat_old_field);
3542 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3543 tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
3544 tree gnu_cont_type, gnu_last = NULL_TREE;
3546 /* If the type is the same, retrieve the GCC type from the
3547 old field to take into account possible adjustments. */
3548 if (Etype (gnat_field) == Etype (gnat_old_field))
3549 gnu_field_type = TREE_TYPE (gnu_old_field);
3551 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3553 /* If there was a component clause, the field types must be
3554 the same for the type and subtype, so copy the data from
3555 the old field to avoid recomputation here. Also if the
3556 field is justified modular and the optimization in
3557 gnat_to_gnu_field was applied. */
3558 if (Present (Component_Clause (gnat_old_field))
3559 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3560 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3561 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3562 == TREE_TYPE (gnu_old_field)))
3564 gnu_size = DECL_SIZE (gnu_old_field);
3565 gnu_field_type = TREE_TYPE (gnu_old_field);
3568 /* If the old field was packed and of constant size, we
3569 have to get the old size here, as it might differ from
3570 what the Etype conveys and the latter might overlap
3571 onto the following field. Try to arrange the type for
3572 possible better packing along the way. */
3573 else if (DECL_PACKED (gnu_old_field)
3574 && TREE_CODE (DECL_SIZE (gnu_old_field))
3577 gnu_size = DECL_SIZE (gnu_old_field);
3578 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
3579 && !TYPE_FAT_POINTER_P (gnu_field_type)
3580 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
3582 = make_packable_type (gnu_field_type, true);
3586 gnu_size = TYPE_SIZE (gnu_field_type);
3588 /* If the context of the old field is the base type or its
3589 REP part (if any), put the field directly in the new
3590 type; otherwise look up the context in the variant list
3591 and put the field either in the new type if there is a
3592 selected variant or in one of the new variants. */
3593 if (gnu_context == gnu_unpad_base_type
3595 && gnu_context == TREE_TYPE (gnu_rep_part)))
3596 gnu_cont_type = gnu_type;
3603 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3604 if (gnu_context == v->type
3605 || ((rep_part = get_rep_part (v->type))
3606 && gnu_context == TREE_TYPE (rep_part)))
3610 if (selected_variant)
3611 gnu_cont_type = gnu_type;
3613 gnu_cont_type = v->new_type;
3616 /* The front-end may pass us "ghost" components if
3617 it fails to recognize that a constrained subtype
3618 is statically constrained. Discard them. */
3622 /* Now create the new field modeled on the old one. */
3624 = create_field_decl_from (gnu_old_field, gnu_field_type,
3625 gnu_cont_type, gnu_size,
3626 gnu_pos_list, gnu_subst_list);
3627 gnu_pos = DECL_FIELD_OFFSET (gnu_field);
3629 /* Put it in one of the new variants directly. */
3630 if (gnu_cont_type != gnu_type)
3632 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3633 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3636 /* To match the layout crafted in components_to_record,
3637 if this is the _Tag or _Parent field, put it before
3638 any other fields. */
3639 else if (gnat_name == Name_uTag
3640 || gnat_name == Name_uParent)
3641 gnu_field_list = chainon (gnu_field_list, gnu_field);
3643 /* Similarly, if this is the _Controller field, put
3644 it before the other fields except for the _Tag or
3646 else if (gnat_name == Name_uController && gnu_last)
3648 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3649 DECL_CHAIN (gnu_last) = gnu_field;
3652 /* Otherwise, if this is a regular field, put it after
3653 the other fields. */
3656 DECL_CHAIN (gnu_field) = gnu_field_list;
3657 gnu_field_list = gnu_field;
3659 gnu_last = gnu_field;
3660 if (TREE_CODE (gnu_pos) != INTEGER_CST)
3661 all_constant_pos = false;
3664 save_gnu_tree (gnat_field, gnu_field, false);
3667 /* If there is a variant list, a selected variant and the fields
3668 all have a constant position, put them in order of increasing
3669 position to match that of constant CONSTRUCTORs. Likewise if
3670 there is no variant list but a REP part, since the latter has
3671 been flattened in the process. */
3672 if (((gnu_variant_list.exists () && selected_variant)
3673 || (!gnu_variant_list.exists () && gnu_rep_part))
3674 && all_constant_pos)
3676 const int len = list_length (gnu_field_list);
3677 tree *field_arr = XALLOCAVEC (tree, len), t;
3680 for (t = gnu_field_list, i = 0; t; t = DECL_CHAIN (t), i++)
3683 qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
3685 gnu_field_list = NULL_TREE;
3686 for (i = 0; i < len; i++)
3688 DECL_CHAIN (field_arr[i]) = gnu_field_list;
3689 gnu_field_list = field_arr[i];
3693 /* If there is a variant list and no selected variant, we need
3694 to create the nest of variant parts from the old nest. */
3695 else if (gnu_variant_list.exists () && !selected_variant)
3697 tree new_variant_part
3698 = create_variant_part_from (gnu_variant_part,
3699 gnu_variant_list, gnu_type,
3700 gnu_pos_list, gnu_subst_list);
3701 DECL_CHAIN (new_variant_part) = gnu_field_list;
3702 gnu_field_list = new_variant_part;
3705 /* Now go through the entities again looking for Itypes that
3706 we have not elaborated but should (e.g., Etypes of fields
3707 that have Original_Components). */
3708 for (gnat_field = First_Entity (gnat_entity);
3709 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3710 if ((Ekind (gnat_field) == E_Discriminant
3711 || Ekind (gnat_field) == E_Component)
3712 && !present_gnu_tree (Etype (gnat_field)))
3713 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3715 /* Do not emit debug info for the type yet since we're going to
3717 finish_record_type (gnu_type, nreverse (gnu_field_list), 2,
3719 compute_record_mode (gnu_type);
3721 /* Fill in locations of fields. */
3722 annotate_rep (gnat_entity, gnu_type);
3724 /* If debugging information is being written for the type and if
3725 we are asked to output such encodings, write a record that
3726 shows what we are a subtype of and also make a variable that
3727 indicates our size, if still variable. */
3728 if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
3730 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3731 tree gnu_unpad_base_name
3732 = TYPE_IDENTIFIER (gnu_unpad_base_type);
3733 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3735 TYPE_NAME (gnu_subtype_marker)
3736 = create_concat_name (gnat_entity, "XVS");
3737 finish_record_type (gnu_subtype_marker,
3738 create_field_decl (gnu_unpad_base_name,
3739 build_reference_type
3740 (gnu_unpad_base_type),
3742 NULL_TREE, NULL_TREE,
3746 add_parallel_type (gnu_type, gnu_subtype_marker);
3749 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3750 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3751 TYPE_SIZE_UNIT (gnu_subtype_marker)
3752 = create_var_decl (create_concat_name (gnat_entity,
3754 NULL_TREE, sizetype, gnu_size_unit,
3755 false, false, false, false, false,
3760 gnu_variant_list.release ();
3761 gnu_subst_list.release ();
3763 /* Now we can finalize it. */
3764 rest_of_record_type_compilation (gnu_type);
3767 /* Otherwise, go down all the components in the new type and make
3768 them equivalent to those in the base type. */
3771 gnu_type = gnu_base_type;
3773 for (gnat_temp = First_Entity (gnat_entity);
3774 Present (gnat_temp);
3775 gnat_temp = Next_Entity (gnat_temp))
3776 if ((Ekind (gnat_temp) == E_Discriminant
3777 && !Is_Unchecked_Union (gnat_base_type))
3778 || Ekind (gnat_temp) == E_Component)
3779 save_gnu_tree (gnat_temp,
3780 gnat_to_gnu_field_decl
3781 (Original_Record_Component (gnat_temp)),
3787 case E_Access_Subprogram_Type:
3788 /* Use the special descriptor type for dispatch tables if needed,
3789 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3790 Note that we are only required to do so for static tables in
3791 order to be compatible with the C++ ABI, but Ada 2005 allows
3792 to extend library level tagged types at the local level so
3793 we do it in the non-static case as well. */
3794 if (TARGET_VTABLE_USES_DESCRIPTORS
3795 && Is_Dispatch_Table_Entity (gnat_entity))
3797 gnu_type = fdesc_type_node;
3798 gnu_size = TYPE_SIZE (gnu_type);
3802 /* ... fall through ... */
3804 case E_Anonymous_Access_Subprogram_Type:
3805 /* If we are not defining this entity, and we have incomplete
3806 entities being processed above us, make a dummy type and
3807 fill it in later. */
3808 if (!definition && defer_incomplete_level != 0)
3810 struct incomplete *p = XNEW (struct incomplete);
3813 = build_pointer_type
3814 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3815 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3816 artificial_p, debug_info_p,
3818 this_made_decl = true;
3819 gnu_type = TREE_TYPE (gnu_decl);
3820 save_gnu_tree (gnat_entity, gnu_decl, false);
3823 p->old_type = TREE_TYPE (gnu_type);
3824 p->full_type = Directly_Designated_Type (gnat_entity);
3825 p->next = defer_incomplete_list;
3826 defer_incomplete_list = p;
3830 /* ... fall through ... */
3832 case E_Allocator_Type:
3834 case E_Access_Attribute_Type:
3835 case E_Anonymous_Access_Type:
3836 case E_General_Access_Type:
3838 /* The designated type and its equivalent type for gigi. */
3839 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3840 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3841 /* Whether it comes from a limited with. */
3842 bool is_from_limited_with
3843 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3844 && From_Limited_With (gnat_desig_equiv));
3845 /* The "full view" of the designated type. If this is an incomplete
3846 entity from a limited with, treat its non-limited view as the full
3847 view. Otherwise, if this is an incomplete or private type, use the
3848 full view. In the former case, we might point to a private type,
3849 in which case, we need its full view. Also, we want to look at the
3850 actual type used for the representation, so this takes a total of
3852 Entity_Id gnat_desig_full_direct_first
3853 = (is_from_limited_with
3854 ? Non_Limited_View (gnat_desig_equiv)
3855 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3856 ? Full_View (gnat_desig_equiv) : Empty));
3857 Entity_Id gnat_desig_full_direct
3858 = ((is_from_limited_with
3859 && Present (gnat_desig_full_direct_first)
3860 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3861 ? Full_View (gnat_desig_full_direct_first)
3862 : gnat_desig_full_direct_first);
3863 Entity_Id gnat_desig_full
3864 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3865 /* The type actually used to represent the designated type, either
3866 gnat_desig_full or gnat_desig_equiv. */
3867 Entity_Id gnat_desig_rep;
3868 /* We want to know if we'll be seeing the freeze node for any
3869 incomplete type we may be pointing to. */
3871 = (Present (gnat_desig_full)
3872 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3873 : In_Extended_Main_Code_Unit (gnat_desig_type));
3874 /* True if we make a dummy type here. */
3875 bool made_dummy = false;
3876 /* The mode to be used for the pointer type. */
3877 machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3878 /* The GCC type used for the designated type. */
3879 tree gnu_desig_type = NULL_TREE;
3881 if (!targetm.valid_pointer_mode (p_mode))
3884 /* If either the designated type or its full view is an unconstrained
3885 array subtype, replace it with the type it's a subtype of. This
3886 avoids problems with multiple copies of unconstrained array types.
3887 Likewise, if the designated type is a subtype of an incomplete
3888 record type, use the parent type to avoid order of elaboration
3889 issues. This can lose some code efficiency, but there is no
3891 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3892 && !Is_Constrained (gnat_desig_equiv))
3893 gnat_desig_equiv = Etype (gnat_desig_equiv);
3894 if (Present (gnat_desig_full)
3895 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3896 && !Is_Constrained (gnat_desig_full))
3897 || (Ekind (gnat_desig_full) == E_Record_Subtype
3898 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3899 gnat_desig_full = Etype (gnat_desig_full);
3901 /* Set the type that's the representation of the designated type. */
3903 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3905 /* If we already know what the full type is, use it. */
3906 if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full))
3907 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3909 /* Get the type of the thing we are to point to and build a pointer to
3910 it. If it is a reference to an incomplete or private type with a
3911 full view that is a record or an array, make a dummy type node and
3912 get the actual type later when we have verified it is safe. */
3913 else if ((!in_main_unit
3914 && !present_gnu_tree (gnat_desig_equiv)
3915 && Present (gnat_desig_full)
3916 && (Is_Record_Type (gnat_desig_full)
3917 || Is_Array_Type (gnat_desig_full)))
3918 /* Likewise if we are pointing to a record or array and we are
3919 to defer elaborating incomplete types. We do this as this
3920 access type may be the full view of a private type. */
3921 || ((!in_main_unit || imported_p)
3922 && defer_incomplete_level != 0
3923 && !present_gnu_tree (gnat_desig_equiv)
3924 && (Is_Record_Type (gnat_desig_rep)
3925 || Is_Array_Type (gnat_desig_rep)))
3926 /* If this is a reference from a limited_with type back to our
3927 main unit and there's a freeze node for it, either we have
3928 already processed the declaration and made the dummy type,
3929 in which case we just reuse the latter, or we have not yet,
3930 in which case we make the dummy type and it will be reused
3931 when the declaration is finally processed. In both cases,
3932 the pointer eventually created below will be automatically
3933 adjusted when the freeze node is processed. */
3935 && is_from_limited_with
3936 && Present (Freeze_Node (gnat_desig_rep))))
3938 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3942 /* Otherwise handle the case of a pointer to itself. */
3943 else if (gnat_desig_equiv == gnat_entity)
3946 = build_pointer_type_for_mode (void_type_node, p_mode,
3947 No_Strict_Aliasing (gnat_entity));
3948 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3951 /* If expansion is disabled, the equivalent type of a concurrent type
3952 is absent, so build a dummy pointer type. */
3953 else if (type_annotate_only && No (gnat_desig_equiv))
3954 gnu_type = ptr_type_node;
3956 /* Finally, handle the default case where we can just elaborate our
3959 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3961 /* It is possible that a call to gnat_to_gnu_type above resolved our
3962 type. If so, just return it. */
3963 if (present_gnu_tree (gnat_entity))
3965 maybe_present = true;
3969 /* For an unconstrained array, make dummy fat & thin pointer types. */
3970 if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
3972 /* If the processing above got something that has a pointer, then
3973 we are done. This could have happened either because the type
3974 was elaborated or because somebody else executed the code. */
3975 if (!TYPE_POINTER_TO (gnu_desig_type))
3976 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3977 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3980 /* If we haven't done it yet, build the pointer type the usual way. */
3983 /* Modify the designated type if we are pointing only to constant
3984 objects, but don't do it for unconstrained arrays. */
3985 if (Is_Access_Constant (gnat_entity)
3986 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3989 = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
3991 /* Some extra processing is required if we are building a
3992 pointer to an incomplete type (in the GCC sense). We might
3993 have such a type if we just made a dummy, or directly out
3994 of the call to gnat_to_gnu_type above if we are processing
3995 an access type for a record component designating the
3996 record type itself. */
3997 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3999 /* We must ensure that the pointer to variant we make will
4000 be processed by update_pointer_to when the initial type
4001 is completed. Pretend we made a dummy and let further
4002 processing act as usual. */
4005 /* We must ensure that update_pointer_to will not retrieve
4006 the dummy variant when building a properly qualified
4007 version of the complete type. We take advantage of the
4008 fact that get_qualified_type is requiring TYPE_NAMEs to
4009 match to influence build_qualified_type and then also
4010 update_pointer_to here. */
4011 TYPE_NAME (gnu_desig_type)
4012 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
4017 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
4018 No_Strict_Aliasing (gnat_entity));
4021 /* If we are not defining this object and we have made a dummy pointer,
4022 save our current definition, evaluate the actual type, and replace
4023 the tentative type we made with the actual one. If we are to defer
4024 actually looking up the actual type, make an entry in the deferred
4025 list. If this is from a limited with, we may have to defer to the
4026 end of the current unit. */
4027 if ((!in_main_unit || is_from_limited_with) && made_dummy)
4029 tree gnu_old_desig_type;
4031 if (TYPE_IS_FAT_POINTER_P (gnu_type))
4033 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
4034 if (esize == POINTER_SIZE)
4035 gnu_type = build_pointer_type
4036 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
4039 gnu_old_desig_type = TREE_TYPE (gnu_type);
4041 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4042 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
4043 artificial_p, debug_info_p,
4045 this_made_decl = true;
4046 gnu_type = TREE_TYPE (gnu_decl);
4047 save_gnu_tree (gnat_entity, gnu_decl, false);
4050 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
4051 update gnu_old_desig_type directly, in which case it will not be
4052 a dummy type any more when we get into update_pointer_to.
4054 This can happen e.g. when the designated type is a record type,
4055 because their elaboration starts with an initial node from
4056 make_dummy_type, which may be the same node as the one we got.
4058 Besides, variants of this non-dummy type might have been created
4059 along the way. update_pointer_to is expected to properly take
4060 care of those situations. */
4061 if (defer_incomplete_level == 0 && !is_from_limited_with)
4063 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
4064 gnat_to_gnu_type (gnat_desig_equiv));
4068 struct incomplete *p = XNEW (struct incomplete);
4069 struct incomplete **head
4070 = (is_from_limited_with
4071 ? &defer_limited_with : &defer_incomplete_list);
4072 p->old_type = gnu_old_desig_type;
4073 p->full_type = gnat_desig_equiv;
4081 case E_Access_Protected_Subprogram_Type:
4082 case E_Anonymous_Access_Protected_Subprogram_Type:
4083 if (type_annotate_only && No (gnat_equiv_type))
4084 gnu_type = ptr_type_node;
4087 /* The run-time representation is the equivalent type. */
4088 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4089 maybe_present = true;
4092 if (Is_Itype (Directly_Designated_Type (gnat_entity))
4093 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
4094 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
4095 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
4096 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
4101 case E_Access_Subtype:
4103 /* We treat this as identical to its base type; any constraint is
4104 meaningful only to the front-end.
4106 The designated type must be elaborated as well, if it does
4107 not have its own freeze node. Designated (sub)types created
4108 for constrained components of records with discriminants are
4109 not frozen by the front-end and thus not elaborated by gigi,
4110 because their use may appear before the base type is frozen,
4111 and because it is not clear that they are needed anywhere in
4112 gigi. With the current model, there is no correct place where
4113 they could be elaborated. */
4115 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
4116 if (Is_Itype (Directly_Designated_Type (gnat_entity))
4117 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
4118 && Is_Frozen (Directly_Designated_Type (gnat_entity))
4119 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
4121 /* If we are not defining this entity, and we have incomplete
4122 entities being processed above us, make a dummy type and
4123 elaborate it later. */
4124 if (!definition && defer_incomplete_level != 0)
4126 struct incomplete *p = XNEW (struct incomplete);
4129 = make_dummy_type (Directly_Designated_Type (gnat_entity));
4130 p->full_type = Directly_Designated_Type (gnat_entity);
4131 p->next = defer_incomplete_list;
4132 defer_incomplete_list = p;
4134 else if (!IN (Ekind (Base_Type
4135 (Directly_Designated_Type (gnat_entity))),
4136 Incomplete_Or_Private_Kind))
4137 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
4141 maybe_present = true;
4144 /* Subprogram Entities
4146 The following access functions are defined for subprograms:
4148 Etype Return type or Standard_Void_Type.
4149 First_Formal The first formal parameter.
4150 Is_Imported Indicates that the subprogram has appeared in
4151 an INTERFACE or IMPORT pragma. For now we
4152 assume that the external language is C.
4153 Is_Exported Likewise but for an EXPORT pragma.
4154 Is_Inlined True if the subprogram is to be inlined.
4156 Each parameter is first checked by calling must_pass_by_ref on its
4157 type to determine if it is passed by reference. For parameters which
4158 are copied in, if they are Ada In Out or Out parameters, their return
4159 value becomes part of a record which becomes the return type of the
4160 function (C function - note that this applies only to Ada procedures
4161 so there is no Ada return type). Additional code to store back the
4162 parameters will be generated on the caller side. This transformation
4163 is done here, not in the front-end.
4165 The intended result of the transformation can be seen from the
4166 equivalent source rewritings that follow:
4168 struct temp {int a,b};
4169 procedure P (A,B: In Out ...) is temp P (int A,B)
4172 end P; return {A,B};
4179 For subprogram types we need to perform mainly the same conversions to
4180 GCC form that are needed for procedures and function declarations. The
4181 only difference is that at the end, we make a type declaration instead
4182 of a function declaration. */
4184 case E_Subprogram_Type:
4188 /* The type returned by a function or else Standard_Void_Type for a
4190 Entity_Id gnat_return_type = Etype (gnat_entity);
4191 tree gnu_return_type;
4192 /* The first GCC parameter declaration (a PARM_DECL node). The
4193 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
4194 actually is the head of this parameter list. */
4195 tree gnu_param_list = NULL_TREE;
4196 /* Non-null for subprograms containing parameters passed by copy-in
4197 copy-out (Ada In Out or Out parameters not passed by reference),
4198 in which case it is the list of nodes used to specify the values
4199 of the In Out/Out parameters that are returned as a record upon
4200 procedure return. The TREE_PURPOSE of an element of this list is
4201 a field of the record and the TREE_VALUE is the PARM_DECL
4202 corresponding to that field. This list will be saved in the
4203 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
4204 tree gnu_cico_list = NULL_TREE;
4205 /* List of fields in return type of procedure with copy-in copy-out
4207 tree gnu_field_list = NULL_TREE;
4208 /* If an import pragma asks to map this subprogram to a GCC builtin,
4209 this is the builtin DECL node. */
4210 tree gnu_builtin_decl = NULL_TREE;
4211 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
4212 Entity_Id gnat_param;
4213 enum inline_status_t inline_status
4214 = Has_Pragma_No_Inline (gnat_entity)
4216 : Has_Pragma_Inline_Always (gnat_entity)
4218 : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled);
4219 bool public_flag = Is_Public (gnat_entity) || imported_p;
4220 /* Subprograms marked both Intrinsic and Always_Inline need not
4221 have a body of their own. */
4223 = ((Is_Public (gnat_entity) && !definition)
4225 || (Convention (gnat_entity) == Convention_Intrinsic
4226 && Has_Pragma_Inline_Always (gnat_entity)));
4227 /* The semantics of "pure" in Ada essentially matches that of "const"
4228 in the back-end. In particular, both properties are orthogonal to
4229 the "nothrow" property if the EH circuitry is explicit in the
4230 internal representation of the back-end. If we are to completely
4231 hide the EH circuitry from it, we need to declare that calls to pure
4232 Ada subprograms that can throw have side effects since they can
4233 trigger an "abnormal" transfer of control flow; thus they can be
4234 neither "const" nor "pure" in the back-end sense. */
4235 bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_entity));
4236 bool volatile_flag = No_Return (gnat_entity);
4237 bool return_by_direct_ref_p = false;
4238 bool return_by_invisi_ref_p = false;
4239 bool return_unconstrained_p = false;
4242 /* A parameter may refer to this type, so defer completion of any
4243 incomplete types. */
4244 if (kind == E_Subprogram_Type && !definition)
4246 defer_incomplete_level++;
4247 this_deferred = true;
4250 /* If the subprogram has an alias, it is probably inherited, so
4251 we can use the original one. If the original "subprogram"
4252 is actually an enumeration literal, it may be the first use
4253 of its type, so we must elaborate that type now. */
4254 if (Present (Alias (gnat_entity)))
4256 const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
4258 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
4259 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
4261 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
4263 /* Elaborate any Itypes in the parameters of this entity. */
4264 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
4265 Present (gnat_temp);
4266 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4267 if (Is_Itype (Etype (gnat_temp)))
4268 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
4270 /* Materialize renamed subprograms in the debugging information
4271 when the renamed object is compile time known. We can consider
4272 such renamings as imported declarations.
4274 Because the parameters in generics instantiation are generally
4275 materialized as renamings, we ofter end up having both the
4276 renamed subprogram and the renaming in the same context and with
4277 the same name: in this case, renaming is both useless debug-wise
4278 and potentially harmful as name resolution in the debugger could
4279 return twice the same entity! So avoid this case. */
4280 if (debug_info_p && !artificial_p
4281 && !(get_debug_scope (gnat_entity, NULL)
4282 == get_debug_scope (gnat_renamed, NULL)
4283 && Name_Equals (Chars (gnat_entity),
4284 Chars (gnat_renamed)))
4285 && Present (gnat_renamed)
4286 && (Ekind (gnat_renamed) == E_Function
4287 || Ekind (gnat_renamed) == E_Procedure)
4289 && TREE_CODE (gnu_decl) == FUNCTION_DECL)
4291 tree decl = build_decl (input_location, IMPORTED_DECL,
4292 gnu_entity_name, void_type_node);
4293 IMPORTED_DECL_ASSOCIATED_DECL (decl) = gnu_decl;
4294 gnat_pushdecl (decl, gnat_entity);
4300 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4301 corresponding DECL node. Proper generation of calls later on need
4302 proper parameter associations so we don't "break;" here. */
4303 if (Convention (gnat_entity) == Convention_Intrinsic
4304 && Present (Interface_Name (gnat_entity)))
4306 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
4308 /* Inability to find the builtin decl most often indicates a
4309 genuine mistake, but imports of unregistered intrinsics are
4310 sometimes issued on purpose to allow hooking in alternate
4311 bodies. We post a warning conditioned on Wshadow in this case,
4312 to let developers be notified on demand without risking false
4313 positives with common default sets of options. */
4315 if (!gnu_builtin_decl && warn_shadow)
4316 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4319 /* ??? What if we don't find the builtin node above ? warn ? err ?
4320 In the current state we neither warn nor err, and calls will just
4321 be handled as for regular subprograms. */
4323 /* Look into the return type and get its associated GCC tree. If it
4324 is not void, compute various flags for the subprogram type. */
4325 if (Ekind (gnat_return_type) == E_Void)
4326 gnu_return_type = void_type_node;
4329 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4330 context may now appear in parameter and result profiles. If
4331 we are only annotating types, break circularities here. */
4332 if (type_annotate_only
4333 && is_from_limited_with_of_main (gnat_return_type))
4334 gnu_return_type = void_type_node;
4336 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4338 /* If this function returns by reference, make the actual return
4339 type the pointer type and make a note of that. */
4340 if (Returns_By_Ref (gnat_entity))
4342 gnu_return_type = build_reference_type (gnu_return_type);
4343 return_by_direct_ref_p = true;
4346 /* If the return type is an unconstrained array type, the return
4347 value will be allocated on the secondary stack so the actual
4348 return type is the fat pointer type. */
4349 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4351 gnu_return_type = TREE_TYPE (gnu_return_type);
4352 return_unconstrained_p = true;
4355 /* Likewise, if the return type requires a transient scope, the
4356 return value will also be allocated on the secondary stack so
4357 the actual return type is the pointer type. */
4358 else if (Requires_Transient_Scope (gnat_return_type))
4360 gnu_return_type = build_reference_type (gnu_return_type);
4361 return_unconstrained_p = true;
4364 /* If the Mechanism is By_Reference, ensure this function uses the
4365 target's by-invisible-reference mechanism, which may not be the
4366 same as above (e.g. it might be passing an extra parameter). */
4367 else if (kind == E_Function
4368 && Mechanism (gnat_entity) == By_Reference)
4369 return_by_invisi_ref_p = true;
4371 /* Likewise, if the return type is itself By_Reference. */
4372 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
4373 return_by_invisi_ref_p = true;
4375 /* If the type is a padded type and the underlying type would not
4376 be passed by reference or the function has a foreign convention,
4377 return the underlying type. */
4378 else if (TYPE_IS_PADDING_P (gnu_return_type)
4379 && (!default_pass_by_ref
4380 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4381 || Has_Foreign_Convention (gnat_entity)))
4382 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4384 /* If the return type is unconstrained, that means it must have a
4385 maximum size. Use the padded type as the effective return type.
4386 And ensure the function uses the target's by-invisible-reference
4387 mechanism to avoid copying too much data when it returns. */
4388 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4390 tree orig_type = gnu_return_type;
4391 tree max_return_size
4392 = max_size (TYPE_SIZE (gnu_return_type), true);
4394 /* If the size overflows to 0, set it to an arbitrary positive
4395 value so that assignments in the type are preserved. Their
4396 actual size is independent of this positive value. */
4397 if (TREE_CODE (max_return_size) == INTEGER_CST
4398 && TREE_OVERFLOW (max_return_size)
4399 && integer_zerop (max_return_size))
4401 max_return_size = copy_node (bitsize_unit_node);
4402 TREE_OVERFLOW (max_return_size) = 1;
4406 = maybe_pad_type (gnu_return_type, max_return_size, 0,
4407 gnat_entity, false, false, definition,
4410 /* Declare it now since it will never be declared otherwise.
4411 This is necessary to ensure that its subtrees are properly
4413 if (gnu_return_type != orig_type
4414 && !DECL_P (TYPE_NAME (gnu_return_type)))
4415 create_type_decl (TYPE_NAME (gnu_return_type),
4416 gnu_return_type, true, debug_info_p,
4419 return_by_invisi_ref_p = true;
4422 /* If the return type has a size that overflows, we cannot have
4423 a function that returns that type. This usage doesn't make
4424 sense anyway, so give an error here. */
4425 if (!return_by_invisi_ref_p
4426 && TYPE_SIZE_UNIT (gnu_return_type)
4427 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
4428 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
4430 post_error ("cannot return type whose size overflows",
4432 gnu_return_type = copy_node (gnu_return_type);
4433 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4434 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4435 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4436 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4440 /* Loop over the parameters and get their associated GCC tree. While
4441 doing this, build a copy-in copy-out structure if we need one. */
4442 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4443 Present (gnat_param);
4444 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4446 Entity_Id gnat_param_type = Etype (gnat_param);
4447 tree gnu_param_name = get_entity_name (gnat_param);
4448 tree gnu_param_type, gnu_param, gnu_field;
4449 Mechanism_Type mech = Mechanism (gnat_param);
4450 bool copy_in_copy_out = false, fake_param_type;
4452 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4453 context may now appear in parameter and result profiles. If
4454 we are only annotating types, break circularities here. */
4455 if (type_annotate_only
4456 && is_from_limited_with_of_main (gnat_param_type))
4458 gnu_param_type = void_type_node;
4459 fake_param_type = true;
4463 gnu_param_type = gnat_to_gnu_type (gnat_param_type);
4464 fake_param_type = false;
4467 /* Builtins are expanded inline and there is no real call sequence
4468 involved. So the type expected by the underlying expander is
4469 always the type of each argument "as is". */
4470 if (gnu_builtin_decl)
4472 /* Handle the first parameter of a valued procedure specially. */
4473 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4474 mech = By_Copy_Return;
4475 /* Otherwise, see if a Mechanism was supplied that forced this
4476 parameter to be passed one way or another. */
4477 else if (mech == Default
4479 || mech == By_Reference)
4483 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4484 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4485 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4487 mech = By_Reference;
4493 post_error ("unsupported mechanism for&", gnat_param);
4497 /* Do not call gnat_to_gnu_param for a fake parameter type since
4498 it will try to use the real type again. */
4499 if (fake_param_type)
4501 if (Ekind (gnat_param) == E_Out_Parameter)
4502 gnu_param = NULL_TREE;
4506 = create_param_decl (gnu_param_name, gnu_param_type,
4508 Set_Mechanism (gnat_param,
4509 mech == Default ? By_Copy : mech);
4510 if (Ekind (gnat_param) == E_In_Out_Parameter)
4511 copy_in_copy_out = true;
4516 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4517 Has_Foreign_Convention (gnat_entity),
4520 /* We are returned either a PARM_DECL or a type if no parameter
4521 needs to be passed; in either case, adjust the type. */
4522 if (DECL_P (gnu_param))
4523 gnu_param_type = TREE_TYPE (gnu_param);
4526 gnu_param_type = gnu_param;
4527 gnu_param = NULL_TREE;
4530 /* The failure of this assertion will very likely come from an
4531 order of elaboration issue for the type of the parameter. */
4532 gcc_assert (kind == E_Subprogram_Type
4533 || !TYPE_IS_DUMMY_P (gnu_param_type)
4534 || type_annotate_only);
4538 gnu_param_list = chainon (gnu_param, gnu_param_list);
4539 Sloc_to_locus (Sloc (gnat_param),
4540 &DECL_SOURCE_LOCATION (gnu_param));
4541 save_gnu_tree (gnat_param, gnu_param, false);
4543 /* If a parameter is a pointer, this function may modify
4544 memory through it and thus shouldn't be considered
4545 a const function. Also, the memory may be modified
4546 between two calls, so they can't be CSE'ed. The latter
4547 case also handles by-ref parameters. */
4548 if (POINTER_TYPE_P (gnu_param_type)
4549 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4553 if (copy_in_copy_out)
4557 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4559 /* If this is a function, we also need a field for the
4560 return value to be placed. */
4561 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4564 = create_field_decl (get_identifier ("RETVAL"),
4566 gnu_new_ret_type, NULL_TREE,
4568 Sloc_to_locus (Sloc (gnat_entity),
4569 &DECL_SOURCE_LOCATION (gnu_field));
4570 gnu_field_list = gnu_field;
4572 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4575 gnu_return_type = gnu_new_ret_type;
4576 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4577 /* Set a default alignment to speed up accesses. But we
4578 shouldn't increase the size of the structure too much,
4579 lest it doesn't fit in return registers anymore. */
4580 SET_TYPE_ALIGN (gnu_return_type,
4581 get_mode_alignment (ptr_mode));
4585 = create_field_decl (gnu_param_name, gnu_param_type,
4586 gnu_return_type, NULL_TREE, NULL_TREE,
4588 Sloc_to_locus (Sloc (gnat_param),
4589 &DECL_SOURCE_LOCATION (gnu_field));
4590 DECL_CHAIN (gnu_field) = gnu_field_list;
4591 gnu_field_list = gnu_field;
4593 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4599 /* If we have a CICO list but it has only one entry, we convert
4600 this function into a function that returns this object. */
4601 if (list_length (gnu_cico_list) == 1)
4602 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4604 /* Do not finalize the return type if the subprogram is stubbed
4605 since structures are incomplete for the back-end. */
4606 else if (Convention (gnat_entity) != Convention_Stubbed)
4608 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4611 /* Try to promote the mode of the return type if it is passed
4612 in registers, again to speed up accesses. */
4613 if (TYPE_MODE (gnu_return_type) == BLKmode
4614 && !targetm.calls.return_in_memory (gnu_return_type,
4618 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4619 unsigned int i = BITS_PER_UNIT;
4624 mode = mode_for_size (i, MODE_INT, 0);
4625 if (mode != BLKmode)
4627 SET_TYPE_MODE (gnu_return_type, mode);
4628 SET_TYPE_ALIGN (gnu_return_type,
4629 GET_MODE_ALIGNMENT (mode));
4630 TYPE_SIZE (gnu_return_type)
4631 = bitsize_int (GET_MODE_BITSIZE (mode));
4632 TYPE_SIZE_UNIT (gnu_return_type)
4633 = size_int (GET_MODE_SIZE (mode));
4638 rest_of_record_type_compilation (gnu_return_type);
4642 /* Deal with platform-specific calling conventions. */
4643 if (Has_Stdcall_Convention (gnat_entity))
4644 prepend_one_attribute
4645 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4646 get_identifier ("stdcall"), NULL_TREE,
4648 else if (Has_Thiscall_Convention (gnat_entity))
4649 prepend_one_attribute
4650 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4651 get_identifier ("thiscall"), NULL_TREE,
4654 /* If we should request stack realignment for a foreign convention
4655 subprogram, do so. Note that this applies to task entry points
4657 if (FOREIGN_FORCE_REALIGN_STACK
4658 && Has_Foreign_Convention (gnat_entity))
4659 prepend_one_attribute
4660 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4661 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4664 /* Deal with a pragma Linker_Section on a subprogram. */
4665 if ((kind == E_Function || kind == E_Procedure)
4666 && Present (Linker_Section_Pragma (gnat_entity)))
4667 prepend_one_attribute_pragma (&attr_list,
4668 Linker_Section_Pragma (gnat_entity));
4670 /* The lists have been built in reverse. */
4671 gnu_param_list = nreverse (gnu_param_list);
4672 gnu_cico_list = nreverse (gnu_cico_list);
4674 if (kind == E_Function)
4675 Set_Mechanism (gnat_entity, return_unconstrained_p
4676 || return_by_direct_ref_p
4677 || return_by_invisi_ref_p
4678 ? By_Reference : By_Copy);
4680 = create_subprog_type (gnu_return_type, gnu_param_list,
4681 gnu_cico_list, return_unconstrained_p,
4682 return_by_direct_ref_p,
4683 return_by_invisi_ref_p);
4685 /* A procedure (something that doesn't return anything) shouldn't be
4686 considered const since there would be no reason for calling such a
4687 subprogram. Note that procedures with Out (or In Out) parameters
4688 have already been converted into a function with a return type.
4689 Similarly, if the function returns an unconstrained type, then the
4690 function will allocate the return value on the secondary stack and
4691 thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
4692 if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
4695 /* If we have a builtin decl for that function, use it. Check if the
4696 profiles are compatible and warn if they are not. The checker is
4697 expected to post extra diagnostics in this case. */
4698 if (gnu_builtin_decl)
4700 intrin_binding_t inb;
4702 inb.gnat_entity = gnat_entity;
4703 inb.ada_fntype = gnu_type;
4704 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4706 if (!intrin_profiles_compatible_p (&inb))
4708 ("?profile of& doesn''t match the builtin it binds!",
4711 gnu_decl = gnu_builtin_decl;
4712 gnu_type = TREE_TYPE (gnu_builtin_decl);
4716 /* If there was no specified Interface_Name and the external and
4717 internal names of the subprogram are the same, only use the
4718 internal name to allow disambiguation of nested subprograms. */
4719 if (No (Interface_Name (gnat_entity))
4720 && gnu_ext_name == gnu_entity_name)
4721 gnu_ext_name = NULL_TREE;
4723 /* If we are defining the subprogram and it has an Address clause
4724 we must get the address expression from the saved GCC tree for the
4725 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4726 the address expression here since the front-end has guaranteed
4727 in that case that the elaboration has no effects. If there is
4728 an Address clause and we are not defining the object, just
4729 make it a constant. */
4730 if (Present (Address_Clause (gnat_entity)))
4732 tree gnu_address = NULL_TREE;
4736 = (present_gnu_tree (gnat_entity)
4737 ? get_gnu_tree (gnat_entity)
4738 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4740 save_gnu_tree (gnat_entity, NULL_TREE, false);
4742 /* Convert the type of the object to a reference type that can
4743 alias everything as per RM 13.3(19). */
4745 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4747 gnu_address = convert (gnu_type, gnu_address);
4750 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4751 gnu_address, false, Is_Public (gnat_entity),
4752 extern_flag, false, false, artificial_p,
4753 debug_info_p, NULL, gnat_entity);
4754 DECL_BY_REF_P (gnu_decl) = 1;
4757 else if (kind == E_Subprogram_Type)
4759 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4761 if (const_flag || volatile_flag)
4764 = (const_flag ? TYPE_QUAL_CONST : 0)
4765 | (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
4766 gnu_type = change_qualified_type (gnu_type, quals);
4770 = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4771 debug_info_p, gnat_entity);
4776 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4777 gnu_param_list, inline_status, const_flag,
4778 public_flag, extern_flag, volatile_flag,
4779 artificial_p, debug_info_p,
4780 attr_list, gnat_entity);
4781 /* This is unrelated to the stub built right above. */
4782 DECL_STUBBED_P (gnu_decl)
4783 = Convention (gnat_entity) == Convention_Stubbed;
4788 case E_Incomplete_Type:
4789 case E_Incomplete_Subtype:
4790 case E_Private_Type:
4791 case E_Private_Subtype:
4792 case E_Limited_Private_Type:
4793 case E_Limited_Private_Subtype:
4794 case E_Record_Type_With_Private:
4795 case E_Record_Subtype_With_Private:
4797 bool is_from_limited_with
4798 = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
4799 /* Get the "full view" of this entity. If this is an incomplete
4800 entity from a limited with, treat its non-limited view as the
4801 full view. Otherwise, use either the full view or the underlying
4802 full view, whichever is present. This is used in all the tests
4805 = is_from_limited_with
4806 ? Non_Limited_View (gnat_entity)
4807 : Present (Full_View (gnat_entity))
4808 ? Full_View (gnat_entity)
4809 : IN (kind, Private_Kind)
4810 ? Underlying_Full_View (gnat_entity)
4813 /* If this is an incomplete type with no full view, it must be a Taft
4814 Amendment type, in which case we return a dummy type. Otherwise,
4815 just get the type from its Etype. */
4818 if (kind == E_Incomplete_Type)
4820 gnu_type = make_dummy_type (gnat_entity);
4821 gnu_decl = TYPE_STUB_DECL (gnu_type);
4825 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4827 maybe_present = true;
4832 /* If we already made a type for the full view, reuse it. */
4833 else if (present_gnu_tree (full_view))
4835 gnu_decl = get_gnu_tree (full_view);
4839 /* Otherwise, if we are not defining the type now, get the type
4840 from the full view. But always get the type from the full view
4841 for define on use types, since otherwise we won't see them.
4842 Likewise if this is a non-limited view not declared in the main
4843 unit, which can happen for incomplete formal types instantiated
4844 on a type coming from a limited_with clause. */
4845 else if (!definition
4846 || (Is_Itype (full_view) && No (Freeze_Node (gnat_entity)))
4847 || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view)))
4848 || (is_from_limited_with
4849 && !In_Extended_Main_Code_Unit (full_view)))
4851 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4852 maybe_present = true;
4856 /* For incomplete types, make a dummy type entry which will be
4857 replaced later. Save it as the full declaration's type so
4858 we can do any needed updates when we see it. */
4859 gnu_type = make_dummy_type (gnat_entity);
4860 gnu_decl = TYPE_STUB_DECL (gnu_type);
4861 if (Has_Completion_In_Body (gnat_entity))
4862 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4863 save_gnu_tree (full_view, gnu_decl, 0);
4867 case E_Class_Wide_Type:
4868 /* Class-wide types are always transformed into their root type. */
4869 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4870 maybe_present = true;
4873 case E_Protected_Type:
4874 case E_Protected_Subtype:
4876 case E_Task_Subtype:
4877 /* If we are just annotating types and have no equivalent record type,
4878 just return void_type, except for root types that have discriminants
4879 because the discriminants will very likely be used in the declarative
4880 part of the associated body so they need to be translated. */
4881 if (type_annotate_only && No (gnat_equiv_type))
4883 if (Has_Discriminants (gnat_entity)
4884 && Root_Type (gnat_entity) == gnat_entity)
4886 tree gnu_field_list = NULL_TREE;
4887 Entity_Id gnat_field;
4889 /* This is a minimal version of the E_Record_Type handling. */
4890 gnu_type = make_node (RECORD_TYPE);
4891 TYPE_NAME (gnu_type) = gnu_entity_name;
4893 for (gnat_field = First_Stored_Discriminant (gnat_entity);
4894 Present (gnat_field);
4895 gnat_field = Next_Stored_Discriminant (gnat_field))
4898 = gnat_to_gnu_field (gnat_field, gnu_type, false,
4899 definition, debug_info_p);
4901 save_gnu_tree (gnat_field,
4902 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
4903 build0 (PLACEHOLDER_EXPR, gnu_type),
4904 gnu_field, NULL_TREE),
4907 DECL_CHAIN (gnu_field) = gnu_field_list;
4908 gnu_field_list = gnu_field;
4911 finish_record_type (gnu_type, nreverse (gnu_field_list), 0,
4915 gnu_type = void_type_node;
4918 /* Concurrent types are always transformed into their record type. */
4920 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4921 maybe_present = true;
4925 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4930 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4931 we've already saved it, so we don't try to. */
4932 gnu_decl = error_mark_node;
4936 case E_Abstract_State:
4937 /* This is a SPARK annotation that only reaches here when compiling in
4939 gcc_assert (type_annotate_only);
4940 gnu_decl = error_mark_node;
4948 /* If we had a case where we evaluated another type and it might have
4949 defined this one, handle it here. */
4950 if (maybe_present && present_gnu_tree (gnat_entity))
4952 gnu_decl = get_gnu_tree (gnat_entity);
4956 /* If we are processing a type and there is either no decl for it or
4957 we just made one, do some common processing for the type, such as
4958 handling alignment and possible padding. */
4959 if (is_type && (!gnu_decl || this_made_decl))
4961 /* Process the attributes, if not already done. Note that the type is
4962 already defined so we cannot pass true for IN_PLACE here. */
4963 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4965 /* Tell the middle-end that objects of tagged types are guaranteed to
4966 be properly aligned. This is necessary because conversions to the
4967 class-wide type are translated into conversions to the root type,
4968 which can be less aligned than some of its derived types. */
4969 if (Is_Tagged_Type (gnat_entity)
4970 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4971 TYPE_ALIGN_OK (gnu_type) = 1;
4973 /* Record whether the type is passed by reference. */
4974 if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4975 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4977 /* ??? Don't set the size for a String_Literal since it is either
4978 confirming or we don't handle it properly (if the low bound is
4980 if (!gnu_size && kind != E_String_Literal_Subtype)
4982 Uint gnat_size = Known_Esize (gnat_entity)
4983 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4985 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4986 false, Has_Size_Clause (gnat_entity));
4989 /* If a size was specified, see if we can make a new type of that size
4990 by rearranging the type, for example from a fat to a thin pointer. */
4994 = make_type_from_size (gnu_type, gnu_size,
4995 Has_Biased_Representation (gnat_entity));
4997 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4998 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4999 gnu_size = NULL_TREE;
5002 /* If the alignment has not already been processed and this is not
5003 an unconstrained array type, see if an alignment is specified.
5004 If not, we pick a default alignment for atomic objects. */
5005 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
5007 else if (Known_Alignment (gnat_entity))
5009 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
5010 TYPE_ALIGN (gnu_type));
5012 /* Warn on suspiciously large alignments. This should catch
5013 errors about the (alignment,byte)/(size,bit) discrepancy. */
5014 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
5018 /* If a size was specified, take it into account. Otherwise
5019 use the RM size for records or unions as the type size has
5020 already been adjusted to the alignment. */
5023 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
5024 && !TYPE_FAT_POINTER_P (gnu_type))
5025 size = rm_size (gnu_type);
5027 size = TYPE_SIZE (gnu_type);
5029 /* Consider an alignment as suspicious if the alignment/size
5030 ratio is greater or equal to the byte/bit ratio. */
5031 if (tree_fits_uhwi_p (size)
5032 && align >= tree_to_uhwi (size) * BITS_PER_UNIT)
5033 post_error_ne ("?suspiciously large alignment specified for&",
5034 Expression (Alignment_Clause (gnat_entity)),
5038 else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size
5039 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
5040 && integer_pow2p (TYPE_SIZE (gnu_type)))
5041 align = MIN (BIGGEST_ALIGNMENT,
5042 tree_to_uhwi (TYPE_SIZE (gnu_type)));
5043 else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size
5044 && tree_fits_uhwi_p (gnu_size)
5045 && integer_pow2p (gnu_size))
5046 align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
5048 /* See if we need to pad the type. If we did, and made a record,
5049 the name of the new type may be changed. So get it back for
5050 us when we make the new TYPE_DECL below. */
5051 if (gnu_size || align > 0)
5052 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
5053 false, !gnu_decl, definition, false);
5055 if (TYPE_IS_PADDING_P (gnu_type))
5056 gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
5058 /* Now set the RM size of the type. We cannot do it before padding
5059 because we need to accept arbitrary RM sizes on integral types. */
5060 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
5062 /* If we are at global level, GCC will have applied variable_size to
5063 the type, but that won't have done anything. So, if it's not
5064 a constant or self-referential, call elaborate_expression_1 to
5065 make a variable for the size rather than calculating it each time.
5066 Handle both the RM size and the actual size. */
5067 if (global_bindings_p ()
5068 && TYPE_SIZE (gnu_type)
5069 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
5070 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5072 tree size = TYPE_SIZE (gnu_type);
5074 TYPE_SIZE (gnu_type)
5075 = elaborate_expression_1 (size, gnat_entity, "SIZE", definition,
5078 /* ??? For now, store the size as a multiple of the alignment in
5079 bytes so that we can see the alignment from the tree. */
5080 TYPE_SIZE_UNIT (gnu_type)
5081 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
5082 "SIZE_A_UNIT", definition, false,
5083 TYPE_ALIGN (gnu_type));
5085 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
5086 may not be marked by the call to create_type_decl below. */
5087 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
5089 if (TREE_CODE (gnu_type) == RECORD_TYPE)
5091 tree variant_part = get_variant_part (gnu_type);
5092 tree ada_size = TYPE_ADA_SIZE (gnu_type);
5096 tree union_type = TREE_TYPE (variant_part);
5097 tree offset = DECL_FIELD_OFFSET (variant_part);
5099 /* If the position of the variant part is constant, subtract
5100 it from the size of the type of the parent to get the new
5101 size. This manual CSE reduces the data size. */
5102 if (TREE_CODE (offset) == INTEGER_CST)
5104 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
5105 TYPE_SIZE (union_type)
5106 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
5107 bit_from_pos (offset, bitpos));
5108 TYPE_SIZE_UNIT (union_type)
5109 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
5110 byte_from_pos (offset, bitpos));
5114 TYPE_SIZE (union_type)
5115 = elaborate_expression_1 (TYPE_SIZE (union_type),
5116 gnat_entity, "VSIZE",
5119 /* ??? For now, store the size as a multiple of the
5120 alignment in bytes so that we can see the alignment
5122 TYPE_SIZE_UNIT (union_type)
5123 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
5124 gnat_entity, "VSIZE_A_UNIT",
5126 TYPE_ALIGN (union_type));
5128 /* ??? For now, store the offset as a multiple of the
5129 alignment in bytes so that we can see the alignment
5131 DECL_FIELD_OFFSET (variant_part)
5132 = elaborate_expression_2 (offset, gnat_entity,
5133 "VOFFSET", definition, false,
5138 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
5139 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
5142 if (operand_equal_p (ada_size, size, 0))
5143 ada_size = TYPE_SIZE (gnu_type);
5146 = elaborate_expression_1 (ada_size, gnat_entity, "RM_SIZE",
5148 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
5152 /* If this is a record type or subtype, call elaborate_expression_2 on
5153 any field position. Do this for both global and local types.
5154 Skip any fields that we haven't made trees for to avoid problems with
5155 class wide types. */
5156 if (IN (kind, Record_Kind))
5157 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
5158 gnat_temp = Next_Entity (gnat_temp))
5159 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
5161 tree gnu_field = get_gnu_tree (gnat_temp);
5163 /* ??? For now, store the offset as a multiple of the alignment
5164 in bytes so that we can see the alignment from the tree. */
5165 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
5167 DECL_FIELD_OFFSET (gnu_field)
5168 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
5169 gnat_temp, "OFFSET", definition,
5171 DECL_OFFSET_ALIGN (gnu_field));
5173 /* ??? The context of gnu_field is not necessarily gnu_type
5174 so the MULT_EXPR node built above may not be marked by
5175 the call to create_type_decl below. */
5176 if (global_bindings_p ())
5177 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
5181 if (Is_Atomic_Or_VFA (gnat_entity))
5182 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
5184 /* If this is not an unconstrained array type, set some flags. */
5185 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5187 if (Present (Alignment_Clause (gnat_entity)))
5188 TYPE_USER_ALIGN (gnu_type) = 1;
5190 if (Universal_Aliasing (gnat_entity))
5191 TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
5193 /* If it is passed by reference, force BLKmode to ensure that
5194 objects of this type will always be put in memory. */
5195 if (TYPE_MODE (gnu_type) != BLKmode
5196 && AGGREGATE_TYPE_P (gnu_type)
5197 && TYPE_BY_REFERENCE_P (gnu_type))
5198 SET_TYPE_MODE (gnu_type, BLKmode);
5200 if (Treat_As_Volatile (gnat_entity))
5203 = TYPE_QUAL_VOLATILE
5204 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
5205 gnu_type = change_qualified_type (gnu_type, quals);
5210 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
5211 artificial_p, debug_info_p,
5215 TREE_TYPE (gnu_decl) = gnu_type;
5216 TYPE_STUB_DECL (gnu_type) = gnu_decl;
5220 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
5222 gnu_type = TREE_TYPE (gnu_decl);
5224 /* If this is a derived type, relate its alias set to that of its parent
5225 to avoid troubles when a call to an inherited primitive is inlined in
5226 a context where a derived object is accessed. The inlined code works
5227 on the parent view so the resulting code may access the same object
5228 using both the parent and the derived alias sets, which thus have to
5229 conflict. As the same issue arises with component references, the
5230 parent alias set also has to conflict with composite types enclosing
5231 derived components. For instance, if we have:
5238 we want T to conflict with both D and R, in addition to R being a
5239 superset of D by record/component construction.
5241 One way to achieve this is to perform an alias set copy from the
5242 parent to the derived type. This is not quite appropriate, though,
5243 as we don't want separate derived types to conflict with each other:
5245 type I1 is new Integer;
5246 type I2 is new Integer;
5248 We want I1 and I2 to both conflict with Integer but we do not want
5249 I1 to conflict with I2, and an alias set copy on derivation would
5252 The option chosen is to make the alias set of the derived type a
5253 superset of that of its parent type. It trivially fulfills the
5254 simple requirement for the Integer derivation example above, and
5255 the component case as well by superset transitivity:
5258 R ----------> D ----------> T
5260 However, for composite types, conversions between derived types are
5261 translated into VIEW_CONVERT_EXPRs so a sequence like:
5263 type Comp1 is new Comp;
5264 type Comp2 is new Comp;
5265 procedure Proc (C : Comp1);
5273 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
5275 and gimplified into:
5282 i.e. generates code involving type punning. Therefore, Comp1 needs
5283 to conflict with Comp2 and an alias set copy is required.
5285 The language rules ensure the parent type is already frozen here. */
5286 if (kind != E_Subprogram_Type
5287 && Is_Derived_Type (gnat_entity)
5288 && !type_annotate_only)
5290 Entity_Id gnat_parent_type = Underlying_Type (Etype (gnat_entity));
5291 /* For constrained packed array subtypes, the implementation type is
5292 used instead of the nominal type. */
5293 if (kind == E_Array_Subtype
5294 && Is_Constrained (gnat_entity)
5295 && Present (Packed_Array_Impl_Type (gnat_parent_type)))
5296 gnat_parent_type = Packed_Array_Impl_Type (gnat_parent_type);
5297 relate_alias_sets (gnu_type, gnat_to_gnu_type (gnat_parent_type),
5298 Is_Composite_Type (gnat_entity)
5299 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
5302 /* Back-annotate the Alignment of the type if not already in the
5303 tree. Likewise for sizes. */
5304 if (Unknown_Alignment (gnat_entity))
5306 unsigned int double_align, align;
5307 bool is_capped_double, align_clause;
5309 /* If the default alignment of "double" or larger scalar types is
5310 specifically capped and this is not an array with an alignment
5311 clause on the component type, return the cap. */
5312 if ((double_align = double_float_alignment) > 0)
5314 = is_double_float_or_array (gnat_entity, &align_clause);
5315 else if ((double_align = double_scalar_alignment) > 0)
5317 = is_double_scalar_or_array (gnat_entity, &align_clause);
5319 is_capped_double = align_clause = false;
5321 if (is_capped_double && !align_clause)
5322 align = double_align;
5324 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
5326 Set_Alignment (gnat_entity, UI_From_Int (align));
5329 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
5331 tree gnu_size = TYPE_SIZE (gnu_type);
5333 /* If the size is self-referential, annotate the maximum value. */
5334 if (CONTAINS_PLACEHOLDER_P (gnu_size))
5335 gnu_size = max_size (gnu_size, true);
5337 /* If we are just annotating types and the type is tagged, the tag
5338 and the parent components are not generated by the front-end so
5339 alignment and sizes must be adjusted if there is no rep clause. */
5340 if (type_annotate_only
5341 && Is_Tagged_Type (gnat_entity)
5342 && Unknown_RM_Size (gnat_entity)
5343 && !VOID_TYPE_P (gnu_type)
5344 && (!TYPE_FIELDS (gnu_type)
5345 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
5349 if (Is_Derived_Type (gnat_entity))
5351 Entity_Id gnat_parent = Etype (Base_Type (gnat_entity));
5352 offset = UI_To_gnu (Esize (gnat_parent), bitsizetype);
5353 Set_Alignment (gnat_entity, Alignment (gnat_parent));
5358 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
5359 offset = bitsize_int (POINTER_SIZE);
5360 Set_Alignment (gnat_entity, UI_From_Int (align));
5363 if (TYPE_FIELDS (gnu_type))
5365 = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type)));
5367 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
5368 gnu_size = round_up (gnu_size, POINTER_SIZE);
5369 Uint uint_size = annotate_value (gnu_size);
5370 Set_RM_Size (gnat_entity, uint_size);
5371 Set_Esize (gnat_entity, uint_size);
5374 /* If there is a rep clause, only adjust alignment and Esize. */
5375 else if (type_annotate_only && Is_Tagged_Type (gnat_entity))
5378 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
5379 Set_Alignment (gnat_entity, UI_From_Int (align));
5380 gnu_size = round_up (gnu_size, POINTER_SIZE);
5381 Set_Esize (gnat_entity, annotate_value (gnu_size));
5384 /* Otherwise no adjustment is needed. */
5386 Set_Esize (gnat_entity, annotate_value (gnu_size));
5389 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
5390 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
5393 /* If we haven't already, associate the ..._DECL node that we just made with
5394 the input GNAT entity node. */
5396 save_gnu_tree (gnat_entity, gnu_decl, false);
5398 /* Now we are sure gnat_entity has a corresponding ..._DECL node,
5399 eliminate as many deferred computations as possible. */
5400 process_deferred_decl_context (false);
5402 /* If this is an enumeration or floating-point type, we were not able to set
5403 the bounds since they refer to the type. These are always static. */
5404 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
5405 || (kind == E_Floating_Point_Type))
5407 tree gnu_scalar_type = gnu_type;
5408 tree gnu_low_bound, gnu_high_bound;
5410 /* If this is a padded type, we need to use the underlying type. */
5411 if (TYPE_IS_PADDING_P (gnu_scalar_type))
5412 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
5414 /* If this is a floating point type and we haven't set a floating
5415 point type yet, use this in the evaluation of the bounds. */
5416 if (!longest_float_type_node && kind == E_Floating_Point_Type)
5417 longest_float_type_node = gnu_scalar_type;
5419 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5420 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5422 if (kind == E_Enumeration_Type)
5424 /* Enumeration types have specific RM bounds. */
5425 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5426 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5430 /* Floating-point types don't have specific RM bounds. */
5431 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5432 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5436 /* If we deferred processing of incomplete types, re-enable it. If there
5437 were no other disables and we have deferred types to process, do so. */
5439 && --defer_incomplete_level == 0
5440 && defer_incomplete_list)
5442 struct incomplete *p, *next;
5444 /* We are back to level 0 for the deferring of incomplete types.
5445 But processing these incomplete types below may itself require
5446 deferring, so preserve what we have and restart from scratch. */
5447 p = defer_incomplete_list;
5448 defer_incomplete_list = NULL;
5455 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5456 gnat_to_gnu_type (p->full_type));
5461 /* If we are not defining this type, see if it's on one of the lists of
5462 incomplete types. If so, handle the list entry now. */
5463 if (is_type && !definition)
5465 struct incomplete *p;
5467 for (p = defer_incomplete_list; p; p = p->next)
5468 if (p->old_type && p->full_type == gnat_entity)
5470 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5471 TREE_TYPE (gnu_decl));
5472 p->old_type = NULL_TREE;
5475 for (p = defer_limited_with; p; p = p->next)
5476 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5478 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5479 TREE_TYPE (gnu_decl));
5480 p->old_type = NULL_TREE;
5487 /* If this is a packed array type whose original array type is itself
5488 an Itype without freeze node, make sure the latter is processed. */
5489 if (Is_Packed_Array_Impl_Type (gnat_entity)
5490 && Is_Itype (Original_Array_Type (gnat_entity))
5491 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5492 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5493 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5498 /* Similar, but if the returned value is a COMPONENT_REF, return the
5502 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5504 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5506 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5507 gnu_field = TREE_OPERAND (gnu_field, 1);
5512 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5513 the GCC type corresponding to that entity. */
5516 gnat_to_gnu_type (Entity_Id gnat_entity)
5520 /* The back end never attempts to annotate generic types. */
5521 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5522 return void_type_node;
5524 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5525 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5527 return TREE_TYPE (gnu_decl);
5530 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5531 the unpadded version of the GCC type corresponding to that entity. */
5534 get_unpadded_type (Entity_Id gnat_entity)
5536 tree type = gnat_to_gnu_type (gnat_entity);
5538 if (TYPE_IS_PADDING_P (type))
5539 type = TREE_TYPE (TYPE_FIELDS (type));
5544 /* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
5545 type has been changed to that of the parameterless procedure, except if an
5546 alias is already present, in which case it is returned instead. */
5549 get_minimal_subprog_decl (Entity_Id gnat_entity)
5551 tree gnu_entity_name, gnu_ext_name;
5552 struct attrib *attr_list = NULL;
5554 /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
5555 of the handling applied here. */
5557 while (Present (Alias (gnat_entity)))
5559 gnat_entity = Alias (gnat_entity);
5560 if (present_gnu_tree (gnat_entity))
5561 return get_gnu_tree (gnat_entity);
5564 gnu_entity_name = get_entity_name (gnat_entity);
5565 gnu_ext_name = create_concat_name (gnat_entity, NULL);
5567 if (Has_Stdcall_Convention (gnat_entity))
5568 prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
5569 get_identifier ("stdcall"), NULL_TREE,
5571 else if (Has_Thiscall_Convention (gnat_entity))
5572 prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
5573 get_identifier ("thiscall"), NULL_TREE,
5576 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
5577 gnu_ext_name = NULL_TREE;
5580 create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
5581 is_disabled, false, true, true, false, true, false,
5582 attr_list, gnat_entity);
5585 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
5586 a C++ imported method or equivalent.
5588 We use the predicate on 32-bit x86/Windows to find out whether we need to
5589 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
5590 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
5593 is_cplusplus_method (Entity_Id gnat_entity)
5595 /* Check that the subprogram has C++ convention. */
5596 if (Convention (gnat_entity) != Convention_CPP)
5599 /* A constructor is a method on the C++ side. We deal with it now because
5600 it is declared without the 'this' parameter in the sources and, although
5601 the front-end will create a version with the 'this' parameter for code
5602 generation purposes, we want to return true for both versions. */
5603 if (Is_Constructor (gnat_entity))
5606 /* And that the type of the first parameter (indirectly) has it too. */
5607 Entity_Id gnat_first = First_Formal (gnat_entity);
5608 if (No (gnat_first))
5611 Entity_Id gnat_type = Etype (gnat_first);
5612 if (Is_Access_Type (gnat_type))
5613 gnat_type = Directly_Designated_Type (gnat_type);
5614 if (Convention (gnat_type) != Convention_CPP)
5617 /* This is the main case: C++ method imported as a primitive operation.
5618 Note that a C++ class with no virtual functions can be imported as a
5619 limited record type so the operation is not necessarily dispatching. */
5620 if (Is_Primitive (gnat_entity))
5623 /* A thunk needs to be handled like its associated primitive operation. */
5624 if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
5627 /* This is set on the E_Subprogram_Type built for a dispatching call. */
5628 if (Is_Dispatch_Table_Entity (gnat_entity))
5634 /* Finalize the processing of From_Limited_With incomplete types. */
5637 finalize_from_limited_with (void)
5639 struct incomplete *p, *next;
5641 p = defer_limited_with;
5642 defer_limited_with = NULL;
5649 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5650 gnat_to_gnu_type (p->full_type));
5655 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5656 kind of type (such E_Task_Type) that has a different type which Gigi
5657 uses for its representation. If the type does not have a special type
5658 for its representation, return GNAT_ENTITY. If a type is supposed to
5659 exist, but does not, abort unless annotating types, in which case
5660 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5663 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5665 Entity_Id gnat_equiv = gnat_entity;
5667 if (No (gnat_entity))
5670 switch (Ekind (gnat_entity))
5672 case E_Class_Wide_Subtype:
5673 if (Present (Equivalent_Type (gnat_entity)))
5674 gnat_equiv = Equivalent_Type (gnat_entity);
5677 case E_Access_Protected_Subprogram_Type:
5678 case E_Anonymous_Access_Protected_Subprogram_Type:
5679 gnat_equiv = Equivalent_Type (gnat_entity);
5682 case E_Class_Wide_Type:
5683 gnat_equiv = Root_Type (gnat_entity);
5687 case E_Task_Subtype:
5688 case E_Protected_Type:
5689 case E_Protected_Subtype:
5690 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5697 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5702 /* Return a GCC tree for a type corresponding to the component type of the
5703 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5704 is for an array being defined. DEBUG_INFO_P is true if we need to write
5705 debug information for other types that we may create in the process. */
5708 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5711 const Entity_Id gnat_type = Component_Type (gnat_array);
5712 tree gnu_type = gnat_to_gnu_type (gnat_type);
5715 /* Try to get a smaller form of the component if needed. */
5716 if ((Is_Packed (gnat_array)
5717 || Has_Component_Size_Clause (gnat_array))
5718 && !Is_Bit_Packed_Array (gnat_array)
5719 && !Has_Aliased_Components (gnat_array)
5720 && !Strict_Alignment (gnat_type)
5721 && RECORD_OR_UNION_TYPE_P (gnu_type)
5722 && !TYPE_FAT_POINTER_P (gnu_type)
5723 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
5724 gnu_type = make_packable_type (gnu_type, false);
5726 if (Has_Atomic_Components (gnat_array))
5727 check_ok_for_atomic_type (gnu_type, gnat_array, true);
5729 /* Get and validate any specified Component_Size. */
5731 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5732 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5733 true, Has_Component_Size_Clause (gnat_array));
5735 /* If the array has aliased components and the component size can be zero,
5736 force at least unit size to ensure that the components have distinct
5739 && Has_Aliased_Components (gnat_array)
5740 && (integer_zerop (TYPE_SIZE (gnu_type))
5741 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5742 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5744 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5746 /* If the component type is a RECORD_TYPE that has a self-referential size,
5747 then use the maximum size for the component size. */
5749 && TREE_CODE (gnu_type) == RECORD_TYPE
5750 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5751 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5753 /* Honor the component size. This is not needed for bit-packed arrays. */
5754 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5756 tree orig_type = gnu_type;
5757 unsigned int max_align;
5759 /* If an alignment is specified, use it as a cap on the component type
5760 so that it can be honored for the whole type. But ignore it for the
5761 original type of packed array types. */
5762 if (No (Packed_Array_Impl_Type (gnat_array))
5763 && Known_Alignment (gnat_array))
5764 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5768 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5769 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5770 gnu_type = orig_type;
5772 orig_type = gnu_type;
5774 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5775 true, false, definition, true);
5777 /* If a padding record was made, declare it now since it will never be
5778 declared otherwise. This is necessary to ensure that its subtrees
5779 are properly marked. */
5780 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5781 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5785 /* If the component type is a padded type made for a non-bit-packed array
5786 of scalars with reverse storage order, we need to propagate the reverse
5787 storage order to the padding type since it is the innermost enclosing
5788 aggregate type around the scalar. */
5789 if (TYPE_IS_PADDING_P (gnu_type)
5790 && Reverse_Storage_Order (gnat_array)
5791 && !Is_Bit_Packed_Array (gnat_array)
5792 && Is_Scalar_Type (gnat_type))
5793 gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
5795 if (Has_Volatile_Components (gnat_array))
5798 = TYPE_QUAL_VOLATILE
5799 | (Has_Atomic_Components (gnat_array) ? TYPE_QUAL_ATOMIC : 0);
5800 gnu_type = change_qualified_type (gnu_type, quals);
5806 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5807 using MECH as its passing mechanism, to be placed in the parameter
5808 list built for GNAT_SUBPROG. Assume a foreign convention for the
5809 latter if FOREIGN is true. Also set CICO to true if the parameter
5810 must use the copy-in copy-out implementation mechanism.
5812 The returned tree is a PARM_DECL, except for those cases where no
5813 parameter needs to be actually passed to the subprogram; the type
5814 of this "shadow" parameter is then returned instead. */
5817 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5818 Entity_Id gnat_subprog, bool foreign, bool *cico)
5820 tree gnu_param_name = get_entity_name (gnat_param);
5821 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5822 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5823 /* The parameter can be indirectly modified if its address is taken. */
5824 bool ro_param = in_param && !Address_Taken (gnat_param);
5825 bool by_return = false, by_component_ptr = false;
5826 bool by_ref = false;
5827 bool restricted_aliasing_p = false;
5830 /* Copy-return is used only for the first parameter of a valued procedure.
5831 It's a copy mechanism for which a parameter is never allocated. */
5832 if (mech == By_Copy_Return)
5834 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5839 /* If this is either a foreign function or if the underlying type won't
5840 be passed by reference and is as aligned as the original type, strip
5841 off possible padding type. */
5842 if (TYPE_IS_PADDING_P (gnu_param_type))
5844 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5847 || (!must_pass_by_ref (unpadded_type)
5848 && mech != By_Reference
5849 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))
5850 && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
5851 gnu_param_type = unpadded_type;
5854 /* If this is a read-only parameter, make a variant of the type that is
5855 read-only. ??? However, if this is an unconstrained array, that type
5856 can be very complex, so skip it for now. Likewise for any other
5857 self-referential type. */
5859 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5860 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5861 gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5863 /* For foreign conventions, pass arrays as pointers to the element type.
5864 First check for unconstrained array and get the underlying array. */
5865 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5867 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5869 /* For GCC builtins, pass Address integer types as (void *) */
5870 if (Convention (gnat_subprog) == Convention_Intrinsic
5871 && Present (Interface_Name (gnat_subprog))
5872 && Is_Descendent_Of_Address (Etype (gnat_param)))
5873 gnu_param_type = ptr_type_node;
5875 /* Arrays are passed as pointers to element type for foreign conventions. */
5876 if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5878 /* Strip off any multi-dimensional entries, then strip
5879 off the last array to get the component type. */
5880 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5881 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5882 gnu_param_type = TREE_TYPE (gnu_param_type);
5884 by_component_ptr = true;
5885 gnu_param_type = TREE_TYPE (gnu_param_type);
5889 = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5891 gnu_param_type = build_pointer_type (gnu_param_type);
5894 /* Fat pointers are passed as thin pointers for foreign conventions. */
5895 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5897 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5899 /* If we must pass or were requested to pass by reference, do so.
5900 If we were requested to pass by copy, do so.
5901 Otherwise, for foreign conventions, pass In Out or Out parameters
5902 or aggregates by reference. For COBOL and Fortran, pass all
5903 integer and FP types that way too. For Convention Ada, use
5904 the standard Ada default. */
5905 else if (must_pass_by_ref (gnu_param_type)
5906 || mech == By_Reference
5909 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5911 && (Convention (gnat_subprog) == Convention_Fortran
5912 || Convention (gnat_subprog) == Convention_COBOL)
5913 && (INTEGRAL_TYPE_P (gnu_param_type)
5914 || FLOAT_TYPE_P (gnu_param_type)))
5916 && default_pass_by_ref (gnu_param_type)))))
5918 gnu_param_type = build_reference_type (gnu_param_type);
5919 /* We take advantage of 6.2(12) by considering that references built for
5920 parameters whose type isn't by-ref and for which the mechanism hasn't
5921 been forced to by-ref allow only a restricted form of aliasing. */
5922 restricted_aliasing_p
5923 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5927 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5931 if (mech == By_Copy && (by_ref || by_component_ptr))
5932 post_error ("?cannot pass & by copy", gnat_param);
5934 /* If this is an Out parameter that isn't passed by reference and isn't
5935 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5936 it will be a VAR_DECL created when we process the procedure, so just
5937 return its type. For the special parameter of a valued procedure,
5940 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5941 Out parameters with discriminants or implicit initial values to be
5942 handled like In Out parameters. These type are normally built as
5943 aggregates, hence passed by reference, except for some packed arrays
5944 which end up encoded in special integer types. Note that scalars can
5945 be given implicit initial values using the Default_Value aspect.
5947 The exception we need to make is then for packed arrays of records
5948 with discriminants or implicit initial values. We have no light/easy
5949 way to check for the latter case, so we merely check for packed arrays
5950 of records. This may lead to useless copy-in operations, but in very
5951 rare cases only, as these would be exceptions in a set of already
5952 exceptional situations. */
5953 if (Ekind (gnat_param) == E_Out_Parameter
5956 || (!POINTER_TYPE_P (gnu_param_type)
5957 && !AGGREGATE_TYPE_P (gnu_param_type)
5958 && !Has_Default_Aspect (Etype (gnat_param))))
5959 && !(Is_Array_Type (Etype (gnat_param))
5960 && Is_Packed (Etype (gnat_param))
5961 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5962 return gnu_param_type;
5964 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5965 ro_param || by_ref || by_component_ptr);
5966 DECL_BY_REF_P (gnu_param) = by_ref;
5967 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5968 DECL_POINTS_TO_READONLY_P (gnu_param)
5969 = (ro_param && (by_ref || by_component_ptr));
5970 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5971 DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
5973 /* If no Mechanism was specified, indicate what we're using, then
5974 back-annotate it. */
5975 if (mech == Default)
5976 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5978 Set_Mechanism (gnat_param, mech);
5982 /* Return true if GNAT_ENTITY is an incomplete entity coming from a limited
5983 with of the main unit and whose full view has not been elaborated yet. */
5986 is_from_limited_with_of_main (Entity_Id gnat_entity)
5988 /* Class-wide types are always transformed into their root type. */
5989 if (Ekind (gnat_entity) == E_Class_Wide_Type)
5990 gnat_entity = Root_Type (gnat_entity);
5992 if (IN (Ekind (gnat_entity), Incomplete_Kind)
5993 && From_Limited_With (gnat_entity))
5995 Entity_Id gnat_full_view = Non_Limited_View (gnat_entity);
5997 if (present_gnu_tree (gnat_full_view))
6000 return In_Extended_Main_Code_Unit (gnat_full_view);
6006 /* Like build_qualified_type, but TYPE_QUALS is added to the existing
6007 qualifiers on TYPE. */
6010 change_qualified_type (tree type, int type_quals)
6012 return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
6015 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
6018 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
6020 while (Present (Corresponding_Discriminant (discr1)))
6021 discr1 = Corresponding_Discriminant (discr1);
6023 while (Present (Corresponding_Discriminant (discr2)))
6024 discr2 = Corresponding_Discriminant (discr2);
6027 Original_Record_Component (discr1) == Original_Record_Component (discr2);
6030 /* Return true if the array type GNU_TYPE, which represents a dimension of
6031 GNAT_TYPE, has a non-aliased component in the back-end sense. */
6034 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
6036 /* If the array type is not the innermost dimension of the GNAT type,
6037 then it has a non-aliased component. */
6038 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6039 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
6042 /* If the array type has an aliased component in the front-end sense,
6043 then it also has an aliased component in the back-end sense. */
6044 if (Has_Aliased_Components (gnat_type))
6047 /* If this is a derived type, then it has a non-aliased component if
6048 and only if its parent type also has one. */
6049 if (Is_Derived_Type (gnat_type))
6051 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
6053 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
6055 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
6056 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
6057 gnu_parent_type = TREE_TYPE (gnu_parent_type);
6058 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
6061 /* Otherwise, rely exclusively on properties of the element type. */
6062 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
6065 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
6068 compile_time_known_address_p (Node_Id gnat_address)
6070 /* Catch System'To_Address. */
6071 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
6072 gnat_address = Expression (gnat_address);
6074 return Compile_Time_Known_Value (gnat_address);
6077 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
6078 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
6081 cannot_be_superflat (Node_Id gnat_range)
6083 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
6084 Node_Id scalar_range;
6085 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
6087 /* If the low bound is not constant, try to find an upper bound. */
6088 while (Nkind (gnat_lb) != N_Integer_Literal
6089 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
6090 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
6091 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
6092 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6093 || Nkind (scalar_range) == N_Range))
6094 gnat_lb = High_Bound (scalar_range);
6096 /* If the high bound is not constant, try to find a lower bound. */
6097 while (Nkind (gnat_hb) != N_Integer_Literal
6098 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
6099 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
6100 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
6101 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6102 || Nkind (scalar_range) == N_Range))
6103 gnat_hb = Low_Bound (scalar_range);
6105 /* If we have failed to find constant bounds, punt. */
6106 if (Nkind (gnat_lb) != N_Integer_Literal
6107 || Nkind (gnat_hb) != N_Integer_Literal)
6110 /* We need at least a signed 64-bit type to catch most cases. */
6111 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
6112 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
6113 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
6116 /* If the low bound is the smallest integer, nothing can be smaller. */
6117 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
6118 if (TREE_OVERFLOW (gnu_lb_minus_one))
6121 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
6124 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
6127 constructor_address_p (tree gnu_expr)
6129 while (TREE_CODE (gnu_expr) == NOP_EXPR
6130 || TREE_CODE (gnu_expr) == CONVERT_EXPR
6131 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
6132 gnu_expr = TREE_OPERAND (gnu_expr, 0);
6134 return (TREE_CODE (gnu_expr) == ADDR_EXPR
6135 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
6138 /* Return true if the size in units represented by GNU_SIZE can be handled by
6139 an allocation. If STATIC_P is true, consider only what can be done with a
6140 static allocation. */
6143 allocatable_size_p (tree gnu_size, bool static_p)
6145 /* We can allocate a fixed size if it is a valid for the middle-end. */
6146 if (TREE_CODE (gnu_size) == INTEGER_CST)
6147 return valid_constant_size_p (gnu_size);
6149 /* We can allocate a variable size if this isn't a static allocation. */
6154 /* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
6155 initial value of an object of GNU_TYPE. */
6158 initial_value_needs_conversion (tree gnu_type, tree gnu_expr)
6160 /* Do not convert if the object's type is unconstrained because this would
6161 generate useless evaluations of the CONSTRUCTOR to compute the size. */
6162 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
6163 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
6166 /* Do not convert if the object's type is a padding record whose field is of
6167 self-referential size because we want to copy only the actual data. */
6168 if (type_is_padding_self_referential (gnu_type))
6171 /* Do not convert a call to a function that returns with variable size since
6172 we want to use the return slot optimization in this case. */
6173 if (TREE_CODE (gnu_expr) == CALL_EXPR
6174 && return_type_with_variable_size_p (TREE_TYPE (gnu_expr)))
6177 /* Do not convert to a record type with a variant part from a record type
6178 without one, to keep the object simpler. */
6179 if (TREE_CODE (gnu_type) == RECORD_TYPE
6180 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
6181 && get_variant_part (gnu_type)
6182 && !get_variant_part (TREE_TYPE (gnu_expr)))
6185 /* In all the other cases, convert the expression to the object's type. */
6189 /* Given GNAT_ENTITY, elaborate all expressions that are required to
6190 be elaborated at the point of its definition, but do nothing else. */
6193 elaborate_entity (Entity_Id gnat_entity)
6195 switch (Ekind (gnat_entity))
6197 case E_Signed_Integer_Subtype:
6198 case E_Modular_Integer_Subtype:
6199 case E_Enumeration_Subtype:
6200 case E_Ordinary_Fixed_Point_Subtype:
6201 case E_Decimal_Fixed_Point_Subtype:
6202 case E_Floating_Point_Subtype:
6204 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
6205 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
6207 /* ??? Tests to avoid Constraint_Error in static expressions
6208 are needed until after the front stops generating bogus
6209 conversions on bounds of real types. */
6210 if (!Raises_Constraint_Error (gnat_lb))
6211 elaborate_expression (gnat_lb, gnat_entity, "L", true, false,
6212 Needs_Debug_Info (gnat_entity));
6213 if (!Raises_Constraint_Error (gnat_hb))
6214 elaborate_expression (gnat_hb, gnat_entity, "U", true, false,
6215 Needs_Debug_Info (gnat_entity));
6219 case E_Record_Subtype:
6220 case E_Private_Subtype:
6221 case E_Limited_Private_Subtype:
6222 case E_Record_Subtype_With_Private:
6223 if (Has_Discriminants (gnat_entity) && Is_Constrained (gnat_entity))
6225 Node_Id gnat_discriminant_expr;
6226 Entity_Id gnat_field;
6229 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
6230 gnat_discriminant_expr
6231 = First_Elmt (Discriminant_Constraint (gnat_entity));
6232 Present (gnat_field);
6233 gnat_field = Next_Discriminant (gnat_field),
6234 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
6235 /* Ignore access discriminants. */
6236 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
6237 elaborate_expression (Node (gnat_discriminant_expr),
6238 gnat_entity, get_entity_char (gnat_field),
6239 true, false, false);
6246 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6247 NAME, ARGS and ERROR_POINT. */
6250 prepend_one_attribute (struct attrib **attr_list,
6251 enum attrib_type attrib_type,
6254 Node_Id attr_error_point)
6256 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
6258 attr->type = attrib_type;
6259 attr->name = attr_name;
6260 attr->args = attr_args;
6261 attr->error_point = attr_error_point;
6263 attr->next = *attr_list;
6267 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
6270 prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma)
6272 const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma);
6273 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
6274 enum attrib_type etype;
6276 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
6277 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
6279 case Pragma_Machine_Attribute:
6280 etype = ATTR_MACHINE_ATTRIBUTE;
6283 case Pragma_Linker_Alias:
6284 etype = ATTR_LINK_ALIAS;
6287 case Pragma_Linker_Section:
6288 etype = ATTR_LINK_SECTION;
6291 case Pragma_Linker_Constructor:
6292 etype = ATTR_LINK_CONSTRUCTOR;
6295 case Pragma_Linker_Destructor:
6296 etype = ATTR_LINK_DESTRUCTOR;
6299 case Pragma_Weak_External:
6300 etype = ATTR_WEAK_EXTERNAL;
6303 case Pragma_Thread_Local_Storage:
6304 etype = ATTR_THREAD_LOCAL_STORAGE;
6311 /* See what arguments we have and turn them into GCC trees for attribute
6312 handlers. These expect identifier for strings. We handle at most two
6313 arguments and static expressions only. */
6314 if (Present (gnat_arg) && Present (First (gnat_arg)))
6316 Node_Id gnat_arg0 = Next (First (gnat_arg));
6317 Node_Id gnat_arg1 = Empty;
6319 if (Present (gnat_arg0)
6320 && Is_OK_Static_Expression (Expression (gnat_arg0)))
6322 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
6324 if (TREE_CODE (gnu_arg0) == STRING_CST)
6326 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6327 if (IDENTIFIER_LENGTH (gnu_arg0) == 0)
6331 gnat_arg1 = Next (gnat_arg0);
6334 if (Present (gnat_arg1)
6335 && Is_OK_Static_Expression (Expression (gnat_arg1)))
6337 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6339 if (TREE_CODE (gnu_arg1) == STRING_CST)
6340 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6344 /* Prepend to the list. Make a list of the argument we might have, as GCC
6346 prepend_one_attribute (attr_list, etype, gnu_arg0,
6348 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6349 Present (Next (First (gnat_arg)))
6350 ? Expression (Next (First (gnat_arg))) : gnat_pragma);
6353 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6356 prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
6360 /* Attributes are stored as Representation Item pragmas. */
6361 for (gnat_temp = First_Rep_Item (gnat_entity);
6362 Present (gnat_temp);
6363 gnat_temp = Next_Rep_Item (gnat_temp))
6364 if (Nkind (gnat_temp) == N_Pragma)
6365 prepend_one_attribute_pragma (attr_list, gnat_temp);
6368 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6369 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6370 return the GCC tree to use for that expression. S is the suffix to use
6371 if a variable needs to be created and DEFINITION is true if this is done
6372 for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6373 otherwise, we are just elaborating the expression for side-effects. If
6374 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6375 isn't needed for code generation. */
6378 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
6379 bool definition, bool need_value, bool need_debug)
6383 /* If we already elaborated this expression (e.g. it was involved
6384 in the definition of a private type), use the old value. */
6385 if (present_gnu_tree (gnat_expr))
6386 return get_gnu_tree (gnat_expr);
6388 /* If we don't need a value and this is static or a discriminant,
6389 we don't need to do anything. */
6391 && (Is_OK_Static_Expression (gnat_expr)
6392 || (Nkind (gnat_expr) == N_Identifier
6393 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6396 /* If it's a static expression, we don't need a variable for debugging. */
6397 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6400 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6401 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s,
6402 definition, need_debug);
6404 /* Save the expression in case we try to elaborate this entity again. Since
6405 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6406 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6407 save_gnu_tree (gnat_expr, gnu_expr, true);
6409 return need_value ? gnu_expr : error_mark_node;
6412 /* Similar, but take a GNU expression and always return a result. */
6415 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6416 bool definition, bool need_debug)
6418 const bool expr_public_p = Is_Public (gnat_entity);
6419 const bool expr_global_p = expr_public_p || global_bindings_p ();
6420 bool expr_variable_p, use_variable;
6422 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6423 that an expression cannot contain both a discriminant and a variable. */
6424 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6427 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6428 a variable that is initialized to contain the expression when the package
6429 containing the definition is elaborated. If this entity is defined at top
6430 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6431 if this is necessary. */
6432 if (TREE_CONSTANT (gnu_expr))
6433 expr_variable_p = false;
6436 /* Skip any conversions and simple constant arithmetics to see if the
6437 expression is based on a read-only variable. */
6438 tree inner = remove_conversions (gnu_expr, true);
6440 inner = skip_simple_constant_arithmetic (inner);
6442 if (handled_component_p (inner))
6443 inner = get_inner_constant_reference (inner);
6447 && TREE_CODE (inner) == VAR_DECL
6448 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6451 /* We only need to use the variable if we are in a global context since GCC
6452 can do the right thing in the local case. However, when not optimizing,
6453 use it for bounds of loop iteration scheme to avoid code duplication. */
6454 use_variable = expr_variable_p
6458 && Is_Itype (gnat_entity)
6459 && Nkind (Associated_Node_For_Itype (gnat_entity))
6460 == N_Loop_Parameter_Specification));
6462 /* Now create it, possibly only for debugging purposes. */
6463 if (use_variable || need_debug)
6465 /* The following variable creation can happen when processing the body
6466 of subprograms that are defined out of the extended main unit and
6467 inlined. In this case, we are not at the global scope, and thus the
6468 new variable must not be tagged "external", as we used to do here as
6469 soon as DEFINITION was false. */
6471 = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE,
6472 TREE_TYPE (gnu_expr), gnu_expr, true,
6473 expr_public_p, !definition && expr_global_p,
6474 expr_global_p, false, true, need_debug,
6477 /* Using this variable at debug time (if need_debug is true) requires a
6478 proper location. The back-end will compute a location for this
6479 variable only if the variable is used by the generated code.
6480 Returning the variable ensures the caller will use it in generated
6481 code. Note that there is no need for a location if the debug info
6482 contains an integer constant.
6483 TODO: when the encoding-based debug scheme is dropped, move this
6484 condition to the top-level IF block: we will not need to create a
6485 variable anymore in such cases, then. */
6486 if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr)))
6490 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6493 /* Similar, but take an alignment factor and make it explicit in the tree. */
6496 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6497 bool definition, bool need_debug, unsigned int align)
6499 tree unit_align = size_int (align / BITS_PER_UNIT);
6501 size_binop (MULT_EXPR,
6502 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6505 gnat_entity, s, definition,
6510 /* Structure to hold internal data for elaborate_reference. */
6519 /* Wrapper function around elaborate_expression_1 for elaborate_reference. */
6522 elaborate_reference_1 (tree ref, void *data)
6524 struct er_data *er = (struct er_data *)data;
6527 /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */
6528 if (TREE_CONSTANT (ref))
6531 /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat
6532 pointer. This may be more efficient, but will also allow us to more
6533 easily find the match for the PLACEHOLDER_EXPR. */
6534 if (TREE_CODE (ref) == COMPONENT_REF
6535 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
6536 return build3 (COMPONENT_REF, TREE_TYPE (ref),
6537 elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
6538 TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2));
6540 sprintf (suffix, "EXP%d", ++er->n);
6542 elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
6545 /* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
6546 DEFINITION is true if this is done for a definition of GNAT_ENTITY and
6547 INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
6550 elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
6553 struct er_data er = { gnat_entity, definition, 0 };
6554 return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
6557 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6558 the value passed against the list of choices. */
6561 choices_to_gnu (tree operand, Node_Id choices)
6565 tree result = boolean_false_node;
6566 tree this_test, low = 0, high = 0, single = 0;
6568 for (choice = First (choices); Present (choice); choice = Next (choice))
6570 switch (Nkind (choice))
6573 low = gnat_to_gnu (Low_Bound (choice));
6574 high = gnat_to_gnu (High_Bound (choice));
6577 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6578 build_binary_op (GE_EXPR, boolean_type_node,
6580 build_binary_op (LE_EXPR, boolean_type_node,
6585 case N_Subtype_Indication:
6586 gnat_temp = Range_Expression (Constraint (choice));
6587 low = gnat_to_gnu (Low_Bound (gnat_temp));
6588 high = gnat_to_gnu (High_Bound (gnat_temp));
6591 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6592 build_binary_op (GE_EXPR, boolean_type_node,
6594 build_binary_op (LE_EXPR, boolean_type_node,
6599 case N_Expanded_Name:
6600 /* This represents either a subtype range, an enumeration
6601 literal, or a constant Ekind says which. If an enumeration
6602 literal or constant, fall through to the next case. */
6603 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6604 && Ekind (Entity (choice)) != E_Constant)
6606 tree type = gnat_to_gnu_type (Entity (choice));
6608 low = TYPE_MIN_VALUE (type);
6609 high = TYPE_MAX_VALUE (type);
6612 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6613 build_binary_op (GE_EXPR, boolean_type_node,
6615 build_binary_op (LE_EXPR, boolean_type_node,
6620 /* ... fall through ... */
6622 case N_Character_Literal:
6623 case N_Integer_Literal:
6624 single = gnat_to_gnu (choice);
6625 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6629 case N_Others_Choice:
6630 this_test = boolean_true_node;
6637 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6644 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6645 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6648 adjust_packed (tree field_type, tree record_type, int packed)
6650 /* If the field contains an item of variable size, we cannot pack it
6651 because we cannot create temporaries of non-fixed size in case
6652 we need to take the address of the field. See addressable_p and
6653 the notes on the addressability issues for further details. */
6654 if (type_has_variable_size (field_type))
6657 /* In the other cases, we can honor the packing. */
6661 /* If the alignment of the record is specified and the field type
6662 is over-aligned, request Storage_Unit alignment for the field. */
6663 if (TYPE_ALIGN (record_type)
6664 && TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6667 /* Likewise if the maximum alignment of the record is specified. */
6668 if (TYPE_MAX_ALIGN (record_type)
6669 && TYPE_ALIGN (field_type) > TYPE_MAX_ALIGN (record_type))
6675 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6676 placed in GNU_RECORD_TYPE.
6678 PACKED is 1 if the enclosing record is packed or -1 if the enclosing
6679 record has Component_Alignment of Storage_Unit.
6681 DEFINITION is true if this field is for a record being defined.
6683 DEBUG_INFO_P is true if we need to write debug information for types
6684 that we may create in the process. */
6687 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6688 bool definition, bool debug_info_p)
6690 const Entity_Id gnat_field_type = Etype (gnat_field);
6691 const bool is_aliased
6692 = Is_Aliased (gnat_field);
6693 const bool is_atomic
6694 = (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type));
6695 const bool is_independent
6696 = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
6697 const bool is_volatile
6698 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6699 const bool needs_strict_alignment
6703 || Strict_Alignment (gnat_field_type));
6704 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6705 tree gnu_field_id = get_entity_name (gnat_field);
6706 tree gnu_field, gnu_size, gnu_pos;
6708 /* If this field requires strict alignment, we cannot pack it because
6709 it would very likely be under-aligned in the record. */
6710 if (needs_strict_alignment)
6713 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6715 /* If a size is specified, use it. Otherwise, if the record type is packed,
6716 use the official RM size. See "Handling of Type'Size Values" in Einfo
6717 for further details. */
6718 if (Known_Esize (gnat_field))
6719 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6720 gnat_field, FIELD_DECL, false, true);
6721 else if (packed == 1)
6722 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6723 gnat_field, FIELD_DECL, false, true);
6725 gnu_size = NULL_TREE;
6727 /* If we have a specified size that is smaller than that of the field's type,
6728 or a position is specified, and the field's type is a record that doesn't
6729 require strict alignment, see if we can get either an integral mode form
6730 of the type or a smaller form. If we can, show a size was specified for
6731 the field if there wasn't one already, so we know to make this a bitfield
6732 and avoid making things wider.
6734 Changing to an integral mode form is useful when the record is packed as
6735 we can then place the field at a non-byte-aligned position and so achieve
6736 tighter packing. This is in addition required if the field shares a byte
6737 with another field and the front-end lets the back-end handle the access
6738 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6740 Changing to a smaller form is required if the specified size is smaller
6741 than that of the field's type and the type contains sub-fields that are
6742 padded, in order to avoid generating accesses to these sub-fields that
6743 are wider than the field.
6745 We avoid the transformation if it is not required or potentially useful,
6746 as it might entail an increase of the field's alignment and have ripple
6747 effects on the outer record type. A typical case is a field known to be
6748 byte-aligned and not to share a byte with another field. */
6749 if (!needs_strict_alignment
6750 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
6751 && !TYPE_FAT_POINTER_P (gnu_field_type)
6752 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
6755 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6756 || (Present (Component_Clause (gnat_field))
6757 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6758 % BITS_PER_UNIT == 0
6759 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6761 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6762 if (gnu_packable_type != gnu_field_type)
6764 gnu_field_type = gnu_packable_type;
6766 gnu_size = rm_size (gnu_field_type);
6770 if (Is_Atomic_Or_VFA (gnat_field))
6771 check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
6773 if (Present (Component_Clause (gnat_field)))
6775 Node_Id gnat_clause = Component_Clause (gnat_field);
6776 Entity_Id gnat_parent
6777 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6779 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6780 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6781 gnat_field, FIELD_DECL, false, true);
6783 /* Ensure the position does not overlap with the parent subtype, if there
6784 is one. This test is omitted if the parent of the tagged type has a
6785 full rep clause since, in this case, component clauses are allowed to
6786 overlay the space allocated for the parent type and the front-end has
6787 checked that there are no overlapping components. */
6788 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6790 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6792 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6793 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6795 ("offset of& must be beyond parent{, minimum allowed is ^}",
6796 Position (gnat_clause), gnat_field, TYPE_SIZE_UNIT (gnu_parent));
6799 /* If this field needs strict alignment, make sure that the record is
6800 sufficiently aligned and that the position and size are consistent
6801 with the type. But don't do it if we are just annotating types and
6802 the field's type is tagged, since tagged types aren't fully laid out
6803 in this mode. Also, note that atomic implies volatile so the inner
6804 test sequences ordering is significant here. */
6805 if (needs_strict_alignment
6806 && !(type_annotate_only && Is_Tagged_Type (gnat_field_type)))
6808 const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
6810 if (TYPE_ALIGN (gnu_record_type) < type_align)
6811 SET_TYPE_ALIGN (gnu_record_type, type_align);
6813 /* If the position is not a multiple of the alignment of the type,
6814 then error out and reset the position. */
6815 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
6816 bitsize_int (type_align))))
6821 s = "position of atomic field& must be multiple of ^ bits";
6822 else if (is_aliased)
6823 s = "position of aliased field& must be multiple of ^ bits";
6824 else if (is_independent)
6825 s = "position of independent field& must be multiple of ^ bits";
6826 else if (is_volatile)
6827 s = "position of volatile field& must be multiple of ^ bits";
6828 else if (Strict_Alignment (gnat_field_type))
6829 s = "position of & with aliased or tagged part must be"
6830 " multiple of ^ bits";
6834 post_error_ne_num (s, First_Bit (gnat_clause), gnat_field,
6836 gnu_pos = NULL_TREE;
6841 tree gnu_type_size = TYPE_SIZE (gnu_field_type);
6842 const int cmp = tree_int_cst_compare (gnu_size, gnu_type_size);
6844 /* If the size is lower than that of the type, or greater for
6845 atomic and aliased, then error out and reset the size. */
6846 if (cmp < 0 || (cmp > 0 && (is_atomic || is_aliased)))
6851 s = "size of atomic field& must be ^ bits";
6852 else if (is_aliased)
6853 s = "size of aliased field& must be ^ bits";
6854 else if (is_independent)
6855 s = "size of independent field& must be at least ^ bits";
6856 else if (is_volatile)
6857 s = "size of volatile field& must be at least ^ bits";
6858 else if (Strict_Alignment (gnat_field_type))
6859 s = "size of & with aliased or tagged part must be"
6864 post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field,
6866 gnu_size = NULL_TREE;
6869 /* Likewise if the size is not a multiple of a byte, */
6870 else if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
6871 bitsize_unit_node)))
6876 s = "size of independent field& must be multiple of"
6878 else if (is_volatile)
6879 s = "size of volatile field& must be multiple of"
6881 else if (Strict_Alignment (gnat_field_type))
6882 s = "size of & with aliased or tagged part must be"
6883 " multiple of Storage_Unit";
6887 post_error_ne (s, Last_Bit (gnat_clause), gnat_field);
6888 gnu_size = NULL_TREE;
6894 /* If the record has rep clauses and this is the tag field, make a rep
6895 clause for it as well. */
6896 else if (Has_Specified_Layout (Scope (gnat_field))
6897 && Chars (gnat_field) == Name_uTag)
6899 gnu_pos = bitsize_zero_node;
6900 gnu_size = TYPE_SIZE (gnu_field_type);
6905 gnu_pos = NULL_TREE;
6907 /* If we are packing the record and the field is BLKmode, round the
6908 size up to a byte boundary. */
6909 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6910 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6913 /* We need to make the size the maximum for the type if it is
6914 self-referential and an unconstrained type. In that case, we can't
6915 pack the field since we can't make a copy to align it. */
6916 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6918 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6919 && !Is_Constrained (Underlying_Type (gnat_field_type)))
6921 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6925 /* If a size is specified, adjust the field's type to it. */
6928 tree orig_field_type;
6930 /* If the field's type is justified modular, we would need to remove
6931 the wrapper to (better) meet the layout requirements. However we
6932 can do so only if the field is not aliased to preserve the unique
6933 layout and if the prescribed size is not greater than that of the
6934 packed array to preserve the justification. */
6935 if (!needs_strict_alignment
6936 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6937 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6938 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6940 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6942 /* Similarly if the field's type is a misaligned integral type, but
6943 there is no restriction on the size as there is no justification. */
6944 if (!needs_strict_alignment
6945 && TYPE_IS_PADDING_P (gnu_field_type)
6946 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
6947 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6950 = make_type_from_size (gnu_field_type, gnu_size,
6951 Has_Biased_Representation (gnat_field));
6953 orig_field_type = gnu_field_type;
6954 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6955 false, false, definition, true);
6957 /* If a padding record was made, declare it now since it will never be
6958 declared otherwise. This is necessary to ensure that its subtrees
6959 are properly marked. */
6960 if (gnu_field_type != orig_field_type
6961 && !DECL_P (TYPE_NAME (gnu_field_type)))
6962 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true,
6963 debug_info_p, gnat_field);
6966 /* Otherwise (or if there was an error), don't specify a position. */
6968 gnu_pos = NULL_TREE;
6970 /* If the field's type is a padded type made for a scalar field of a record
6971 type with reverse storage order, we need to propagate the reverse storage
6972 order to the padding type since it is the innermost enclosing aggregate
6973 type around the scalar. */
6974 if (TYPE_IS_PADDING_P (gnu_field_type)
6975 && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type)
6976 && Is_Scalar_Type (gnat_field_type))
6977 gnu_field_type = set_reverse_storage_order_on_pad_type (gnu_field_type);
6979 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6980 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6982 /* Now create the decl for the field. */
6984 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6985 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
6986 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6987 DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field);
6988 TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile;
6990 if (Ekind (gnat_field) == E_Discriminant)
6992 DECL_INVARIANT_P (gnu_field)
6993 = No (Discriminant_Default_Value (gnat_field));
6994 DECL_DISCRIMINANT_NUMBER (gnu_field)
6995 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7001 /* Return true if at least one member of COMPONENT_LIST needs strict
7005 components_need_strict_alignment (Node_Id component_list)
7007 Node_Id component_decl;
7009 for (component_decl = First_Non_Pragma (Component_Items (component_list));
7010 Present (component_decl);
7011 component_decl = Next_Non_Pragma (component_decl))
7013 Entity_Id gnat_field = Defining_Entity (component_decl);
7015 if (Is_Aliased (gnat_field))
7018 if (Strict_Alignment (Etype (gnat_field)))
7025 /* Return true if TYPE is a type with variable size or a padding type with a
7026 field of variable size or a record that has a field with such a type. */
7029 type_has_variable_size (tree type)
7033 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7036 if (TYPE_IS_PADDING_P (type)
7037 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7040 if (!RECORD_OR_UNION_TYPE_P (type))
7043 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7044 if (type_has_variable_size (TREE_TYPE (field)))
7050 /* Return true if FIELD is an artificial field. */
7053 field_is_artificial (tree field)
7055 /* These fields are generated by the front-end proper. */
7056 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
7059 /* These fields are generated by gigi. */
7060 if (DECL_INTERNAL_P (field))
7066 /* Return true if FIELD is a non-artificial aliased field. */
7069 field_is_aliased (tree field)
7071 if (field_is_artificial (field))
7074 return DECL_ALIASED_P (field);
7077 /* Return true if FIELD is a non-artificial field with self-referential
7081 field_has_self_size (tree field)
7083 if (field_is_artificial (field))
7086 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7089 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
7092 /* Return true if FIELD is a non-artificial field with variable size. */
7095 field_has_variable_size (tree field)
7097 if (field_is_artificial (field))
7100 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7103 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
7106 /* qsort comparer for the bit positions of two record components. */
7109 compare_field_bitpos (const PTR rt1, const PTR rt2)
7111 const_tree const field1 = * (const_tree const *) rt1;
7112 const_tree const field2 = * (const_tree const *) rt2;
7114 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7116 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7119 /* Structure holding information for a given variant. */
7120 typedef struct vinfo
7122 /* The record type of the variant. */
7125 /* The name of the variant. */
7128 /* The qualifier of the variant. */
7131 /* Whether the variant has a rep clause. */
7134 /* Whether the variant is packed. */
7139 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set the
7140 result as the field list of GNU_RECORD_TYPE and finish it up. Return true
7141 if GNU_RECORD_TYPE has a rep clause which affects the layout (see below).
7142 When called from gnat_to_gnu_entity during the processing of a record type
7143 definition, the GCC node for the parent, if any, will be the single field
7144 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
7145 GNU_FIELD_LIST. The other calls to this function are recursive calls for
7146 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
7148 PACKED is 1 if this is for a packed record or -1 if this is for a record
7149 with Component_Alignment of Storage_Unit.
7151 DEFINITION is true if we are defining this record type.
7153 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7154 out the record. This means the alignment only serves to force fields to
7155 be bitfields, but not to require the record to be that aligned. This is
7158 ALL_REP is true if a rep clause is present for all the fields.
7160 UNCHECKED_UNION is true if we are building this type for a record with a
7161 Pragma Unchecked_Union.
7163 ARTIFICIAL is true if this is a type that was generated by the compiler.
7165 DEBUG_INFO is true if we need to write debug information about the type.
7167 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7168 mean that its contents may be unused as well, only the container itself.
7170 REORDER is true if we are permitted to reorder components of this type.
7172 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
7173 the outer record type down to this variant level. It is nonzero only if
7174 all the fields down to this level have a rep clause and ALL_REP is false.
7176 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7177 with a rep clause is to be added; in this case, that is all that should
7178 be done with such fields and the return value will be false. */
7181 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
7182 tree gnu_field_list, int packed, bool definition,
7183 bool cancel_alignment, bool all_rep,
7184 bool unchecked_union, bool artificial,
7185 bool debug_info, bool maybe_unused, bool reorder,
7186 tree first_free_pos, tree *p_gnu_rep_list)
7188 const bool needs_xv_encodings
7189 = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL;
7190 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7191 bool variants_have_rep = all_rep;
7192 bool layout_with_rep = false;
7193 bool has_self_field = false;
7194 bool has_aliased_after_self_field = false;
7195 Node_Id component_decl, variant_part;
7196 tree gnu_field, gnu_next, gnu_last;
7197 tree gnu_variant_part = NULL_TREE;
7198 tree gnu_rep_list = NULL_TREE;
7199 tree gnu_var_list = NULL_TREE;
7200 tree gnu_self_list = NULL_TREE;
7201 tree gnu_zero_list = NULL_TREE;
7203 /* For each component referenced in a component declaration create a GCC
7204 field and add it to the list, skipping pragmas in the GNAT list. */
7205 gnu_last = tree_last (gnu_field_list);
7206 if (Present (Component_Items (gnat_component_list)))
7208 = First_Non_Pragma (Component_Items (gnat_component_list));
7209 Present (component_decl);
7210 component_decl = Next_Non_Pragma (component_decl))
7212 Entity_Id gnat_field = Defining_Entity (component_decl);
7213 Name_Id gnat_name = Chars (gnat_field);
7215 /* If present, the _Parent field must have been created as the single
7216 field of the record type. Put it before any other fields. */
7217 if (gnat_name == Name_uParent)
7219 gnu_field = TYPE_FIELDS (gnu_record_type);
7220 gnu_field_list = chainon (gnu_field_list, gnu_field);
7224 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7225 definition, debug_info);
7227 /* If this is the _Tag field, put it before any other fields. */
7228 if (gnat_name == Name_uTag)
7229 gnu_field_list = chainon (gnu_field_list, gnu_field);
7231 /* If this is the _Controller field, put it before the other
7232 fields except for the _Tag or _Parent field. */
7233 else if (gnat_name == Name_uController && gnu_last)
7235 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7236 DECL_CHAIN (gnu_last) = gnu_field;
7239 /* If this is a regular field, put it after the other fields. */
7242 DECL_CHAIN (gnu_field) = gnu_field_list;
7243 gnu_field_list = gnu_field;
7245 gnu_last = gnu_field;
7247 /* And record information for the final layout. */
7248 if (field_has_self_size (gnu_field))
7249 has_self_field = true;
7250 else if (has_self_field && field_is_aliased (gnu_field))
7251 has_aliased_after_self_field = true;
7255 save_gnu_tree (gnat_field, gnu_field, false);
7258 /* At the end of the component list there may be a variant part. */
7259 variant_part = Variant_Part (gnat_component_list);
7261 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7262 mutually exclusive and should go in the same memory. To do this we need
7263 to treat each variant as a record whose elements are created from the
7264 component list for the variant. So here we create the records from the
7265 lists for the variants and put them all into the QUAL_UNION_TYPE.
7266 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7267 use GNU_RECORD_TYPE if there are no fields so far. */
7268 if (Present (variant_part))
7270 Node_Id gnat_discr = Name (variant_part), variant;
7271 tree gnu_discr = gnat_to_gnu (gnat_discr);
7272 tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
7274 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7276 tree gnu_union_type, gnu_union_name;
7277 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
7278 bool union_field_needs_strict_alignment = false;
7279 auto_vec <vinfo_t, 16> variant_types;
7280 vinfo_t *gnu_variant;
7281 unsigned int variants_align = 0;
7285 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7287 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7288 are all in the variant part, to match the layout of C unions. There
7289 is an associated check below. */
7290 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
7291 gnu_union_type = gnu_record_type;
7295 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7297 TYPE_NAME (gnu_union_type) = gnu_union_name;
7298 SET_TYPE_ALIGN (gnu_union_type, 0);
7299 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7300 TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
7301 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7304 /* If all the fields down to this level have a rep clause, find out
7305 whether all the fields at this level also have one. If so, then
7306 compute the new first free position to be passed downward. */
7307 this_first_free_pos = first_free_pos;
7308 if (this_first_free_pos)
7310 for (gnu_field = gnu_field_list;
7312 gnu_field = DECL_CHAIN (gnu_field))
7313 if (DECL_FIELD_OFFSET (gnu_field))
7315 tree pos = bit_position (gnu_field);
7316 if (!tree_int_cst_lt (pos, this_first_free_pos))
7318 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
7322 this_first_free_pos = NULL_TREE;
7327 /* We build the variants in two passes. The bulk of the work is done in
7328 the first pass, that is to say translating the GNAT nodes, building
7329 the container types and computing the associated properties. However
7330 we cannot finish up the container types during this pass because we
7331 don't know where the variant part will be placed until the end. */
7332 for (variant = First_Non_Pragma (Variants (variant_part));
7334 variant = Next_Non_Pragma (variant))
7336 tree gnu_variant_type = make_node (RECORD_TYPE);
7337 tree gnu_inner_name, gnu_qual;
7342 Get_Variant_Encoding (variant);
7343 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7344 TYPE_NAME (gnu_variant_type)
7345 = concat_name (gnu_union_name,
7346 IDENTIFIER_POINTER (gnu_inner_name));
7348 /* Set the alignment of the inner type in case we need to make
7349 inner objects into bitfields, but then clear it out so the
7350 record actually gets only the alignment required. */
7351 SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
7352 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7353 TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
7354 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7356 /* Similarly, if the outer record has a size specified and all
7357 the fields have a rep clause, we can propagate the size. */
7358 if (all_rep_and_size)
7360 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7361 TYPE_SIZE_UNIT (gnu_variant_type)
7362 = TYPE_SIZE_UNIT (gnu_record_type);
7365 /* Add the fields into the record type for the variant. Note that
7366 we aren't sure to really use it at this point, see below. */
7368 = components_to_record (gnu_variant_type, Component_List (variant),
7369 NULL_TREE, packed, definition,
7370 !all_rep_and_size, all_rep,
7372 true, needs_xv_encodings, true, reorder,
7373 this_first_free_pos,
7374 all_rep || this_first_free_pos
7375 ? NULL : &gnu_rep_list);
7377 /* Translate the qualifier and annotate the GNAT node. */
7378 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7379 Set_Present_Expr (variant, annotate_value (gnu_qual));
7381 /* Deal with packedness like in gnat_to_gnu_field. */
7382 if (components_need_strict_alignment (Component_List (variant)))
7385 union_field_needs_strict_alignment = true;
7389 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7391 /* Push this variant onto the stack for the second pass. */
7392 vinfo.type = gnu_variant_type;
7393 vinfo.name = gnu_inner_name;
7394 vinfo.qual = gnu_qual;
7395 vinfo.has_rep = has_rep;
7396 vinfo.packed = field_packed;
7397 variant_types.safe_push (vinfo);
7399 /* Compute the global properties that will determine the placement of
7400 the variant part. */
7401 variants_have_rep |= has_rep;
7402 if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align)
7403 variants_align = TYPE_ALIGN (gnu_variant_type);
7406 /* Round up the first free position to the alignment of the variant part
7407 for the variants without rep clause. This will guarantee a consistent
7408 layout independently of the placement of the variant part. */
7409 if (variants_have_rep && variants_align > 0 && this_first_free_pos)
7410 this_first_free_pos = round_up (this_first_free_pos, variants_align);
7412 /* In the second pass, the container types are adjusted if necessary and
7413 finished up, then the corresponding fields of the variant part are
7414 built with their qualifier, unless this is an unchecked union. */
7415 FOR_EACH_VEC_ELT (variant_types, i, gnu_variant)
7417 tree gnu_variant_type = gnu_variant->type;
7418 tree gnu_field_list = TYPE_FIELDS (gnu_variant_type);
7420 /* If this is an Unchecked_Union whose fields are all in the variant
7421 part and we have a single field with no representation clause or
7422 placed at offset zero, use the field directly to match the layout
7424 if (TREE_CODE (gnu_record_type) == UNION_TYPE
7426 && !DECL_CHAIN (gnu_field_list)
7427 && (!DECL_FIELD_OFFSET (gnu_field_list)
7428 || integer_zerop (bit_position (gnu_field_list))))
7430 gnu_field = gnu_field_list;
7431 DECL_CONTEXT (gnu_field) = gnu_record_type;
7435 /* Finalize the variant type now. We used to throw away empty
7436 record types but we no longer do that because we need them to
7437 generate complete debug info for the variant; otherwise, the
7438 union type definition will be lacking the fields associated
7439 with these empty variants. */
7440 if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep)
7442 /* The variant part will be at offset 0 so we need to ensure
7443 that the fields are laid out starting from the first free
7444 position at this level. */
7445 tree gnu_rep_type = make_node (RECORD_TYPE);
7447 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
7448 = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type);
7449 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
7451 = create_rep_part (gnu_rep_type, gnu_variant_type,
7452 this_first_free_pos);
7453 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7454 gnu_field_list = gnu_rep_part;
7455 finish_record_type (gnu_variant_type, gnu_field_list, 0,
7460 rest_of_record_type_compilation (gnu_variant_type);
7461 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7462 true, needs_xv_encodings, gnat_component_list);
7465 = create_field_decl (gnu_variant->name, gnu_variant_type,
7468 ? TYPE_SIZE (gnu_variant_type) : 0,
7469 variants_have_rep ? bitsize_zero_node : 0,
7470 gnu_variant->packed, 0);
7472 DECL_INTERNAL_P (gnu_field) = 1;
7474 if (!unchecked_union)
7475 DECL_QUALIFIER (gnu_field) = gnu_variant->qual;
7478 DECL_CHAIN (gnu_field) = gnu_variant_list;
7479 gnu_variant_list = gnu_field;
7482 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7483 if (gnu_variant_list)
7485 int union_field_packed;
7487 if (all_rep_and_size)
7489 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7490 TYPE_SIZE_UNIT (gnu_union_type)
7491 = TYPE_SIZE_UNIT (gnu_record_type);
7494 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7495 all_rep_and_size ? 1 : 0, needs_xv_encodings);
7497 /* If GNU_UNION_TYPE is our record type, it means we must have an
7498 Unchecked_Union with no fields. Verify that and, if so, just
7500 if (gnu_union_type == gnu_record_type)
7502 gcc_assert (unchecked_union
7505 return variants_have_rep;
7508 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true,
7509 needs_xv_encodings, gnat_component_list);
7511 /* Deal with packedness like in gnat_to_gnu_field. */
7512 if (union_field_needs_strict_alignment)
7513 union_field_packed = 0;
7516 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7519 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7521 ? TYPE_SIZE (gnu_union_type) : 0,
7522 variants_have_rep ? bitsize_zero_node : 0,
7523 union_field_packed, 0);
7525 DECL_INTERNAL_P (gnu_variant_part) = 1;
7529 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7530 permitted to reorder components, self-referential sizes or variable sizes.
7531 If they do, pull them out and put them onto the appropriate list. We have
7532 to do this in a separate pass since we want to handle the discriminants
7533 but can't play with them until we've used them in debugging data above.
7535 Similarly, pull out the fields with zero size and no rep clause, as they
7536 would otherwise modify the layout and thus very likely run afoul of the
7537 Ada semantics, which are different from those of C here.
7539 ??? If we reorder them, debugging information will be wrong but there is
7540 nothing that can be done about this at the moment. */
7541 gnu_last = NULL_TREE;
7543 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7546 DECL_CHAIN (gnu_last) = gnu_next; \
7548 gnu_field_list = gnu_next; \
7550 DECL_CHAIN (gnu_field) = (LIST); \
7551 (LIST) = gnu_field; \
7554 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7556 gnu_next = DECL_CHAIN (gnu_field);
7558 if (DECL_FIELD_OFFSET (gnu_field))
7560 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7564 if ((reorder || has_aliased_after_self_field)
7565 && field_has_self_size (gnu_field))
7567 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7571 if (reorder && field_has_variable_size (gnu_field))
7573 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7577 if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
7579 DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
7580 SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
7581 DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
7582 if (field_is_aliased (gnu_field))
7583 SET_TYPE_ALIGN (gnu_record_type,
7584 MAX (TYPE_ALIGN (gnu_record_type),
7585 TYPE_ALIGN (TREE_TYPE (gnu_field))));
7586 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
7590 gnu_last = gnu_field;
7593 #undef MOVE_FROM_FIELD_LIST_TO
7595 gnu_field_list = nreverse (gnu_field_list);
7597 /* If permitted, we reorder the fields as follows:
7599 1) all fixed length fields,
7600 2) all fields whose length doesn't depend on discriminants,
7601 3) all fields whose length depends on discriminants,
7602 4) the variant part,
7604 within the record and within each variant recursively. */
7607 = chainon (gnu_field_list, chainon (gnu_var_list, gnu_self_list));
7609 /* Otherwise, if there is an aliased field placed after a field whose length
7610 depends on discriminants, we put all the fields of the latter sort, last.
7611 We need to do this in case an object of this record type is mutable. */
7612 else if (has_aliased_after_self_field)
7613 gnu_field_list = chainon (gnu_field_list, gnu_self_list);
7615 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7616 in our REP list to the previous level because this level needs them in
7617 order to do a correct layout, i.e. avoid having overlapping fields. */
7618 if (p_gnu_rep_list && gnu_rep_list)
7619 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7621 /* Deal with the annoying case of an extension of a record with variable size
7622 and partial rep clause, for which the _Parent field is forced at offset 0
7623 and has variable size, which we do not support below. Note that we cannot
7624 do it if the field has fixed size because we rely on the presence of the
7625 REP part built below to trigger the reordering of the fields in a derived
7626 record type when all the fields have a fixed position. */
7627 else if (gnu_rep_list
7628 && !DECL_CHAIN (gnu_rep_list)
7629 && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
7630 && !variants_have_rep
7632 && integer_zerop (first_free_pos)
7633 && integer_zerop (bit_position (gnu_rep_list)))
7635 DECL_CHAIN (gnu_rep_list) = gnu_field_list;
7636 gnu_field_list = gnu_rep_list;
7637 gnu_rep_list = NULL_TREE;
7640 /* Otherwise, sort the fields by bit position and put them into their own
7641 record, before the others, if we also have fields without rep clause. */
7642 else if (gnu_rep_list)
7644 tree gnu_rep_type, gnu_rep_part;
7645 int i, len = list_length (gnu_rep_list);
7646 tree *gnu_arr = XALLOCAVEC (tree, len);
7648 /* If all the fields have a rep clause, we can do a flat layout. */
7649 layout_with_rep = !gnu_field_list
7650 && (!gnu_variant_part || variants_have_rep);
7652 = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE);
7654 for (gnu_field = gnu_rep_list, i = 0;
7656 gnu_field = DECL_CHAIN (gnu_field), i++)
7657 gnu_arr[i] = gnu_field;
7659 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7661 /* Put the fields in the list in order of increasing position, which
7662 means we start from the end. */
7663 gnu_rep_list = NULL_TREE;
7664 for (i = len - 1; i >= 0; i--)
7666 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7667 gnu_rep_list = gnu_arr[i];
7668 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7671 if (layout_with_rep)
7672 gnu_field_list = gnu_rep_list;
7675 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
7676 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7677 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7679 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
7680 without rep clause are laid out starting from this position.
7681 Therefore, we force it as a minimal size on the REP part. */
7683 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
7685 /* Chain the REP part at the beginning of the field list. */
7686 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7687 gnu_field_list = gnu_rep_part;
7691 /* Chain the variant part at the end of the field list. */
7692 if (gnu_variant_part)
7693 gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
7695 if (cancel_alignment)
7696 SET_TYPE_ALIGN (gnu_record_type, 0);
7698 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
7700 finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0,
7701 debug_info && !maybe_unused);
7703 /* Chain the fields with zero size at the beginning of the field list. */
7705 TYPE_FIELDS (gnu_record_type)
7706 = chainon (gnu_zero_list, TYPE_FIELDS (gnu_record_type));
7708 return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
7711 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7712 placed into an Esize, Component_Bit_Offset, or Component_Size value
7713 in the GNAT tree. */
7716 annotate_value (tree gnu_size)
7719 Node_Ref_Or_Val ops[3], ret, pre_op1 = No_Uint;
7720 struct tree_int_map in;
7723 /* See if we've already saved the value for this node. */
7724 if (EXPR_P (gnu_size))
7726 struct tree_int_map *e;
7728 in.base.from = gnu_size;
7729 e = annotate_value_cache->find (&in);
7732 return (Node_Ref_Or_Val) e->to;
7735 in.base.from = NULL_TREE;
7737 /* If we do not return inside this switch, TCODE will be set to the
7738 code to use for a Create_Node operand and LEN (set above) will be
7739 the number of recursive calls for us to make. */
7741 switch (TREE_CODE (gnu_size))
7744 return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
7747 /* The only case we handle here is a simple discriminant reference. */
7748 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7750 tree n = DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1));
7752 /* Climb up the chain of successive extensions, if any. */
7753 while (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == COMPONENT_REF
7754 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 1))
7756 gnu_size = TREE_OPERAND (gnu_size, 0);
7758 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR)
7760 Create_Node (Discrim_Val, annotate_value (n), No_Uint, No_Uint);
7765 CASE_CONVERT: case NON_LVALUE_EXPR:
7766 return annotate_value (TREE_OPERAND (gnu_size, 0));
7768 /* Now just list the operations we handle. */
7769 case COND_EXPR: tcode = Cond_Expr; break;
7770 case PLUS_EXPR: tcode = Plus_Expr; break;
7771 case MINUS_EXPR: tcode = Minus_Expr; break;
7772 case MULT_EXPR: tcode = Mult_Expr; break;
7773 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7774 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7775 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7776 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7777 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7778 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7779 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7780 case NEGATE_EXPR: tcode = Negate_Expr; break;
7781 case MIN_EXPR: tcode = Min_Expr; break;
7782 case MAX_EXPR: tcode = Max_Expr; break;
7783 case ABS_EXPR: tcode = Abs_Expr; break;
7784 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7785 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7786 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7787 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7788 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7789 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7790 case LT_EXPR: tcode = Lt_Expr; break;
7791 case LE_EXPR: tcode = Le_Expr; break;
7792 case GT_EXPR: tcode = Gt_Expr; break;
7793 case GE_EXPR: tcode = Ge_Expr; break;
7794 case EQ_EXPR: tcode = Eq_Expr; break;
7795 case NE_EXPR: tcode = Ne_Expr; break;
7798 tcode = Bit_And_Expr;
7799 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
7800 Such values appear in expressions with aligning patterns. Note that,
7801 since sizetype is unsigned, we have to jump through some hoops. */
7802 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
7804 tree op1 = TREE_OPERAND (gnu_size, 1);
7805 wide_int signed_op1 = wi::sext (op1, TYPE_PRECISION (sizetype));
7806 if (wi::neg_p (signed_op1))
7808 op1 = wide_int_to_tree (sizetype, wi::neg (signed_op1));
7809 pre_op1 = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
7815 /* In regular mode, inline back only if symbolic annotation is requested
7816 in order to avoid memory explosion on big discriminated record types.
7817 But not in ASIS mode, as symbolic annotation is required for DDA. */
7818 if (List_Representation_Info == 3 || type_annotate_only)
7820 tree t = maybe_inline_call_in_expr (gnu_size);
7822 return annotate_value (t);
7825 return Uint_Minus_1;
7827 /* Fall through... */
7833 /* Now get each of the operands that's relevant for this code. If any
7834 cannot be expressed as a repinfo node, say we can't. */
7835 for (i = 0; i < 3; i++)
7838 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7840 if (i == 1 && pre_op1 != No_Uint)
7843 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7844 if (ops[i] == No_Uint)
7848 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7850 /* Save the result in the cache. */
7853 struct tree_int_map **h;
7854 /* We can't assume the hash table data hasn't moved since the initial
7855 look up, so we have to search again. Allocating and inserting an
7856 entry at that point would be an alternative, but then we'd better
7857 discard the entry if we decided not to cache it. */
7858 h = annotate_value_cache->find_slot (&in, INSERT);
7860 *h = ggc_alloc<tree_int_map> ();
7861 (*h)->base.from = gnu_size;
7868 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7869 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7870 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7871 BY_REF is true if the object is used by reference. */
7874 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7878 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7879 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7881 gnu_type = TREE_TYPE (gnu_type);
7884 if (Unknown_Esize (gnat_entity))
7886 if (TREE_CODE (gnu_type) == RECORD_TYPE
7887 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7888 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7890 size = TYPE_SIZE (gnu_type);
7893 Set_Esize (gnat_entity, annotate_value (size));
7896 if (Unknown_Alignment (gnat_entity))
7897 Set_Alignment (gnat_entity,
7898 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7901 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7902 Return NULL_TREE if there is no such element in the list. */
7905 purpose_member_field (const_tree elem, tree list)
7909 tree field = TREE_PURPOSE (list);
7910 if (SAME_FIELD_P (field, elem))
7912 list = TREE_CHAIN (list);
7917 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7918 set Component_Bit_Offset and Esize of the components to the position and
7919 size used by Gigi. */
7922 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7924 Entity_Id gnat_field;
7927 /* We operate by first making a list of all fields and their position (we
7928 can get the size easily) and then update all the sizes in the tree. */
7930 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7931 BIGGEST_ALIGNMENT, NULL_TREE);
7933 for (gnat_field = First_Entity (gnat_entity);
7934 Present (gnat_field);
7935 gnat_field = Next_Entity (gnat_field))
7936 if (Ekind (gnat_field) == E_Component
7937 || (Ekind (gnat_field) == E_Discriminant
7938 && !Is_Unchecked_Union (Scope (gnat_field))))
7940 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7946 /* If we are just annotating types and the type is tagged, the tag
7947 and the parent components are not generated by the front-end so
7948 we need to add the appropriate offset to each component without
7949 representation clause. */
7950 if (type_annotate_only
7951 && Is_Tagged_Type (gnat_entity)
7952 && No (Component_Clause (gnat_field)))
7954 /* For a component appearing in the current extension, the
7955 offset is the size of the parent. */
7956 if (Is_Derived_Type (gnat_entity)
7957 && Original_Record_Component (gnat_field) == gnat_field)
7959 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7962 parent_offset = bitsize_int (POINTER_SIZE);
7964 if (TYPE_FIELDS (gnu_type))
7966 = round_up (parent_offset,
7967 DECL_ALIGN (TYPE_FIELDS (gnu_type)));
7970 parent_offset = bitsize_zero_node;
7972 Set_Component_Bit_Offset
7975 (size_binop (PLUS_EXPR,
7976 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7977 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7980 Set_Esize (gnat_field,
7981 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7983 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7985 /* If there is no entry, this is an inherited component whose
7986 position is the same as in the parent type. */
7987 Entity_Id gnat_orig_field = Original_Record_Component (gnat_field);
7989 /* If we are just annotating types, discriminants renaming those of
7990 the parent have no entry so deal with them specifically. */
7991 if (type_annotate_only
7992 && gnat_orig_field == gnat_field
7993 && Ekind (gnat_field) == E_Discriminant)
7994 gnat_orig_field = Corresponding_Discriminant (gnat_field);
7996 Set_Component_Bit_Offset (gnat_field,
7997 Component_Bit_Offset (gnat_orig_field));
7999 Set_Esize (gnat_field, Esize (gnat_orig_field));
8004 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
8005 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
8006 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
8007 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
8008 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
8009 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
8010 pre-existing list to be chained to the newly created entries. */
8013 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
8014 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
8018 for (gnu_field = TYPE_FIELDS (gnu_type);
8020 gnu_field = DECL_CHAIN (gnu_field))
8022 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
8023 DECL_FIELD_BIT_OFFSET (gnu_field));
8024 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
8025 DECL_FIELD_OFFSET (gnu_field));
8026 unsigned int our_offset_align
8027 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
8028 tree v = make_tree_vec (3);
8030 TREE_VEC_ELT (v, 0) = gnu_our_offset;
8031 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
8032 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
8033 gnu_list = tree_cons (gnu_field, v, gnu_list);
8035 /* Recurse on internal fields, flattening the nested fields except for
8036 those in the variant part, if requested. */
8037 if (DECL_INTERNAL_P (gnu_field))
8039 tree gnu_field_type = TREE_TYPE (gnu_field);
8040 if (do_not_flatten_variant
8041 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
8043 = build_position_list (gnu_field_type, do_not_flatten_variant,
8044 size_zero_node, bitsize_zero_node,
8045 BIGGEST_ALIGNMENT, gnu_list);
8048 = build_position_list (gnu_field_type, do_not_flatten_variant,
8049 gnu_our_offset, gnu_our_bitpos,
8050 our_offset_align, gnu_list);
8057 /* Return a list describing the substitutions needed to reflect the
8058 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
8059 be in any order. The values in an element of the list are in the form
8060 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
8061 a definition of GNAT_SUBTYPE. */
8063 static vec<subst_pair>
8064 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
8066 vec<subst_pair> gnu_list = vNULL;
8067 Entity_Id gnat_discrim;
8068 Node_Id gnat_constr;
8070 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
8071 gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
8072 Present (gnat_discrim);
8073 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
8074 gnat_constr = Next_Elmt (gnat_constr))
8075 /* Ignore access discriminants. */
8076 if (!Is_Access_Type (Etype (Node (gnat_constr))))
8078 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
8079 tree replacement = convert (TREE_TYPE (gnu_field),
8080 elaborate_expression
8081 (Node (gnat_constr), gnat_subtype,
8082 get_entity_char (gnat_discrim),
8083 definition, true, false));
8084 subst_pair s = {gnu_field, replacement};
8085 gnu_list.safe_push (s);
8091 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
8092 variants of QUAL_UNION_TYPE that are still relevant after applying
8093 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
8094 list to be prepended to the newly created entries. */
8096 static vec<variant_desc>
8097 build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
8098 vec<variant_desc> gnu_list)
8102 for (gnu_field = TYPE_FIELDS (qual_union_type);
8104 gnu_field = DECL_CHAIN (gnu_field))
8106 tree qual = DECL_QUALIFIER (gnu_field);
8110 FOR_EACH_VEC_ELT (subst_list, i, s)
8111 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
8113 /* If the new qualifier is not unconditionally false, its variant may
8114 still be accessed. */
8115 if (!integer_zerop (qual))
8117 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
8118 variant_desc v = {variant_type, gnu_field, qual, NULL_TREE};
8120 gnu_list.safe_push (v);
8122 /* Recurse on the variant subpart of the variant, if any. */
8123 variant_subpart = get_variant_part (variant_type);
8124 if (variant_subpart)
8125 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
8126 subst_list, gnu_list);
8128 /* If the new qualifier is unconditionally true, the subsequent
8129 variants cannot be accessed. */
8130 if (integer_onep (qual))
8138 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
8139 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
8140 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
8141 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
8142 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
8143 true if we are being called to process the Component_Size of GNAT_OBJECT;
8144 this is used only for error messages. ZERO_OK is true if a size of zero
8145 is permitted; if ZERO_OK is false, it means that a size of zero should be
8146 treated as an unspecified size. */
8149 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
8150 enum tree_code kind, bool component_p, bool zero_ok)
8152 Node_Id gnat_error_node;
8153 tree type_size, size;
8155 /* Return 0 if no size was specified. */
8156 if (uint_size == No_Uint)
8159 /* Ignore a negative size since that corresponds to our back-annotation. */
8160 if (UI_Lt (uint_size, Uint_0))
8163 /* Find the node to use for error messages. */
8164 if ((Ekind (gnat_object) == E_Component
8165 || Ekind (gnat_object) == E_Discriminant)
8166 && Present (Component_Clause (gnat_object)))
8167 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
8168 else if (Present (Size_Clause (gnat_object)))
8169 gnat_error_node = Expression (Size_Clause (gnat_object));
8171 gnat_error_node = gnat_object;
8173 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8174 but cannot be represented in bitsizetype. */
8175 size = UI_To_gnu (uint_size, bitsizetype);
8176 if (TREE_OVERFLOW (size))
8179 post_error_ne ("component size for& is too large", gnat_error_node,
8182 post_error_ne ("size for& is too large", gnat_error_node,
8187 /* Ignore a zero size if it is not permitted. */
8188 if (!zero_ok && integer_zerop (size))
8191 /* The size of objects is always a multiple of a byte. */
8192 if (kind == VAR_DECL
8193 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
8196 post_error_ne ("component size for& is not a multiple of Storage_Unit",
8197 gnat_error_node, gnat_object);
8199 post_error_ne ("size for& is not a multiple of Storage_Unit",
8200 gnat_error_node, gnat_object);
8204 /* If this is an integral type or a packed array type, the front-end has
8205 already verified the size, so we need not do it here (which would mean
8206 checking against the bounds). However, if this is an aliased object,
8207 it may not be smaller than the type of the object. */
8208 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
8209 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
8212 /* If the object is a record that contains a template, add the size of the
8213 template to the specified size. */
8214 if (TREE_CODE (gnu_type) == RECORD_TYPE
8215 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8216 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
8218 if (kind == VAR_DECL
8219 /* If a type needs strict alignment, a component of this type in
8220 a packed record cannot be packed and thus uses the type size. */
8221 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
8222 type_size = TYPE_SIZE (gnu_type);
8224 type_size = rm_size (gnu_type);
8226 /* Modify the size of a discriminated type to be the maximum size. */
8227 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
8228 type_size = max_size (type_size, true);
8230 /* If this is an access type or a fat pointer, the minimum size is that given
8231 by the smallest integral mode that's valid for pointers. */
8232 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
8234 machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
8235 while (!targetm.valid_pointer_mode (p_mode))
8236 p_mode = GET_MODE_WIDER_MODE (p_mode);
8237 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
8240 /* Issue an error either if the default size of the object isn't a constant
8241 or if the new size is smaller than it. */
8242 if (TREE_CODE (type_size) != INTEGER_CST
8243 || TREE_OVERFLOW (type_size)
8244 || tree_int_cst_lt (size, type_size))
8248 ("component size for& too small{, minimum allowed is ^}",
8249 gnat_error_node, gnat_object, type_size);
8252 ("size for& too small{, minimum allowed is ^}",
8253 gnat_error_node, gnat_object, type_size);
8260 /* Similarly, but both validate and process a value of RM size. This routine
8261 is only called for types. */
8264 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
8266 Node_Id gnat_attr_node;
8267 tree old_size, size;
8269 /* Do nothing if no size was specified. */
8270 if (uint_size == No_Uint)
8273 /* Ignore a negative size since that corresponds to our back-annotation. */
8274 if (UI_Lt (uint_size, Uint_0))
8277 /* Only issue an error if a Value_Size clause was explicitly given.
8278 Otherwise, we'd be duplicating an error on the Size clause. */
8280 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
8282 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8283 but cannot be represented in bitsizetype. */
8284 size = UI_To_gnu (uint_size, bitsizetype);
8285 if (TREE_OVERFLOW (size))
8287 if (Present (gnat_attr_node))
8288 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8293 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8294 exists, or this is an integer type, in which case the front-end will
8295 have always set it. */
8296 if (No (gnat_attr_node)
8297 && integer_zerop (size)
8298 && !Has_Size_Clause (gnat_entity)
8299 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8302 old_size = rm_size (gnu_type);
8304 /* If the old size is self-referential, get the maximum size. */
8305 if (CONTAINS_PLACEHOLDER_P (old_size))
8306 old_size = max_size (old_size, true);
8308 /* Issue an error either if the old size of the object isn't a constant or
8309 if the new size is smaller than it. The front-end has already verified
8310 this for scalar and packed array types. */
8311 if (TREE_CODE (old_size) != INTEGER_CST
8312 || TREE_OVERFLOW (old_size)
8313 || (AGGREGATE_TYPE_P (gnu_type)
8314 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8315 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8316 && !(TYPE_IS_PADDING_P (gnu_type)
8317 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8318 && TYPE_PACKED_ARRAY_TYPE_P
8319 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8320 && tree_int_cst_lt (size, old_size)))
8322 if (Present (gnat_attr_node))
8324 ("Value_Size for& too small{, minimum allowed is ^}",
8325 gnat_attr_node, gnat_entity, old_size);
8329 /* Otherwise, set the RM size proper for integral types... */
8330 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8331 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8332 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8333 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8334 SET_TYPE_RM_SIZE (gnu_type, size);
8336 /* ...or the Ada size for record and union types. */
8337 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
8338 && !TYPE_FAT_POINTER_P (gnu_type))
8339 SET_TYPE_ADA_SIZE (gnu_type, size);
8342 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8343 a type or object whose present alignment is ALIGN. If this alignment is
8344 valid, return it. Otherwise, give an error and return ALIGN. */
8347 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8349 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8350 unsigned int new_align;
8351 Node_Id gnat_error_node;
8353 /* Don't worry about checking alignment if alignment was not specified
8354 by the source program and we already posted an error for this entity. */
8355 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8358 /* Post the error on the alignment clause if any. Note, for the implicit
8359 base type of an array type, the alignment clause is on the first
8361 if (Present (Alignment_Clause (gnat_entity)))
8362 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8364 else if (Is_Itype (gnat_entity)
8365 && Is_Array_Type (gnat_entity)
8366 && Etype (gnat_entity) == gnat_entity
8367 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8369 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8372 gnat_error_node = gnat_entity;
8374 /* Within GCC, an alignment is an integer, so we must make sure a value is
8375 specified that fits in that range. Also, there is an upper bound to
8376 alignments we can support/allow. */
8377 if (!UI_Is_In_Int_Range (alignment)
8378 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8379 post_error_ne_num ("largest supported alignment for& is ^",
8380 gnat_error_node, gnat_entity, max_allowed_alignment);
8381 else if (!(Present (Alignment_Clause (gnat_entity))
8382 && From_At_Mod (Alignment_Clause (gnat_entity)))
8383 && new_align * BITS_PER_UNIT < align)
8385 unsigned int double_align;
8386 bool is_capped_double, align_clause;
8388 /* If the default alignment of "double" or larger scalar types is
8389 specifically capped and the new alignment is above the cap, do
8390 not post an error and change the alignment only if there is an
8391 alignment clause; this makes it possible to have the associated
8392 GCC type overaligned by default for performance reasons. */
8393 if ((double_align = double_float_alignment) > 0)
8396 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8398 = is_double_float_or_array (gnat_type, &align_clause);
8400 else if ((double_align = double_scalar_alignment) > 0)
8403 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8405 = is_double_scalar_or_array (gnat_type, &align_clause);
8408 is_capped_double = align_clause = false;
8410 if (is_capped_double && new_align >= double_align)
8413 align = new_align * BITS_PER_UNIT;
8417 if (is_capped_double)
8418 align = double_align * BITS_PER_UNIT;
8420 post_error_ne_num ("alignment for& must be at least ^",
8421 gnat_error_node, gnat_entity,
8422 align / BITS_PER_UNIT);
8427 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8428 if (new_align > align)
8435 /* Verify that TYPE is something we can implement atomically. If not, issue
8436 an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
8437 process a component type. */
8440 check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p)
8442 Node_Id gnat_error_point = gnat_entity;
8445 enum mode_class mclass;
8449 /* If this is an anonymous base type, nothing to check, the error will be
8450 reported on the source type if need be. */
8451 if (!Comes_From_Source (gnat_entity))
8454 mode = TYPE_MODE (type);
8455 mclass = GET_MODE_CLASS (mode);
8456 align = TYPE_ALIGN (type);
8457 size = TYPE_SIZE (type);
8459 /* Consider all aligned floating-point types atomic and any aligned types
8460 that are represented by integers no wider than a machine word. */
8461 if ((mclass == MODE_FLOAT
8462 || ((mclass == MODE_INT || mclass == MODE_PARTIAL_INT)
8463 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8464 && align >= GET_MODE_ALIGNMENT (mode))
8467 /* For the moment, also allow anything that has an alignment equal to its
8468 size and which is smaller than a word. */
8470 && TREE_CODE (size) == INTEGER_CST
8471 && compare_tree_int (size, align) == 0
8472 && align <= BITS_PER_WORD)
8475 for (gnat_node = First_Rep_Item (gnat_entity);
8476 Present (gnat_node);
8477 gnat_node = Next_Rep_Item (gnat_node))
8478 if (Nkind (gnat_node) == N_Pragma)
8480 unsigned char pragma_id
8481 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
8483 if ((pragma_id == Pragma_Atomic && !component_p)
8484 || (pragma_id == Pragma_Atomic_Components && component_p))
8486 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8492 post_error_ne ("atomic access to component of & cannot be guaranteed",
8493 gnat_error_point, gnat_entity);
8494 else if (Is_Volatile_Full_Access (gnat_entity))
8495 post_error_ne ("volatile full access to & cannot be guaranteed",
8496 gnat_error_point, gnat_entity);
8498 post_error_ne ("atomic access to & cannot be guaranteed",
8499 gnat_error_point, gnat_entity);
8503 /* Helper for the intrin compatibility checks family. Evaluate whether
8504 two types are definitely incompatible. */
8507 intrin_types_incompatible_p (tree t1, tree t2)
8509 enum tree_code code;
8511 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8514 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8517 if (TREE_CODE (t1) != TREE_CODE (t2))
8520 code = TREE_CODE (t1);
8526 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8529 case REFERENCE_TYPE:
8530 /* Assume designated types are ok. We'd need to account for char * and
8531 void * variants to do better, which could rapidly get messy and isn't
8532 clearly worth the effort. */
8542 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8543 on the Ada/builtin argument lists for the INB binding. */
8546 intrin_arglists_compatible_p (intrin_binding_t * inb)
8548 function_args_iterator ada_iter, btin_iter;
8550 function_args_iter_init (&ada_iter, inb->ada_fntype);
8551 function_args_iter_init (&btin_iter, inb->btin_fntype);
8553 /* Sequence position of the last argument we checked. */
8558 tree ada_type = function_args_iter_cond (&ada_iter);
8559 tree btin_type = function_args_iter_cond (&btin_iter);
8561 /* If we've exhausted both lists simultaneously, we're done. */
8562 if (!ada_type && !btin_type)
8565 /* If one list is shorter than the other, they fail to match. */
8566 if (!ada_type || !btin_type)
8569 /* If we're done with the Ada args and not with the internal builtin
8570 args, or the other way around, complain. */
8571 if (ada_type == void_type_node
8572 && btin_type != void_type_node)
8574 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8578 if (btin_type == void_type_node
8579 && ada_type != void_type_node)
8581 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8582 inb->gnat_entity, inb->gnat_entity, argpos);
8586 /* Otherwise, check that types match for the current argument. */
8588 if (intrin_types_incompatible_p (ada_type, btin_type))
8590 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8591 inb->gnat_entity, inb->gnat_entity, argpos);
8596 function_args_iter_next (&ada_iter);
8597 function_args_iter_next (&btin_iter);
8603 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8604 on the Ada/builtin return values for the INB binding. */
8607 intrin_return_compatible_p (intrin_binding_t * inb)
8609 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8610 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8612 /* Accept function imported as procedure, common and convenient. */
8613 if (VOID_TYPE_P (ada_return_type)
8614 && !VOID_TYPE_P (btin_return_type))
8617 /* If return type is Address (integer type), map it to void *. */
8618 if (Is_Descendent_Of_Address (Etype (inb->gnat_entity)))
8619 ada_return_type = ptr_type_node;
8621 /* Check return types compatibility otherwise. Note that this
8622 handles void/void as well. */
8623 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8625 post_error ("?intrinsic binding type mismatch on return value!",
8633 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8634 compatible. Issue relevant warnings when they are not.
8636 This is intended as a light check to diagnose the most obvious cases, not
8637 as a full fledged type compatibility predicate. It is the programmer's
8638 responsibility to ensure correctness of the Ada declarations in Imports,
8639 especially when binding straight to a compiler internal. */
8642 intrin_profiles_compatible_p (intrin_binding_t * inb)
8644 /* Check compatibility on return values and argument lists, each responsible
8645 for posting warnings as appropriate. Ensure use of the proper sloc for
8648 bool arglists_compatible_p, return_compatible_p;
8649 location_t saved_location = input_location;
8651 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8653 return_compatible_p = intrin_return_compatible_p (inb);
8654 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8656 input_location = saved_location;
8658 return return_compatible_p && arglists_compatible_p;
8661 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8662 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8663 specified size for this field. POS_LIST is a position list describing
8664 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8668 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8669 tree size, tree pos_list,
8670 vec<subst_pair> subst_list)
8672 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8673 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8674 unsigned int offset_align = tree_to_uhwi (TREE_VEC_ELT (t, 1));
8675 tree new_pos, new_field;
8679 if (CONTAINS_PLACEHOLDER_P (pos))
8680 FOR_EACH_VEC_ELT (subst_list, i, s)
8681 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8683 /* If the position is now a constant, we can set it as the position of the
8684 field when we make it. Otherwise, we need to deal with it specially. */
8685 if (TREE_CONSTANT (pos))
8686 new_pos = bit_from_pos (pos, bitpos);
8688 new_pos = NULL_TREE;
8691 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8692 size, new_pos, DECL_PACKED (old_field),
8693 !DECL_NONADDRESSABLE_P (old_field));
8697 normalize_offset (&pos, &bitpos, offset_align);
8698 /* Finalize the position. */
8699 DECL_FIELD_OFFSET (new_field) = variable_size (pos);
8700 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8701 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8702 DECL_SIZE (new_field) = size;
8703 DECL_SIZE_UNIT (new_field)
8704 = convert (sizetype,
8705 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8706 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8709 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8710 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8711 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8712 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8717 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
8718 it is the minimal size the REP_PART must have. */
8721 create_rep_part (tree rep_type, tree record_type, tree min_size)
8725 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
8726 min_size = NULL_TREE;
8728 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
8729 min_size, NULL_TREE, 0, 1);
8730 DECL_INTERNAL_P (field) = 1;
8735 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8738 get_rep_part (tree record_type)
8740 tree field = TYPE_FIELDS (record_type);
8742 /* The REP part is the first field, internal, another record, and its name
8743 starts with an 'R'. */
8745 && DECL_INTERNAL_P (field)
8746 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8747 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
8753 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8756 get_variant_part (tree record_type)
8760 /* The variant part is the only internal field that is a qualified union. */
8761 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8762 if (DECL_INTERNAL_P (field)
8763 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8769 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8770 the list of variants to be used and RECORD_TYPE is the type of the parent.
8771 POS_LIST is a position list describing the layout of fields present in
8772 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8776 create_variant_part_from (tree old_variant_part,
8777 vec<variant_desc> variant_list,
8778 tree record_type, tree pos_list,
8779 vec<subst_pair> subst_list)
8781 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8782 tree old_union_type = TREE_TYPE (old_variant_part);
8783 tree new_union_type, new_variant_part;
8784 tree union_field_list = NULL_TREE;
8788 /* First create the type of the variant part from that of the old one. */
8789 new_union_type = make_node (QUAL_UNION_TYPE);
8790 TYPE_NAME (new_union_type)
8791 = concat_name (TYPE_NAME (record_type),
8792 IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
8794 /* If the position of the variant part is constant, subtract it from the
8795 size of the type of the parent to get the new size. This manual CSE
8796 reduces the code size when not optimizing. */
8797 if (TREE_CODE (offset) == INTEGER_CST)
8799 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8800 tree first_bit = bit_from_pos (offset, bitpos);
8801 TYPE_SIZE (new_union_type)
8802 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8803 TYPE_SIZE_UNIT (new_union_type)
8804 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8805 byte_from_pos (offset, bitpos));
8806 SET_TYPE_ADA_SIZE (new_union_type,
8807 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8809 SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
8810 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8813 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8815 /* Now finish up the new variants and populate the union type. */
8816 FOR_EACH_VEC_ELT_REVERSE (variant_list, i, v)
8818 tree old_field = v->field, new_field;
8819 tree old_variant, old_variant_subpart, new_variant, field_list;
8821 /* Skip variants that don't belong to this nesting level. */
8822 if (DECL_CONTEXT (old_field) != old_union_type)
8825 /* Retrieve the list of fields already added to the new variant. */
8826 new_variant = v->new_type;
8827 field_list = TYPE_FIELDS (new_variant);
8829 /* If the old variant had a variant subpart, we need to create a new
8830 variant subpart and add it to the field list. */
8831 old_variant = v->type;
8832 old_variant_subpart = get_variant_part (old_variant);
8833 if (old_variant_subpart)
8835 tree new_variant_subpart
8836 = create_variant_part_from (old_variant_subpart, variant_list,
8837 new_variant, pos_list, subst_list);
8838 DECL_CHAIN (new_variant_subpart) = field_list;
8839 field_list = new_variant_subpart;
8842 /* Finish up the new variant and create the field. No need for debug
8843 info thanks to the XVS type. */
8844 finish_record_type (new_variant, nreverse (field_list), 2, false);
8845 compute_record_mode (new_variant);
8846 create_type_decl (TYPE_NAME (new_variant), new_variant, true, false,
8850 = create_field_decl_from (old_field, new_variant, new_union_type,
8851 TYPE_SIZE (new_variant),
8852 pos_list, subst_list);
8853 DECL_QUALIFIER (new_field) = v->qual;
8854 DECL_INTERNAL_P (new_field) = 1;
8855 DECL_CHAIN (new_field) = union_field_list;
8856 union_field_list = new_field;
8859 /* Finish up the union type and create the variant part. No need for debug
8860 info thanks to the XVS type. Note that we don't reverse the field list
8861 because VARIANT_LIST has been traversed in reverse order. */
8862 finish_record_type (new_union_type, union_field_list, 2, false);
8863 compute_record_mode (new_union_type);
8864 create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, false,
8868 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8869 TYPE_SIZE (new_union_type),
8870 pos_list, subst_list);
8871 DECL_INTERNAL_P (new_variant_part) = 1;
8873 /* With multiple discriminants it is possible for an inner variant to be
8874 statically selected while outer ones are not; in this case, the list
8875 of fields of the inner variant is not flattened and we end up with a
8876 qualified union with a single member. Drop the useless container. */
8877 if (!DECL_CHAIN (union_field_list))
8879 DECL_CONTEXT (union_field_list) = record_type;
8880 DECL_FIELD_OFFSET (union_field_list)
8881 = DECL_FIELD_OFFSET (new_variant_part);
8882 DECL_FIELD_BIT_OFFSET (union_field_list)
8883 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8884 SET_DECL_OFFSET_ALIGN (union_field_list,
8885 DECL_OFFSET_ALIGN (new_variant_part));
8886 new_variant_part = union_field_list;
8889 return new_variant_part;
8892 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8893 which are both RECORD_TYPE, after applying the substitutions described
8897 copy_and_substitute_in_size (tree new_type, tree old_type,
8898 vec<subst_pair> subst_list)
8903 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8904 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8905 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8906 SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
8907 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8909 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8910 FOR_EACH_VEC_ELT (subst_list, i, s)
8911 TYPE_SIZE (new_type)
8912 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8913 s->discriminant, s->replacement);
8915 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8916 FOR_EACH_VEC_ELT (subst_list, i, s)
8917 TYPE_SIZE_UNIT (new_type)
8918 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8919 s->discriminant, s->replacement);
8921 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8922 FOR_EACH_VEC_ELT (subst_list, i, s)
8924 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8925 s->discriminant, s->replacement));
8927 /* Finalize the size. */
8928 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8929 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8932 /* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
8933 the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
8934 the original array type if it has been translated. This association is a
8935 parallel type for GNAT encodings or a debug type for standard DWARF. Note
8936 that for standard DWARF, we also want to get the original type name. */
8939 associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
8941 Entity_Id gnat_original_array_type
8942 = Underlying_Type (Original_Array_Type (gnat_entity));
8943 tree gnu_original_array_type;
8945 if (!present_gnu_tree (gnat_original_array_type))
8948 gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
8950 if (TYPE_IS_DUMMY_P (gnu_original_array_type))
8953 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
8955 tree original_name = TYPE_NAME (gnu_original_array_type);
8957 if (TREE_CODE (original_name) == TYPE_DECL)
8958 original_name = DECL_NAME (original_name);
8960 SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
8961 TYPE_NAME (gnu_type) = original_name;
8964 add_parallel_type (gnu_type, gnu_original_array_type);
8967 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8968 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8969 updated by replacing F with R.
8971 The function doesn't update the layout of the type, i.e. it assumes
8972 that the substitution is purely formal. That's why the replacement
8973 value R must itself contain a PLACEHOLDER_EXPR. */
8976 substitute_in_type (tree t, tree f, tree r)
8980 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8982 switch (TREE_CODE (t))
8989 /* First the domain types of arrays. */
8990 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8991 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8993 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8994 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8996 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
9000 TYPE_GCC_MIN_VALUE (nt) = low;
9001 TYPE_GCC_MAX_VALUE (nt) = high;
9003 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
9005 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
9010 /* Then the subtypes. */
9011 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
9012 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
9014 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
9015 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
9017 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
9021 SET_TYPE_RM_MIN_VALUE (nt, low);
9022 SET_TYPE_RM_MAX_VALUE (nt, high);
9030 nt = substitute_in_type (TREE_TYPE (t), f, r);
9031 if (nt == TREE_TYPE (t))
9034 return build_complex_type (nt);
9037 /* These should never show up here. */
9042 tree component = substitute_in_type (TREE_TYPE (t), f, r);
9043 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
9045 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
9048 nt = build_nonshared_array_type (component, domain);
9049 SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
9050 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
9051 SET_TYPE_MODE (nt, TYPE_MODE (t));
9052 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9053 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9054 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
9055 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
9056 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
9062 case QUAL_UNION_TYPE:
9064 bool changed_field = false;
9067 /* Start out with no fields, make new fields, and chain them
9068 in. If we haven't actually changed the type of any field,
9069 discard everything we've done and return the old type. */
9071 TYPE_FIELDS (nt) = NULL_TREE;
9073 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
9075 tree new_field = copy_node (field), new_n;
9077 new_n = substitute_in_type (TREE_TYPE (field), f, r);
9078 if (new_n != TREE_TYPE (field))
9080 TREE_TYPE (new_field) = new_n;
9081 changed_field = true;
9084 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
9085 if (new_n != DECL_FIELD_OFFSET (field))
9087 DECL_FIELD_OFFSET (new_field) = new_n;
9088 changed_field = true;
9091 /* Do the substitution inside the qualifier, if any. */
9092 if (TREE_CODE (t) == QUAL_UNION_TYPE)
9094 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
9095 if (new_n != DECL_QUALIFIER (field))
9097 DECL_QUALIFIER (new_field) = new_n;
9098 changed_field = true;
9102 DECL_CONTEXT (new_field) = nt;
9103 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
9105 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
9106 TYPE_FIELDS (nt) = new_field;
9112 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
9113 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9114 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9115 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
9124 /* Return the RM size of GNU_TYPE. This is the actual number of bits
9125 needed to represent the object. */
9128 rm_size (tree gnu_type)
9130 /* For integral types, we store the RM size explicitly. */
9131 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
9132 return TYPE_RM_SIZE (gnu_type);
9134 /* Return the RM size of the actual data plus the size of the template. */
9135 if (TREE_CODE (gnu_type) == RECORD_TYPE
9136 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9138 size_binop (PLUS_EXPR,
9139 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
9140 DECL_SIZE (TYPE_FIELDS (gnu_type)));
9142 /* For record or union types, we store the size explicitly. */
9143 if (RECORD_OR_UNION_TYPE_P (gnu_type)
9144 && !TYPE_FAT_POINTER_P (gnu_type)
9145 && TYPE_ADA_SIZE (gnu_type))
9146 return TYPE_ADA_SIZE (gnu_type);
9148 /* For other types, this is just the size. */
9149 return TYPE_SIZE (gnu_type);
9152 /* Return the name to be used for GNAT_ENTITY. If a type, create a
9153 fully-qualified name, possibly with type information encoding.
9154 Otherwise, return the name. */
9157 get_entity_char (Entity_Id gnat_entity)
9159 Get_Encoded_Name (gnat_entity);
9160 return ggc_strdup (Name_Buffer);
9164 get_entity_name (Entity_Id gnat_entity)
9166 Get_Encoded_Name (gnat_entity);
9167 return get_identifier_with_length (Name_Buffer, Name_Len);
9170 /* Return an identifier representing the external name to be used for
9171 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
9172 and the specified suffix. */
9175 create_concat_name (Entity_Id gnat_entity, const char *suffix)
9177 const Entity_Kind kind = Ekind (gnat_entity);
9178 const bool has_suffix = (suffix != NULL);
9179 String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
9180 String_Pointer sp = {suffix, &temp};
9182 Get_External_Name (gnat_entity, has_suffix, sp);
9184 /* A variable using the Stdcall convention lives in a DLL. We adjust
9185 its name to use the jump table, the _imp__NAME contains the address
9186 for the NAME variable. */
9187 if ((kind == E_Variable || kind == E_Constant)
9188 && Has_Stdcall_Convention (gnat_entity))
9190 const int len = strlen (STDCALL_PREFIX) + Name_Len;
9191 char *new_name = (char *) alloca (len + 1);
9192 strcpy (new_name, STDCALL_PREFIX);
9193 strcat (new_name, Name_Buffer);
9194 return get_identifier_with_length (new_name, len);
9197 return get_identifier_with_length (Name_Buffer, Name_Len);
9200 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9201 string, return a new IDENTIFIER_NODE that is the concatenation of
9202 the name followed by "___" and the specified suffix. */
9205 concat_name (tree gnu_name, const char *suffix)
9207 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
9208 char *new_name = (char *) alloca (len + 1);
9209 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
9210 strcat (new_name, "___");
9211 strcat (new_name, suffix);
9212 return get_identifier_with_length (new_name, len);
9215 /* Initialize data structures of the decl.c module. */
9218 init_gnat_decl (void)
9220 /* Initialize the cache of annotated values. */
9221 annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
9224 /* Destroy data structures of the decl.c module. */
9227 destroy_gnat_decl (void)
9229 /* Destroy the cache of annotated values. */
9230 annotate_value_cache->empty ();
9231 annotate_value_cache = NULL;
9234 #include "gt-ada-decl.h"