1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2014, 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 "stor-layout.h"
37 #include "tree-inline.h"
38 #include "diagnostic-core.h"
56 /* "stdcall" and "thiscall" conventions should be processed in a specific way
57 on 32-bit x86/Windows only. The macros below are helpers to avoid having
58 to check for a Windows specific attribute throughout this unit. */
60 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
62 #define Has_Stdcall_Convention(E) \
63 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
64 #define Has_Thiscall_Convention(E) \
65 (!TARGET_64BIT && is_cplusplus_method (E))
67 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
68 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
71 #define Has_Stdcall_Convention(E) 0
72 #define Has_Thiscall_Convention(E) 0
75 #define STDCALL_PREFIX "_imp__"
77 /* Stack realignment is necessary for functions with foreign conventions when
78 the ABI doesn't mandate as much as what the compiler assumes - that is, up
79 to PREFERRED_STACK_BOUNDARY.
81 Such realignment can be requested with a dedicated function type attribute
82 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
83 characterize the situations where the attribute should be set. We rely on
84 compiler configuration settings for 'main' to decide. */
86 #ifdef MAIN_STACK_BOUNDARY
87 #define FOREIGN_FORCE_REALIGN_STACK \
88 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
90 #define FOREIGN_FORCE_REALIGN_STACK 0
95 struct incomplete *next;
100 /* These variables are used to defer recursively expanding incomplete types
101 while we are processing an array, a record or a subprogram type. */
102 static int defer_incomplete_level = 0;
103 static struct incomplete *defer_incomplete_list;
105 /* This variable is used to delay expanding From_Limited_With types until the
107 static struct incomplete *defer_limited_with;
109 typedef struct subst_pair_d {
115 typedef struct variant_desc_d {
116 /* The type of the variant. */
119 /* The associated field. */
122 /* The value of the qualifier. */
125 /* The type of the variant after transformation. */
130 /* A hash table used to cache the result of annotate_value. */
131 static GTY ((if_marked ("tree_int_map_marked_p"),
132 param_is (struct tree_int_map))) htab_t annotate_value_cache;
134 static bool allocatable_size_p (tree, bool);
135 static void prepend_one_attribute (struct attrib **,
136 enum attr_type, tree, tree, Node_Id);
137 static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
138 static void prepend_attributes (struct attrib **, Entity_Id);
139 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
140 static bool type_has_variable_size (tree);
141 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
142 static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool,
144 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
145 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
147 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
148 static tree change_qualified_type (tree, int);
149 static bool same_discriminant_p (Entity_Id, Entity_Id);
150 static bool array_type_has_nonaliased_component (tree, Entity_Id);
151 static bool compile_time_known_address_p (Node_Id);
152 static bool cannot_be_superflat_p (Node_Id);
153 static bool constructor_address_p (tree);
154 static int compare_field_bitpos (const PTR, const PTR);
155 static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
156 bool, bool, bool, bool, bool, tree, tree *);
157 static Uint annotate_value (tree);
158 static void annotate_rep (Entity_Id, tree);
159 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
160 static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
161 static vec<variant_desc> build_variant_list (tree,
164 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
165 static void set_rm_size (Uint, tree, Entity_Id);
166 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
167 static void check_ok_for_atomic (tree, Entity_Id, bool);
168 static tree create_field_decl_from (tree, tree, tree, tree, tree,
170 static tree create_rep_part (tree, tree, tree);
171 static tree get_rep_part (tree);
172 static tree create_variant_part_from (tree, vec<variant_desc> , tree,
173 tree, vec<subst_pair> );
174 static void copy_and_substitute_in_size (tree, tree, vec<subst_pair> );
176 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
177 to pass around calls performing profile compatibility checks. */
180 Entity_Id gnat_entity; /* The Ada subprogram entity. */
181 tree ada_fntype; /* The corresponding GCC type node. */
182 tree btin_fntype; /* The GCC builtin function type node. */
185 static bool intrin_profiles_compatible_p (intrin_binding_t *);
187 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
188 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
189 and associate the ..._DECL node with the input GNAT defining identifier.
191 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
192 initial value (in GCC tree form). This is optional for a variable. For
193 a renamed entity, GNU_EXPR gives the object being renamed.
195 DEFINITION is nonzero if this call is intended for a definition. This is
196 used for separate compilation where it is necessary to know whether an
197 external declaration or a definition must be created if the GCC equivalent
198 was not created previously. The value of 1 is normally used for a nonzero
199 DEFINITION, but a value of 2 is used in special circumstances, defined in
203 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
205 /* Contains the kind of the input GNAT node. */
206 const Entity_Kind kind = Ekind (gnat_entity);
207 /* True if this is a type. */
208 const bool is_type = IN (kind, Type_Kind);
209 /* True if debug info is requested for this entity. */
210 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
211 /* True if this entity is to be considered as imported. */
212 const bool imported_p
213 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
214 /* For a type, contains the equivalent GNAT node to be used in gigi. */
215 Entity_Id gnat_equiv_type = Empty;
216 /* Temporary used to walk the GNAT tree. */
218 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
219 This node will be associated with the GNAT node by calling at the end
220 of the `switch' statement. */
221 tree gnu_decl = NULL_TREE;
222 /* Contains the GCC type to be used for the GCC node. */
223 tree gnu_type = NULL_TREE;
224 /* Contains the GCC size tree to be used for the GCC node. */
225 tree gnu_size = NULL_TREE;
226 /* Contains the GCC name to be used for the GCC node. */
227 tree gnu_entity_name;
228 /* True if we have already saved gnu_decl as a GNAT association. */
230 /* True if we incremented defer_incomplete_level. */
231 bool this_deferred = false;
232 /* True if we incremented force_global. */
233 bool this_global = false;
234 /* True if we should check to see if elaborated during processing. */
235 bool maybe_present = false;
236 /* True if we made GNU_DECL and its type here. */
237 bool this_made_decl = false;
238 /* Size and alignment of the GCC node, if meaningful. */
239 unsigned int esize = 0, align = 0;
240 /* Contains the list of attributes directly attached to the entity. */
241 struct attrib *attr_list = NULL;
243 /* Since a use of an Itype is a definition, process it as such if it
244 is not in a with'ed unit. */
247 && Is_Itype (gnat_entity)
248 && !present_gnu_tree (gnat_entity)
249 && In_Extended_Main_Code_Unit (gnat_entity))
251 /* Ensure that we are in a subprogram mentioned in the Scope chain of
252 this entity, our current scope is global, or we encountered a task
253 or entry (where we can't currently accurately check scoping). */
254 if (!current_function_decl
255 || DECL_ELABORATION_PROC_P (current_function_decl))
257 process_type (gnat_entity);
258 return get_gnu_tree (gnat_entity);
261 for (gnat_temp = Scope (gnat_entity);
263 gnat_temp = Scope (gnat_temp))
265 if (Is_Type (gnat_temp))
266 gnat_temp = Underlying_Type (gnat_temp);
268 if (Ekind (gnat_temp) == E_Subprogram_Body)
270 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
272 if (IN (Ekind (gnat_temp), Subprogram_Kind)
273 && Present (Protected_Body_Subprogram (gnat_temp)))
274 gnat_temp = Protected_Body_Subprogram (gnat_temp);
276 if (Ekind (gnat_temp) == E_Entry
277 || Ekind (gnat_temp) == E_Entry_Family
278 || Ekind (gnat_temp) == E_Task_Type
279 || (IN (Ekind (gnat_temp), Subprogram_Kind)
280 && present_gnu_tree (gnat_temp)
281 && (current_function_decl
282 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
284 process_type (gnat_entity);
285 return get_gnu_tree (gnat_entity);
289 /* This abort means the Itype has an incorrect scope, i.e. that its
290 scope does not correspond to the subprogram it is declared in. */
294 /* If we've already processed this entity, return what we got last time.
295 If we are defining the node, we should not have already processed it.
296 In that case, we will abort below when we try to save a new GCC tree
297 for this object. We also need to handle the case of getting a dummy
298 type when a Full_View exists but be careful so as not to trigger its
299 premature elaboration. */
300 if ((!definition || (is_type && imported_p))
301 && present_gnu_tree (gnat_entity))
303 gnu_decl = get_gnu_tree (gnat_entity);
305 if (TREE_CODE (gnu_decl) == TYPE_DECL
306 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
307 && IN (kind, Incomplete_Or_Private_Kind)
308 && Present (Full_View (gnat_entity))
309 && (present_gnu_tree (Full_View (gnat_entity))
310 || No (Freeze_Node (Full_View (gnat_entity)))))
313 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
314 save_gnu_tree (gnat_entity, NULL_TREE, false);
315 save_gnu_tree (gnat_entity, gnu_decl, false);
321 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
322 must be specified unless it was specified by the programmer. Exceptions
323 are for access-to-protected-subprogram types and all access subtypes, as
324 another GNAT type is used to lay out the GCC type for them. */
325 gcc_assert (!Unknown_Esize (gnat_entity)
326 || Has_Size_Clause (gnat_entity)
327 || (!IN (kind, Numeric_Kind)
328 && !IN (kind, Enumeration_Kind)
329 && (!IN (kind, Access_Kind)
330 || kind == E_Access_Protected_Subprogram_Type
331 || kind == E_Anonymous_Access_Protected_Subprogram_Type
332 || kind == E_Access_Subtype
333 || type_annotate_only)));
335 /* The RM size must be specified for all discrete and fixed-point types. */
336 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
337 && Unknown_RM_Size (gnat_entity)));
339 /* If we get here, it means we have not yet done anything with this entity.
340 If we are not defining it, it must be a type or an entity that is defined
341 elsewhere or externally, otherwise we should have defined it already. */
342 gcc_assert (definition
343 || type_annotate_only
345 || kind == E_Discriminant
346 || kind == E_Component
348 || (kind == E_Constant && Present (Full_View (gnat_entity)))
349 || Is_Public (gnat_entity));
351 /* Get the name of the entity and set up the line number and filename of
352 the original definition for use in any decl we make. */
353 gnu_entity_name = get_entity_name (gnat_entity);
354 Sloc_to_locus (Sloc (gnat_entity), &input_location);
356 /* For cases when we are not defining (i.e., we are referencing from
357 another compilation unit) public entities, show we are at global level
358 for the purpose of computing scopes. Don't do this for components or
359 discriminants since the relevant test is whether or not the record is
362 && kind != E_Component
363 && kind != E_Discriminant
364 && Is_Public (gnat_entity)
365 && !Is_Statically_Allocated (gnat_entity))
366 force_global++, this_global = true;
368 /* Handle any attributes directly attached to the entity. */
369 if (Has_Gigi_Rep_Item (gnat_entity))
370 prepend_attributes (&attr_list, gnat_entity);
372 /* Do some common processing for types. */
375 /* Compute the equivalent type to be used in gigi. */
376 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
378 /* Machine_Attributes on types are expected to be propagated to
379 subtypes. The corresponding Gigi_Rep_Items are only attached
380 to the first subtype though, so we handle the propagation here. */
381 if (Base_Type (gnat_entity) != gnat_entity
382 && !Is_First_Subtype (gnat_entity)
383 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
384 prepend_attributes (&attr_list,
385 First_Subtype (Base_Type (gnat_entity)));
387 /* Compute a default value for the size of an elementary type. */
388 if (Known_Esize (gnat_entity) && Is_Elementary_Type (gnat_entity))
390 unsigned int max_esize;
392 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity)));
393 esize = UI_To_Int (Esize (gnat_entity));
395 if (IN (kind, Float_Kind))
396 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
397 else if (IN (kind, Access_Kind))
398 max_esize = POINTER_SIZE * 2;
400 max_esize = LONG_LONG_TYPE_SIZE;
402 if (esize > max_esize)
410 /* If this is a use of a deferred constant without address clause,
411 get its full definition. */
413 && No (Address_Clause (gnat_entity))
414 && Present (Full_View (gnat_entity)))
417 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
422 /* If we have an external constant that we are not defining, get the
423 expression that is was defined to represent. We may throw it away
424 later if it is not a constant. But do not retrieve the expression
425 if it is an allocator because the designated type might be dummy
428 && !No_Initialization (Declaration_Node (gnat_entity))
429 && Present (Expression (Declaration_Node (gnat_entity)))
430 && Nkind (Expression (Declaration_Node (gnat_entity)))
433 bool went_into_elab_proc = false;
434 int save_force_global = force_global;
436 /* The expression may contain N_Expression_With_Actions nodes and
437 thus object declarations from other units. In this case, even
438 though the expression will eventually be discarded since not a
439 constant, the declarations would be stuck either in the global
440 varpool or in the current scope. Therefore we force the local
441 context and create a fake scope that we'll zap at the end. */
442 if (!current_function_decl)
444 current_function_decl = get_elaboration_procedure ();
445 went_into_elab_proc = true;
450 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
453 force_global = save_force_global;
454 if (went_into_elab_proc)
455 current_function_decl = NULL_TREE;
458 /* Ignore deferred constant definitions without address clause since
459 they are processed fully in the front-end. If No_Initialization
460 is set, this is not a deferred constant but a constant whose value
461 is built manually. And constants that are renamings are handled
465 && No (Address_Clause (gnat_entity))
466 && !No_Initialization (Declaration_Node (gnat_entity))
467 && No (Renamed_Object (gnat_entity)))
469 gnu_decl = error_mark_node;
474 /* Ignore constant definitions already marked with the error node. See
475 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
478 && present_gnu_tree (gnat_entity)
479 && get_gnu_tree (gnat_entity) == error_mark_node)
481 maybe_present = true;
488 /* We used to special case VMS exceptions here to directly map them to
489 their associated condition code. Since this code had to be masked
490 dynamically to strip off the severity bits, this caused trouble in
491 the GCC/ZCX case because the "type" pointers we store in the tables
492 have to be static. We now don't special case here anymore, and let
493 the regular processing take place, which leaves us with a regular
494 exception data object for VMS exceptions too. The condition code
495 mapping is taken care of by the front end and the bitmasking by the
502 /* The GNAT record where the component was defined. */
503 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
505 /* If the entity is an inherited component (in the case of extended
506 tagged record types), just return the original entity, which must
507 be a FIELD_DECL. Likewise for discriminants. If the entity is a
508 non-girder discriminant (in the case of derived untagged record
509 types), return the stored discriminant it renames. */
510 if (Present (Original_Record_Component (gnat_entity))
511 && Original_Record_Component (gnat_entity) != gnat_entity)
514 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
515 gnu_expr, definition);
520 /* If this is a discriminant of an extended tagged type used to rename
521 a discriminant of the parent type, return the latter. */
522 else if (Present (Corresponding_Discriminant (gnat_entity)))
524 /* If the derived type is untagged, then this is a non-girder
525 discriminant and its Original_Record_Component must point to
526 the stored discriminant it renames (i.e. we should have taken
527 the previous branch). */
528 gcc_assert (Is_Tagged_Type (gnat_record));
531 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
532 gnu_expr, definition);
537 /* Otherwise, if we are not defining this and we have no GCC type
538 for the containing record, make one for it. Then we should
539 have made our own equivalent. */
540 else if (!definition && !present_gnu_tree (gnat_record))
542 /* ??? If this is in a record whose scope is a protected
543 type and we have an Original_Record_Component, use it.
544 This is a workaround for major problems in protected type
546 Entity_Id Scop = Scope (Scope (gnat_entity));
547 if (Is_Protected_Type (Underlying_Type (Scop))
548 && Present (Original_Record_Component (gnat_entity)))
551 = gnat_to_gnu_entity (Original_Record_Component
558 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
559 gnu_decl = get_gnu_tree (gnat_entity);
565 /* Here we have no GCC type and this is a reference rather than a
566 definition. This should never happen. Most likely the cause is
567 reference before declaration in the GNAT tree for gnat_entity. */
571 case E_Loop_Parameter:
572 case E_Out_Parameter:
575 /* Simple variables, loop variables, Out parameters and exceptions. */
578 /* Always create a variable for volatile objects and variables seen
579 constant but with a Linker_Section pragma. */
581 = ((kind == E_Constant || kind == E_Variable)
582 && Is_True_Constant (gnat_entity)
583 && !(kind == E_Variable
584 && Present (Linker_Section_Pragma (gnat_entity)))
585 && !Treat_As_Volatile (gnat_entity)
586 && (((Nkind (Declaration_Node (gnat_entity))
587 == N_Object_Declaration)
588 && Present (Expression (Declaration_Node (gnat_entity))))
589 || Present (Renamed_Object (gnat_entity))
591 bool inner_const_flag = const_flag;
592 bool static_p = Is_Statically_Allocated (gnat_entity);
593 bool mutable_p = false;
594 bool used_by_ref = false;
595 tree gnu_ext_name = NULL_TREE;
596 tree renamed_obj = NULL_TREE;
597 tree gnu_object_size;
599 if (Present (Renamed_Object (gnat_entity)) && !definition)
601 if (kind == E_Exception)
602 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
605 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
608 /* Get the type after elaborating the renamed object. */
609 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
611 /* If this is a standard exception definition, then use the standard
612 exception type. This is necessary to make sure that imported and
613 exported views of exceptions are properly merged in LTO mode. */
614 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
615 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
616 gnu_type = except_type_node;
618 /* For a debug renaming declaration, build a debug-only entity. */
619 if (Present (Debug_Renaming_Link (gnat_entity)))
621 /* Force a non-null value to make sure the symbol is retained. */
622 tree value = build1 (INDIRECT_REF, gnu_type,
624 build_pointer_type (gnu_type),
625 integer_minus_one_node));
626 gnu_decl = build_decl (input_location,
627 VAR_DECL, gnu_entity_name, gnu_type);
628 SET_DECL_VALUE_EXPR (gnu_decl, value);
629 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
630 gnat_pushdecl (gnu_decl, gnat_entity);
634 /* If this is a loop variable, its type should be the base type.
635 This is because the code for processing a loop determines whether
636 a normal loop end test can be done by comparing the bounds of the
637 loop against those of the base type, which is presumed to be the
638 size used for computation. But this is not correct when the size
639 of the subtype is smaller than the type. */
640 if (kind == E_Loop_Parameter)
641 gnu_type = get_base_type (gnu_type);
643 /* Reject non-renamed objects whose type is an unconstrained array or
644 any object whose type is a dummy type or void. */
645 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
646 && No (Renamed_Object (gnat_entity)))
647 || TYPE_IS_DUMMY_P (gnu_type)
648 || TREE_CODE (gnu_type) == VOID_TYPE)
650 gcc_assert (type_annotate_only);
653 return error_mark_node;
656 /* If an alignment is specified, use it if valid. Note that exceptions
657 are objects but don't have an alignment. We must do this before we
658 validate the size, since the alignment can affect the size. */
659 if (kind != E_Exception && Known_Alignment (gnat_entity))
661 gcc_assert (Present (Alignment (gnat_entity)));
663 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
664 TYPE_ALIGN (gnu_type));
666 /* No point in changing the type if there is an address clause
667 as the final type of the object will be a reference type. */
668 if (Present (Address_Clause (gnat_entity)))
672 tree orig_type = gnu_type;
675 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
676 false, false, definition, true);
678 /* If a padding record was made, declare it now since it will
679 never be declared otherwise. This is necessary to ensure
680 that its subtrees are properly marked. */
681 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
682 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
683 debug_info_p, gnat_entity);
687 /* If we are defining the object, see if it has a Size and validate it
688 if so. If we are not defining the object and a Size clause applies,
689 simply retrieve the value. We don't want to ignore the clause and
690 it is expected to have been validated already. Then get the new
693 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
694 gnat_entity, VAR_DECL, false,
695 Has_Size_Clause (gnat_entity));
696 else if (Has_Size_Clause (gnat_entity))
697 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
702 = make_type_from_size (gnu_type, gnu_size,
703 Has_Biased_Representation (gnat_entity));
705 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
706 gnu_size = NULL_TREE;
709 /* If this object has self-referential size, it must be a record with
710 a default discriminant. We are supposed to allocate an object of
711 the maximum size in this case, unless it is a constant with an
712 initializing expression, in which case we can get the size from
713 that. Note that the resulting size may still be a variable, so
714 this may end up with an indirect allocation. */
715 if (No (Renamed_Object (gnat_entity))
716 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
718 if (gnu_expr && kind == E_Constant)
720 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
721 if (CONTAINS_PLACEHOLDER_P (size))
723 /* If the initializing expression is itself a constant,
724 despite having a nominal type with self-referential
725 size, we can get the size directly from it. */
726 if (TREE_CODE (gnu_expr) == COMPONENT_REF
728 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
729 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
730 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
731 || DECL_READONLY_ONCE_ELAB
732 (TREE_OPERAND (gnu_expr, 0))))
733 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
736 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
741 /* We may have no GNU_EXPR because No_Initialization is
742 set even though there's an Expression. */
743 else if (kind == E_Constant
744 && (Nkind (Declaration_Node (gnat_entity))
745 == N_Object_Declaration)
746 && Present (Expression (Declaration_Node (gnat_entity))))
748 = TYPE_SIZE (gnat_to_gnu_type
750 (Expression (Declaration_Node (gnat_entity)))));
753 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
757 /* If we are at global level and the size isn't constant, call
758 elaborate_expression_1 to make a variable for it rather than
759 calculating it each time. */
760 if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
761 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
762 get_identifier ("SIZE"),
766 /* If the size is zero byte, make it one byte since some linkers have
767 troubles with zero-sized objects. If the object will have a
768 template, that will make it nonzero so don't bother. Also avoid
769 doing that for an object renaming or an object with an address
770 clause, as we would lose useful information on the view size
771 (e.g. for null array slices) and we are not allocating the object
774 && integer_zerop (gnu_size)
775 && !TREE_OVERFLOW (gnu_size))
776 || (TYPE_SIZE (gnu_type)
777 && integer_zerop (TYPE_SIZE (gnu_type))
778 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
779 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
780 && No (Renamed_Object (gnat_entity))
781 && No (Address_Clause (gnat_entity)))
782 gnu_size = bitsize_unit_node;
784 /* If this is an object with no specified size and alignment, and
785 if either it is atomic or we are not optimizing alignment for
786 space and it is composite and not an exception, an Out parameter
787 or a reference to another object, and the size of its type is a
788 constant, set the alignment to the smallest one which is not
789 smaller than the size, with an appropriate cap. */
790 if (!gnu_size && align == 0
791 && (Is_Atomic (gnat_entity)
792 || (!Optimize_Alignment_Space (gnat_entity)
793 && kind != E_Exception
794 && kind != E_Out_Parameter
795 && Is_Composite_Type (Etype (gnat_entity))
796 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
797 && !Is_Exported (gnat_entity)
799 && No (Renamed_Object (gnat_entity))
800 && No (Address_Clause (gnat_entity))))
801 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
803 unsigned int size_cap, align_cap;
805 /* No point in promoting the alignment if this doesn't prevent
806 BLKmode access to the object, in particular block copy, as
807 this will for example disable the NRV optimization for it.
808 No point in jumping through all the hoops needed in order
809 to support BIGGEST_ALIGNMENT if we don't really have to.
810 So we cap to the smallest alignment that corresponds to
811 a known efficient memory access pattern of the target. */
812 if (Is_Atomic (gnat_entity))
815 align_cap = BIGGEST_ALIGNMENT;
819 size_cap = MAX_FIXED_MODE_SIZE;
820 align_cap = get_mode_alignment (ptr_mode);
823 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
824 || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
826 else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
829 align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
831 /* But make sure not to under-align the object. */
832 if (align <= TYPE_ALIGN (gnu_type))
835 /* And honor the minimum valid atomic alignment, if any. */
836 #ifdef MINIMUM_ATOMIC_ALIGNMENT
837 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
838 align = MINIMUM_ATOMIC_ALIGNMENT;
842 /* If the object is set to have atomic components, find the component
843 type and validate it.
845 ??? Note that we ignore Has_Volatile_Components on objects; it's
846 not at all clear what to do in that case. */
847 if (Has_Atomic_Components (gnat_entity))
849 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
850 ? TREE_TYPE (gnu_type) : gnu_type);
852 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
853 && TYPE_MULTI_ARRAY_P (gnu_inner))
854 gnu_inner = TREE_TYPE (gnu_inner);
856 check_ok_for_atomic (gnu_inner, gnat_entity, true);
859 /* Now check if the type of the object allows atomic access. Note
860 that we must test the type, even if this object has size and
861 alignment to allow such access, because we will be going inside
862 the padded record to assign to the object. We could fix this by
863 always copying via an intermediate value, but it's not clear it's
865 if (Is_Atomic (gnat_entity))
866 check_ok_for_atomic (gnu_type, gnat_entity, false);
868 /* If this is an aliased object with an unconstrained nominal subtype,
869 make a type that includes the template. */
870 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
871 && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
872 && !type_annotate_only)
875 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
877 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
879 concat_name (gnu_entity_name,
884 /* ??? If this is an object of CW type initialized to a value, try to
885 ensure that the object is sufficient aligned for this value, but
886 without pessimizing the allocation. This is a kludge necessary
887 because we don't support dynamic alignment. */
889 && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype
890 && No (Renamed_Object (gnat_entity))
891 && No (Address_Clause (gnat_entity)))
892 align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
894 #ifdef MINIMUM_ATOMIC_ALIGNMENT
895 /* If the size is a constant and no alignment is specified, force
896 the alignment to be the minimum valid atomic alignment. The
897 restriction on constant size avoids problems with variable-size
898 temporaries; if the size is variable, there's no issue with
899 atomic access. Also don't do this for a constant, since it isn't
900 necessary and can interfere with constant replacement. Finally,
901 do not do it for Out parameters since that creates an
902 size inconsistency with In parameters. */
904 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
905 && !FLOAT_TYPE_P (gnu_type)
906 && !const_flag && No (Renamed_Object (gnat_entity))
907 && !imported_p && No (Address_Clause (gnat_entity))
908 && kind != E_Out_Parameter
909 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
910 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
911 align = MINIMUM_ATOMIC_ALIGNMENT;
914 /* Make a new type with the desired size and alignment, if needed.
915 But do not take into account alignment promotions to compute the
916 size of the object. */
917 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
918 if (gnu_size || align > 0)
920 tree orig_type = gnu_type;
922 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
923 false, false, definition, true);
925 /* If a padding record was made, declare it now since it will
926 never be declared otherwise. This is necessary to ensure
927 that its subtrees are properly marked. */
928 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
929 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
930 debug_info_p, gnat_entity);
933 /* If this is a renaming, avoid as much as possible to create a new
934 object. However, in several cases, creating it is required.
935 This processing needs to be applied to the raw expression so
936 as to make it more likely to rename the underlying object. */
937 if (Present (Renamed_Object (gnat_entity)))
939 bool create_normal_object = false;
941 /* If the renamed object had padding, strip off the reference
942 to the inner object and reset our type. */
943 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
944 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
945 /* Strip useless conversions around the object. */
946 || gnat_useless_type_conversion (gnu_expr))
948 gnu_expr = TREE_OPERAND (gnu_expr, 0);
949 gnu_type = TREE_TYPE (gnu_expr);
952 /* Or else, if the renamed object has an unconstrained type with
953 default discriminant, use the padded type. */
954 else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr))
955 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr)))
957 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
958 gnu_type = TREE_TYPE (gnu_expr);
960 /* Case 1: If this is a constant renaming stemming from a function
961 call, treat it as a normal object whose initial value is what is
962 being renamed. RM 3.3 says that the result of evaluating a
963 function call is a constant object. Treat constant literals
964 the same way. As a consequence, it can be the inner object of
965 a constant renaming. In this case, the renaming must be fully
966 instantiated, i.e. it cannot be a mere reference to (part of) an
970 tree inner_object = gnu_expr;
971 while (handled_component_p (inner_object))
972 inner_object = TREE_OPERAND (inner_object, 0);
973 if (TREE_CODE (inner_object) == CALL_EXPR
974 || CONSTANT_CLASS_P (inner_object))
975 create_normal_object = true;
978 /* Otherwise, see if we can proceed with a stabilized version of
979 the renamed entity or if we need to make a new object. */
980 if (!create_normal_object)
982 tree maybe_stable_expr = NULL_TREE;
985 /* Case 2: If the renaming entity need not be materialized and
986 the renamed expression is something we can stabilize, use
987 that for the renaming. At the global level, we can only do
988 this if we know no SAVE_EXPRs need be made, because the
989 expression we return might be used in arbitrary conditional
990 branches so we must force the evaluation of the SAVE_EXPRs
991 immediately and this requires a proper function context.
992 Note that an external constant is at the global level. */
993 if (!Materialize_Entity (gnat_entity)
994 && (!((!definition && kind == E_Constant)
995 || global_bindings_p ())
996 || (staticp (gnu_expr)
997 && !TREE_SIDE_EFFECTS (gnu_expr))))
1000 = gnat_stabilize_reference (gnu_expr, true, &stable);
1004 /* ??? No DECL_EXPR is created so we need to mark
1005 the expression manually lest it is shared. */
1006 if ((!definition && kind == E_Constant)
1007 || global_bindings_p ())
1008 MARK_VISITED (maybe_stable_expr);
1009 gnu_decl = maybe_stable_expr;
1010 save_gnu_tree (gnat_entity, gnu_decl, true);
1012 annotate_object (gnat_entity, gnu_type, NULL_TREE,
1014 /* This assertion will fail if the renamed object
1015 isn't aligned enough as to make it possible to
1016 honor the alignment set on the renaming. */
1019 unsigned int renamed_align
1021 ? DECL_ALIGN (gnu_decl)
1022 : TYPE_ALIGN (TREE_TYPE (gnu_decl));
1023 gcc_assert (renamed_align >= align);
1028 /* The stabilization failed. Keep maybe_stable_expr
1029 untouched here to let the pointer case below know
1030 about that failure. */
1033 /* Case 3: Make this into a constant pointer to the object we
1034 are to rename and attach the object to the pointer if it is
1035 something we can stabilize.
1037 From the proper scope, attached objects will be referenced
1038 directly instead of indirectly via the pointer to avoid
1039 subtle aliasing problems with non-addressable entities.
1040 They have to be stable because we must not evaluate the
1041 variables in the expression every time the renaming is used.
1042 The pointer is called a "renaming" pointer in this case.
1044 In the rare cases where we cannot stabilize the renamed
1045 object, we just make a "bare" pointer and the renamed
1046 object will always be accessed indirectly through it.
1048 Note that we need to preserve the volatility of the renamed
1049 object through the indirection. */
1050 if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
1052 = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1053 gnu_type = build_reference_type (gnu_type);
1054 inner_const_flag = TREE_READONLY (gnu_expr);
1057 /* If the previous attempt at stabilizing failed, there is
1058 no point in trying again and we reuse the result without
1059 attaching it to the pointer. In this case it will only
1060 be used as the initializing expression of the pointer and
1061 thus needs no special treatment with regard to multiple
1064 Otherwise, try to stabilize and attach the expression to
1065 the pointer if the stabilization succeeds.
1067 Note that this might introduce SAVE_EXPRs and we don't
1068 check whether we are at the global level or not. This
1069 is fine since we are building a pointer initializer and
1070 neither the pointer nor the initializing expression can
1071 be accessed before the pointer elaboration has taken
1072 place in a correct program.
1074 These SAVE_EXPRs will be evaluated at the right place
1075 by either the evaluation of the initializer for the
1076 non-global case or the elaboration code for the global
1077 case, and will be attached to the elaboration procedure
1078 in the latter case. */
1079 if (!maybe_stable_expr)
1082 = gnat_stabilize_reference (gnu_expr, true, &stable);
1085 renamed_obj = maybe_stable_expr;
1088 if (type_annotate_only
1089 && TREE_CODE (maybe_stable_expr) == ERROR_MARK)
1090 gnu_expr = NULL_TREE;
1093 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
1095 gnu_size = NULL_TREE;
1100 /* Make a volatile version of this object's type if we are to make
1101 the object volatile. We also interpret 13.3(19) conservatively
1102 and disallow any optimizations for such a non-constant object. */
1103 if ((Treat_As_Volatile (gnat_entity)
1105 && gnu_type != except_type_node
1106 && (Is_Exported (gnat_entity)
1108 || Present (Address_Clause (gnat_entity)))))
1109 && !TYPE_VOLATILE (gnu_type))
1110 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1112 /* If we are defining an aliased object whose nominal subtype is
1113 unconstrained, the object is a record that contains both the
1114 template and the object. If there is an initializer, it will
1115 have already been converted to the right type, but we need to
1116 create the template if there is no initializer. */
1119 && TREE_CODE (gnu_type) == RECORD_TYPE
1120 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1121 /* Beware that padding might have been introduced above. */
1122 || (TYPE_PADDING_P (gnu_type)
1123 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1125 && TYPE_CONTAINS_TEMPLATE_P
1126 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1129 = TYPE_PADDING_P (gnu_type)
1130 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1131 : TYPE_FIELDS (gnu_type);
1132 vec<constructor_elt, va_gc> *v;
1134 tree t = build_template (TREE_TYPE (template_field),
1135 TREE_TYPE (DECL_CHAIN (template_field)),
1137 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1138 gnu_expr = gnat_build_constructor (gnu_type, v);
1141 /* Convert the expression to the type of the object except in the
1142 case where the object's type is unconstrained or the object's type
1143 is a padded record whose field is of self-referential size. In
1144 the former case, converting will generate unnecessary evaluations
1145 of the CONSTRUCTOR to compute the size and in the latter case, we
1146 want to only copy the actual data. Also don't convert to a record
1147 type with a variant part from a record type without one, to keep
1148 the object simpler. */
1150 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1151 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1152 && !(TYPE_IS_PADDING_P (gnu_type)
1153 && CONTAINS_PLACEHOLDER_P
1154 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1155 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1156 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1157 && get_variant_part (gnu_type) != NULL_TREE
1158 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1159 gnu_expr = convert (gnu_type, gnu_expr);
1161 /* If this is a pointer that doesn't have an initializing expression,
1162 initialize it to NULL, unless the object is imported. */
1164 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1166 && !Is_Imported (gnat_entity))
1167 gnu_expr = integer_zero_node;
1169 /* If we are defining the object and it has an Address clause, we must
1170 either get the address expression from the saved GCC tree for the
1171 object if it has a Freeze node, or elaborate the address expression
1172 here since the front-end has guaranteed that the elaboration has no
1173 effects in this case. */
1174 if (definition && Present (Address_Clause (gnat_entity)))
1176 Node_Id gnat_expr = Expression (Address_Clause (gnat_entity));
1178 = present_gnu_tree (gnat_entity)
1179 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
1181 save_gnu_tree (gnat_entity, NULL_TREE, false);
1183 /* Ignore the size. It's either meaningless or was handled
1185 gnu_size = NULL_TREE;
1186 /* Convert the type of the object to a reference type that can
1187 alias everything as per 13.3(19). */
1189 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1190 gnu_address = convert (gnu_type, gnu_address);
1193 = !Is_Public (gnat_entity)
1194 || compile_time_known_address_p (gnat_expr);
1196 /* If this is a deferred constant, the initializer is attached to
1198 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1201 (Expression (Declaration_Node (Full_View (gnat_entity))));
1203 /* If we don't have an initializing expression for the underlying
1204 variable, the initializing expression for the pointer is the
1205 specified address. Otherwise, we have to make a COMPOUND_EXPR
1206 to assign both the address and the initial value. */
1208 gnu_expr = gnu_address;
1211 = build2 (COMPOUND_EXPR, gnu_type,
1213 (MODIFY_EXPR, NULL_TREE,
1214 build_unary_op (INDIRECT_REF, NULL_TREE,
1220 /* If it has an address clause and we are not defining it, mark it
1221 as an indirect object. Likewise for Stdcall objects that are
1223 if ((!definition && Present (Address_Clause (gnat_entity)))
1224 || (Is_Imported (gnat_entity)
1225 && Has_Stdcall_Convention (gnat_entity)))
1227 /* Convert the type of the object to a reference type that can
1228 alias everything as per 13.3(19). */
1230 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1231 gnu_size = NULL_TREE;
1233 /* No point in taking the address of an initializing expression
1234 that isn't going to be used. */
1235 gnu_expr = NULL_TREE;
1237 /* If it has an address clause whose value is known at compile
1238 time, make the object a CONST_DECL. This will avoid a
1239 useless dereference. */
1240 if (Present (Address_Clause (gnat_entity)))
1242 Node_Id gnat_address
1243 = Expression (Address_Clause (gnat_entity));
1245 if (compile_time_known_address_p (gnat_address))
1247 gnu_expr = gnat_to_gnu (gnat_address);
1255 /* If we are at top level and this object is of variable size,
1256 make the actual type a hidden pointer to the real type and
1257 make the initializer be a memory allocation and initialization.
1258 Likewise for objects we aren't defining (presumed to be
1259 external references from other packages), but there we do
1260 not set up an initialization.
1262 If the object's size overflows, make an allocator too, so that
1263 Storage_Error gets raised. Note that we will never free
1264 such memory, so we presume it never will get allocated. */
1265 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1266 global_bindings_p ()
1270 && !allocatable_size_p (convert (sizetype,
1272 (CEIL_DIV_EXPR, gnu_size,
1273 bitsize_unit_node)),
1274 global_bindings_p ()
1278 gnu_type = build_reference_type (gnu_type);
1279 gnu_size = NULL_TREE;
1282 /* In case this was a aliased object whose nominal subtype is
1283 unconstrained, the pointer above will be a thin pointer and
1284 build_allocator will automatically make the template.
1286 If we have a template initializer only (that we made above),
1287 pretend there is none and rely on what build_allocator creates
1288 again anyway. Otherwise (if we have a full initializer), get
1289 the data part and feed that to build_allocator.
1291 If we are elaborating a mutable object, tell build_allocator to
1292 ignore a possibly simpler size from the initializer, if any, as
1293 we must allocate the maximum possible size in this case. */
1294 if (definition && !imported_p)
1296 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1298 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1299 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1302 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1304 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1305 && 1 == vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr)))
1309 = build_component_ref
1310 (gnu_expr, NULL_TREE,
1311 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1315 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1316 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
1317 post_error ("?`Storage_Error` will be raised at run time!",
1321 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1322 Empty, Empty, gnat_entity, mutable_p);
1327 gnu_expr = NULL_TREE;
1332 /* If this object would go into the stack and has an alignment larger
1333 than the largest stack alignment the back-end can honor, resort to
1334 a variable of "aligning type". */
1335 if (!global_bindings_p () && !static_p && definition
1336 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1338 /* Create the new variable. No need for extra room before the
1339 aligned field as this is in automatic storage. */
1341 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1342 TYPE_SIZE_UNIT (gnu_type),
1343 BIGGEST_ALIGNMENT, 0, gnat_entity);
1345 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1346 NULL_TREE, gnu_new_type, NULL_TREE, false,
1347 false, false, false, NULL, gnat_entity);
1349 /* Initialize the aligned field if we have an initializer. */
1352 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1354 (gnu_new_var, NULL_TREE,
1355 TYPE_FIELDS (gnu_new_type), false),
1359 /* And setup this entity as a reference to the aligned field. */
1360 gnu_type = build_reference_type (gnu_type);
1363 (ADDR_EXPR, gnu_type,
1364 build_component_ref (gnu_new_var, NULL_TREE,
1365 TYPE_FIELDS (gnu_new_type), false));
1367 gnu_size = NULL_TREE;
1372 /* If this is an aliased object with an unconstrained nominal subtype,
1373 we make its type a thin reference, i.e. the reference counterpart
1374 of a thin pointer, so that it points to the array part. This is
1375 aimed at making it easier for the debugger to decode the object.
1376 Note that we have to do that this late because of the couple of
1377 allocation adjustments that might be made just above. */
1378 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
1379 && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
1380 && !type_annotate_only)
1383 = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
1385 /* In case the object with the template has already been allocated
1386 just above, we have nothing to do here. */
1387 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1390 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1391 NULL_TREE, gnu_type, gnu_expr,
1392 const_flag, Is_Public (gnat_entity),
1393 imported_p || !definition, static_p,
1396 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1397 TREE_CONSTANT (gnu_expr) = 1;
1399 gnu_size = NULL_TREE;
1405 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1409 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
1411 /* Convert the expression to the type of the object except in the
1412 case where the object's type is unconstrained or the object's type
1413 is a padded record whose field is of self-referential size. In
1414 the former case, converting will generate unnecessary evaluations
1415 of the CONSTRUCTOR to compute the size and in the latter case, we
1416 want to only copy the actual data. Also don't convert to a record
1417 type with a variant part from a record type without one, to keep
1418 the object simpler. */
1420 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1421 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1422 && !(TYPE_IS_PADDING_P (gnu_type)
1423 && CONTAINS_PLACEHOLDER_P
1424 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1425 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1426 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
1427 && get_variant_part (gnu_type) != NULL_TREE
1428 && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
1429 gnu_expr = convert (gnu_type, gnu_expr);
1431 /* If this name is external or there was a name specified, use it,
1432 unless this is a VMS exception object since this would conflict
1433 with the symbol we need to export in addition. Don't use the
1434 Interface_Name if there is an address clause (see CD30005). */
1435 if (!Is_VMS_Exception (gnat_entity)
1436 && ((Present (Interface_Name (gnat_entity))
1437 && No (Address_Clause (gnat_entity)))
1438 || (Is_Public (gnat_entity)
1439 && (!Is_Imported (gnat_entity)
1440 || Is_Exported (gnat_entity)))))
1441 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1443 /* If this is an aggregate constant initialized to a constant, force it
1444 to be statically allocated. This saves an initialization copy. */
1447 && gnu_expr && TREE_CONSTANT (gnu_expr)
1448 && AGGREGATE_TYPE_P (gnu_type)
1449 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
1450 && !(TYPE_IS_PADDING_P (gnu_type)
1451 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1452 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1455 /* Deal with a pragma Linker_Section on a constant or variable. */
1456 if ((kind == E_Constant || kind == E_Variable)
1457 && Present (Linker_Section_Pragma (gnat_entity)))
1458 prepend_one_attribute_pragma (&attr_list,
1459 Linker_Section_Pragma (gnat_entity));
1461 /* Now create the variable or the constant and set various flags. */
1463 = create_var_decl_1 (gnu_entity_name, gnu_ext_name, gnu_type,
1464 gnu_expr, const_flag, Is_Public (gnat_entity),
1465 imported_p || !definition, static_p,
1466 !renamed_obj, attr_list, gnat_entity);
1467 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1468 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1469 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1471 /* If we are defining an Out parameter and optimization isn't enabled,
1472 create a fake PARM_DECL for debugging purposes and make it point to
1473 the VAR_DECL. Suppress debug info for the latter but make sure it
1474 will live in memory so that it can be accessed from within the
1475 debugger through the PARM_DECL. */
1476 if (kind == E_Out_Parameter
1480 && !flag_generate_lto)
1482 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1483 gnat_pushdecl (param, gnat_entity);
1484 SET_DECL_VALUE_EXPR (param, gnu_decl);
1485 DECL_HAS_VALUE_EXPR_P (param) = 1;
1486 DECL_IGNORED_P (gnu_decl) = 1;
1487 TREE_ADDRESSABLE (gnu_decl) = 1;
1490 /* If this is a loop parameter, set the corresponding flag. */
1491 else if (kind == E_Loop_Parameter)
1492 DECL_LOOP_PARM_P (gnu_decl) = 1;
1494 /* If this is a renaming pointer, attach the renamed object to it and
1495 register it if we are at the global level. Note that an external
1496 constant is at the global level. */
1499 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1500 if ((!definition && kind == E_Constant) || global_bindings_p ())
1502 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1503 record_global_renaming_pointer (gnu_decl);
1507 /* If this is a constant and we are defining it or it generates a real
1508 symbol at the object level and we are referencing it, we may want
1509 or need to have a true variable to represent it:
1510 - if optimization isn't enabled, for debugging purposes,
1511 - if the constant is public and not overlaid on something else,
1512 - if its address is taken,
1513 - if either itself or its type is aliased. */
1514 if (TREE_CODE (gnu_decl) == CONST_DECL
1515 && (definition || Sloc (gnat_entity) > Standard_Location)
1516 && ((!optimize && debug_info_p)
1517 || (Is_Public (gnat_entity)
1518 && No (Address_Clause (gnat_entity)))
1519 || Address_Taken (gnat_entity)
1520 || Is_Aliased (gnat_entity)
1521 || Is_Aliased (Etype (gnat_entity))))
1524 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1525 gnu_expr, true, Is_Public (gnat_entity),
1526 !definition, static_p, attr_list,
1529 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1531 /* As debugging information will be generated for the variable,
1532 do not generate debugging information for the constant. */
1534 DECL_IGNORED_P (gnu_decl) = 1;
1536 DECL_IGNORED_P (gnu_corr_var) = 1;
1539 /* If this is a constant, even if we don't need a true variable, we
1540 may need to avoid returning the initializer in every case. That
1541 can happen for the address of a (constant) constructor because,
1542 upon dereferencing it, the constructor will be reinjected in the
1543 tree, which may not be valid in every case; see lvalue_required_p
1544 for more details. */
1545 if (TREE_CODE (gnu_decl) == CONST_DECL)
1546 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1548 /* If this object is declared in a block that contains a block with an
1549 exception handler, and we aren't using the GCC exception mechanism,
1550 we must force this variable in memory in order to avoid an invalid
1552 if (Exception_Mechanism != Back_End_Exceptions
1553 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1554 TREE_ADDRESSABLE (gnu_decl) = 1;
1556 /* If this is a local variable with non-BLKmode and aggregate type,
1557 and optimization isn't enabled, then force it in memory so that
1558 a register won't be allocated to it with possible subparts left
1559 uninitialized and reaching the register allocator. */
1560 else if (TREE_CODE (gnu_decl) == VAR_DECL
1561 && !DECL_EXTERNAL (gnu_decl)
1562 && !TREE_STATIC (gnu_decl)
1563 && DECL_MODE (gnu_decl) != BLKmode
1564 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl))
1565 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl))
1567 TREE_ADDRESSABLE (gnu_decl) = 1;
1569 /* If we are defining an object with variable size or an object with
1570 fixed size that will be dynamically allocated, and we are using the
1571 setjmp/longjmp exception mechanism, update the setjmp buffer. */
1573 && Exception_Mechanism == Setjmp_Longjmp
1574 && get_block_jmpbuf_decl ()
1575 && DECL_SIZE_UNIT (gnu_decl)
1576 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1577 || (flag_stack_check == GENERIC_STACK_CHECK
1578 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1579 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1580 add_stmt_with_node (build_call_n_expr
1581 (update_setjmp_buf_decl, 1,
1582 build_unary_op (ADDR_EXPR, NULL_TREE,
1583 get_block_jmpbuf_decl ())),
1586 /* Back-annotate Esize and Alignment of the object if not already
1587 known. Note that we pick the values of the type, not those of
1588 the object, to shield ourselves from low-level platform-dependent
1589 adjustments like alignment promotion. This is both consistent with
1590 all the treatment above, where alignment and size are set on the
1591 type of the object and not on the object directly, and makes it
1592 possible to support all confirming representation clauses. */
1593 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1599 /* Return a TYPE_DECL for "void" that we previously made. */
1600 gnu_decl = TYPE_NAME (void_type_node);
1603 case E_Enumeration_Type:
1604 /* A special case: for the types Character and Wide_Character in
1605 Standard, we do not list all the literals. So if the literals
1606 are not specified, make this an unsigned integer type. */
1607 if (No (First_Literal (gnat_entity)))
1609 gnu_type = make_unsigned_type (esize);
1610 TYPE_NAME (gnu_type) = gnu_entity_name;
1612 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1613 This is needed by the DWARF-2 back-end to distinguish between
1614 unsigned integer types and character types. */
1615 TYPE_STRING_FLAG (gnu_type) = 1;
1619 /* We have a list of enumeral constants in First_Literal. We make a
1620 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1621 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1622 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1623 value of the literal. But when we have a regular boolean type, we
1624 simplify this a little by using a BOOLEAN_TYPE. */
1625 const bool is_boolean = Is_Boolean_Type (gnat_entity)
1626 && !Has_Non_Standard_Rep (gnat_entity);
1627 const bool is_unsigned = Is_Unsigned_Type (gnat_entity);
1628 tree gnu_list = NULL_TREE;
1629 Entity_Id gnat_literal;
1631 gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1632 TYPE_PRECISION (gnu_type) = esize;
1633 TYPE_UNSIGNED (gnu_type) = is_unsigned;
1634 set_min_and_max_values_for_integral_type (gnu_type, esize,
1635 TYPE_SIGN (gnu_type));
1636 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
1637 layout_type (gnu_type);
1639 for (gnat_literal = First_Literal (gnat_entity);
1640 Present (gnat_literal);
1641 gnat_literal = Next_Literal (gnat_literal))
1644 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1646 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1647 gnu_type, gnu_value, true, false, false,
1648 false, NULL, gnat_literal);
1649 /* Do not generate debug info for individual enumerators. */
1650 DECL_IGNORED_P (gnu_literal) = 1;
1651 save_gnu_tree (gnat_literal, gnu_literal, false);
1653 = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list);
1657 TYPE_VALUES (gnu_type) = nreverse (gnu_list);
1659 /* Note that the bounds are updated at the end of this function
1660 to avoid an infinite recursion since they refer to the type. */
1665 case E_Signed_Integer_Type:
1666 case E_Ordinary_Fixed_Point_Type:
1667 case E_Decimal_Fixed_Point_Type:
1668 /* For integer types, just make a signed type the appropriate number
1670 gnu_type = make_signed_type (esize);
1673 case E_Modular_Integer_Type:
1675 /* For modular types, make the unsigned type of the proper number
1676 of bits and then set up the modulus, if required. */
1677 tree gnu_modulus, gnu_high = NULL_TREE;
1679 /* Packed Array Impl. Types are supposed to be subtypes only. */
1680 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity));
1682 gnu_type = make_unsigned_type (esize);
1684 /* Get the modulus in this type. If it overflows, assume it is because
1685 it is equal to 2**Esize. Note that there is no overflow checking
1686 done on unsigned type, so we detect the overflow by looking for
1687 a modulus of zero, which is otherwise invalid. */
1688 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1690 if (!integer_zerop (gnu_modulus))
1692 TYPE_MODULAR_P (gnu_type) = 1;
1693 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1694 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1695 convert (gnu_type, integer_one_node));
1698 /* If the upper bound is not maximal, make an extra subtype. */
1700 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1702 tree gnu_subtype = make_unsigned_type (esize);
1703 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1704 TREE_TYPE (gnu_subtype) = gnu_type;
1705 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1706 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1707 gnu_type = gnu_subtype;
1712 case E_Signed_Integer_Subtype:
1713 case E_Enumeration_Subtype:
1714 case E_Modular_Integer_Subtype:
1715 case E_Ordinary_Fixed_Point_Subtype:
1716 case E_Decimal_Fixed_Point_Subtype:
1718 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1719 not want to call create_range_type since we would like each subtype
1720 node to be distinct. ??? Historically this was in preparation for
1721 when memory aliasing is implemented, but that's obsolete now given
1722 the call to relate_alias_sets below.
1724 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1725 this fact is used by the arithmetic conversion functions.
1727 We elaborate the Ancestor_Subtype if it is not in the current unit
1728 and one of our bounds is non-static. We do this to ensure consistent
1729 naming in the case where several subtypes share the same bounds, by
1730 elaborating the first such subtype first, thus using its name. */
1733 && Present (Ancestor_Subtype (gnat_entity))
1734 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1735 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1736 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1737 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1739 /* Set the precision to the Esize except for bit-packed arrays. */
1740 if (Is_Packed_Array_Impl_Type (gnat_entity)
1741 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1742 esize = UI_To_Int (RM_Size (gnat_entity));
1744 /* This should be an unsigned type if the base type is unsigned or
1745 if the lower bound is constant and non-negative or if the type
1747 if (Is_Unsigned_Type (Etype (gnat_entity))
1748 || Is_Unsigned_Type (gnat_entity)
1749 || Has_Biased_Representation (gnat_entity))
1750 gnu_type = make_unsigned_type (esize);
1752 gnu_type = make_signed_type (esize);
1753 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1755 SET_TYPE_RM_MIN_VALUE
1757 convert (TREE_TYPE (gnu_type),
1758 elaborate_expression (Type_Low_Bound (gnat_entity),
1759 gnat_entity, get_identifier ("L"),
1761 Needs_Debug_Info (gnat_entity))));
1763 SET_TYPE_RM_MAX_VALUE
1765 convert (TREE_TYPE (gnu_type),
1766 elaborate_expression (Type_High_Bound (gnat_entity),
1767 gnat_entity, get_identifier ("U"),
1769 Needs_Debug_Info (gnat_entity))));
1771 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1772 = Has_Biased_Representation (gnat_entity);
1774 /* Inherit our alias set from what we're a subtype of. Subtypes
1775 are not different types and a pointer can designate any instance
1776 within a subtype hierarchy. */
1777 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1779 /* One of the above calls might have caused us to be elaborated,
1780 so don't blow up if so. */
1781 if (present_gnu_tree (gnat_entity))
1783 maybe_present = true;
1787 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1788 TYPE_STUB_DECL (gnu_type)
1789 = create_type_stub_decl (gnu_entity_name, gnu_type);
1791 /* For a packed array, make the original array type a parallel type. */
1793 && Is_Packed_Array_Impl_Type (gnat_entity)
1794 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1795 add_parallel_type (gnu_type,
1797 (Original_Array_Type (gnat_entity)));
1801 /* We have to handle clauses that under-align the type specially. */
1802 if ((Present (Alignment_Clause (gnat_entity))
1803 || (Is_Packed_Array_Impl_Type (gnat_entity)
1805 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1806 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1808 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1809 if (align >= TYPE_ALIGN (gnu_type))
1813 /* If the type we are dealing with represents a bit-packed array,
1814 we need to have the bits left justified on big-endian targets
1815 and right justified on little-endian targets. We also need to
1816 ensure that when the value is read (e.g. for comparison of two
1817 such values), we only get the good bits, since the unused bits
1818 are uninitialized. Both goals are accomplished by wrapping up
1819 the modular type in an enclosing record type. */
1820 if (Is_Packed_Array_Impl_Type (gnat_entity)
1821 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1823 tree gnu_field_type, gnu_field;
1825 /* Set the RM size before wrapping up the original type. */
1826 SET_TYPE_RM_SIZE (gnu_type,
1827 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1828 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1830 /* Create a stripped-down declaration, mainly for debugging. */
1831 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1834 /* Now save it and build the enclosing record type. */
1835 gnu_field_type = gnu_type;
1837 gnu_type = make_node (RECORD_TYPE);
1838 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1839 TYPE_PACKED (gnu_type) = 1;
1840 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1841 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1842 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1844 /* Propagate the alignment of the modular type to the record type,
1845 unless there is an alignment clause that under-aligns the type.
1846 This means that bit-packed arrays are given "ceil" alignment for
1847 their size by default, which may seem counter-intuitive but makes
1848 it possible to overlay them on modular types easily. */
1849 TYPE_ALIGN (gnu_type)
1850 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1852 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1854 /* Don't declare the field as addressable since we won't be taking
1855 its address and this would prevent create_field_decl from making
1858 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1859 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1861 /* Do not emit debug info until after the parallel type is added. */
1862 finish_record_type (gnu_type, gnu_field, 2, false);
1863 compute_record_mode (gnu_type);
1864 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1868 /* Make the original array type a parallel type. */
1869 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1870 add_parallel_type (gnu_type,
1872 (Original_Array_Type (gnat_entity)));
1874 rest_of_record_type_compilation (gnu_type);
1878 /* If the type we are dealing with has got a smaller alignment than the
1879 natural one, we need to wrap it up in a record type and misalign the
1880 latter; we reuse the padding machinery for this purpose. Note that,
1881 even if the record type is marked as packed because of misalignment,
1882 we don't pack the field so as to give it the size of the type. */
1885 tree gnu_field_type, gnu_field;
1887 /* Set the RM size before wrapping up the type. */
1888 SET_TYPE_RM_SIZE (gnu_type,
1889 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1891 /* Create a stripped-down declaration, mainly for debugging. */
1892 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1895 /* Now save it and build the enclosing record type. */
1896 gnu_field_type = gnu_type;
1898 gnu_type = make_node (RECORD_TYPE);
1899 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1900 TYPE_PACKED (gnu_type) = 1;
1901 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1902 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1903 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1904 TYPE_ALIGN (gnu_type) = align;
1905 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1907 /* Don't declare the field as addressable since we won't be taking
1908 its address and this would prevent create_field_decl from making
1911 = create_field_decl (get_identifier ("F"), gnu_field_type,
1912 gnu_type, TYPE_SIZE (gnu_field_type),
1913 bitsize_zero_node, 0, 0);
1915 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1916 compute_record_mode (gnu_type);
1917 TYPE_PADDING_P (gnu_type) = 1;
1922 case E_Floating_Point_Type:
1923 /* If this is a VAX floating-point type, use an integer of the proper
1924 size. All the operations will be handled with ASM statements. */
1925 if (Vax_Float (gnat_entity))
1927 gnu_type = make_signed_type (esize);
1928 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1929 SET_TYPE_DIGITS_VALUE (gnu_type,
1930 UI_To_gnu (Digits_Value (gnat_entity),
1935 /* The type of the Low and High bounds can be our type if this is
1936 a type from Standard, so set them at the end of the function. */
1937 gnu_type = make_node (REAL_TYPE);
1938 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1939 layout_type (gnu_type);
1942 case E_Floating_Point_Subtype:
1943 if (Vax_Float (gnat_entity))
1945 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1949 /* See the E_Signed_Integer_Subtype case for the rationale. */
1951 && Present (Ancestor_Subtype (gnat_entity))
1952 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1953 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1954 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1955 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1957 gnu_type = make_node (REAL_TYPE);
1958 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1959 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1960 TYPE_GCC_MIN_VALUE (gnu_type)
1961 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1962 TYPE_GCC_MAX_VALUE (gnu_type)
1963 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1964 layout_type (gnu_type);
1966 SET_TYPE_RM_MIN_VALUE
1968 convert (TREE_TYPE (gnu_type),
1969 elaborate_expression (Type_Low_Bound (gnat_entity),
1970 gnat_entity, get_identifier ("L"),
1972 Needs_Debug_Info (gnat_entity))));
1974 SET_TYPE_RM_MAX_VALUE
1976 convert (TREE_TYPE (gnu_type),
1977 elaborate_expression (Type_High_Bound (gnat_entity),
1978 gnat_entity, get_identifier ("U"),
1980 Needs_Debug_Info (gnat_entity))));
1982 /* Inherit our alias set from what we're a subtype of, as for
1983 integer subtypes. */
1984 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1986 /* One of the above calls might have caused us to be elaborated,
1987 so don't blow up if so. */
1988 maybe_present = true;
1991 /* Array and String Types and Subtypes
1993 Unconstrained array types are represented by E_Array_Type and
1994 constrained array types are represented by E_Array_Subtype. There
1995 are no actual objects of an unconstrained array type; all we have
1996 are pointers to that type.
1998 The following fields are defined on array types and subtypes:
2000 Component_Type Component type of the array.
2001 Number_Dimensions Number of dimensions (an int).
2002 First_Index Type of first index. */
2007 const bool convention_fortran_p
2008 = (Convention (gnat_entity) == Convention_Fortran);
2009 const int ndim = Number_Dimensions (gnat_entity);
2010 tree gnu_template_type;
2011 tree gnu_ptr_template;
2012 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
2013 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2014 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2015 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
2016 Entity_Id gnat_index, gnat_name;
2020 /* Create the type for the component now, as it simplifies breaking
2021 type reference loops. */
2023 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2024 if (present_gnu_tree (gnat_entity))
2026 /* As a side effect, the type may have been translated. */
2027 maybe_present = true;
2031 /* We complete an existing dummy fat pointer type in place. This both
2032 avoids further complex adjustments in update_pointer_to and yields
2033 better debugging information in DWARF by leveraging the support for
2034 incomplete declarations of "tagged" types in the DWARF back-end. */
2035 gnu_type = get_dummy_type (gnat_entity);
2036 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2038 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2039 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2040 /* Save the contents of the dummy type for update_pointer_to. */
2041 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2043 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2044 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2048 gnu_fat_type = make_node (RECORD_TYPE);
2049 gnu_template_type = make_node (RECORD_TYPE);
2050 gnu_ptr_template = build_pointer_type (gnu_template_type);
2053 /* Make a node for the array. If we are not defining the array
2054 suppress expanding incomplete types. */
2055 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2059 defer_incomplete_level++;
2060 this_deferred = true;
2063 /* Build the fat pointer type. Use a "void *" object instead of
2064 a pointer to the array type since we don't have the array type
2065 yet (it will reference the fat pointer via the bounds). */
2067 = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
2068 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2070 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
2071 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2073 if (COMPLETE_TYPE_P (gnu_fat_type))
2075 /* We are going to lay it out again so reset the alias set. */
2076 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
2077 TYPE_ALIAS_SET (gnu_fat_type) = -1;
2078 finish_fat_pointer_type (gnu_fat_type, tem);
2079 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
2080 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2082 TYPE_FIELDS (t) = tem;
2083 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2088 finish_fat_pointer_type (gnu_fat_type, tem);
2089 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2092 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2093 is the fat pointer. This will be used to access the individual
2094 fields once we build them. */
2095 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2096 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2097 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
2098 gnu_template_reference
2099 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2100 TREE_READONLY (gnu_template_reference) = 1;
2101 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2103 /* Now create the GCC type for each index and add the fields for that
2104 index to the template. */
2105 for (index = (convention_fortran_p ? ndim - 1 : 0),
2106 gnat_index = First_Index (gnat_entity);
2107 0 <= index && index < ndim;
2108 index += (convention_fortran_p ? - 1 : 1),
2109 gnat_index = Next_Index (gnat_index))
2111 char field_name[16];
2112 tree gnu_index_base_type
2113 = get_unpadded_type (Base_Type (Etype (gnat_index)));
2114 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2115 tree gnu_min, gnu_max, gnu_high;
2117 /* Make the FIELD_DECLs for the low and high bounds of this
2118 type and then make extractions of these fields from the
2120 sprintf (field_name, "LB%d", index);
2121 gnu_lb_field = create_field_decl (get_identifier (field_name),
2122 gnu_index_base_type,
2123 gnu_template_type, NULL_TREE,
2125 Sloc_to_locus (Sloc (gnat_entity),
2126 &DECL_SOURCE_LOCATION (gnu_lb_field));
2128 field_name[0] = 'U';
2129 gnu_hb_field = create_field_decl (get_identifier (field_name),
2130 gnu_index_base_type,
2131 gnu_template_type, NULL_TREE,
2133 Sloc_to_locus (Sloc (gnat_entity),
2134 &DECL_SOURCE_LOCATION (gnu_hb_field));
2136 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2138 /* We can't use build_component_ref here since the template type
2139 isn't complete yet. */
2140 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2141 gnu_template_reference, gnu_lb_field,
2143 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2144 gnu_template_reference, gnu_hb_field,
2146 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2148 gnu_min = convert (sizetype, gnu_orig_min);
2149 gnu_max = convert (sizetype, gnu_orig_max);
2151 /* Compute the size of this dimension. See the E_Array_Subtype
2152 case below for the rationale. */
2154 = build3 (COND_EXPR, sizetype,
2155 build2 (GE_EXPR, boolean_type_node,
2156 gnu_orig_max, gnu_orig_min),
2158 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2160 /* Make a range type with the new range in the Ada base type.
2161 Then make an index type with the size range in sizetype. */
2162 gnu_index_types[index]
2163 = create_index_type (gnu_min, gnu_high,
2164 create_range_type (gnu_index_base_type,
2169 /* Update the maximum size of the array in elements. */
2172 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2174 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2176 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2178 = size_binop (MAX_EXPR,
2179 size_binop (PLUS_EXPR, size_one_node,
2180 size_binop (MINUS_EXPR,
2184 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2185 && TREE_OVERFLOW (gnu_this_max))
2186 gnu_max_size = NULL_TREE;
2189 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2192 TYPE_NAME (gnu_index_types[index])
2193 = create_concat_name (gnat_entity, field_name);
2196 /* Install all the fields into the template. */
2197 TYPE_NAME (gnu_template_type)
2198 = create_concat_name (gnat_entity, "XUB");
2199 gnu_template_fields = NULL_TREE;
2200 for (index = 0; index < ndim; index++)
2202 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2203 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2205 TYPE_READONLY (gnu_template_type) = 1;
2207 /* If Component_Size is not already specified, annotate it with the
2208 size of the component. */
2209 if (Unknown_Component_Size (gnat_entity))
2210 Set_Component_Size (gnat_entity,
2211 annotate_value (TYPE_SIZE (comp_type)));
2213 /* Compute the maximum size of the array in units and bits. */
2216 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2217 TYPE_SIZE_UNIT (comp_type));
2218 gnu_max_size = size_binop (MULT_EXPR,
2219 convert (bitsizetype, gnu_max_size),
2220 TYPE_SIZE (comp_type));
2223 gnu_max_size_unit = NULL_TREE;
2225 /* Now build the array type. */
2227 for (index = ndim - 1; index >= 0; index--)
2229 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2230 if (Reverse_Storage_Order (gnat_entity))
2231 sorry ("non-default Scalar_Storage_Order");
2232 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2233 if (array_type_has_nonaliased_component (tem, gnat_entity))
2234 TYPE_NONALIASED_COMPONENT (tem) = 1;
2236 /* If it is passed by reference, force BLKmode to ensure that
2237 objects of this type will always be put in memory. */
2238 if (TYPE_MODE (tem) != BLKmode
2239 && Is_By_Reference_Type (gnat_entity))
2240 SET_TYPE_MODE (tem, BLKmode);
2243 TYPE_VOLATILE (tem) = Treat_As_Volatile (gnat_entity);
2245 /* If an alignment is specified, use it if valid. But ignore it
2246 for the original type of packed array types. If the alignment
2247 was requested with an explicit alignment clause, state so. */
2248 if (No (Packed_Array_Impl_Type (gnat_entity))
2249 && Known_Alignment (gnat_entity))
2252 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2254 if (Present (Alignment_Clause (gnat_entity)))
2255 TYPE_USER_ALIGN (tem) = 1;
2258 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2260 /* Adjust the type of the pointer-to-array field of the fat pointer
2261 and record the aliasing relationships if necessary. */
2262 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2263 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2264 record_component_aliases (gnu_fat_type);
2266 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2267 corresponding fat pointer. */
2268 TREE_TYPE (gnu_type) = gnu_fat_type;
2269 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2270 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2271 SET_TYPE_MODE (gnu_type, BLKmode);
2272 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2274 /* If the maximum size doesn't overflow, use it. */
2276 && TREE_CODE (gnu_max_size) == INTEGER_CST
2277 && !TREE_OVERFLOW (gnu_max_size)
2278 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2279 && !TREE_OVERFLOW (gnu_max_size_unit))
2281 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2283 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2284 TYPE_SIZE_UNIT (tem));
2287 create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
2288 !Comes_From_Source (gnat_entity), debug_info_p,
2291 /* Give the fat pointer type a name. If this is a packed array, tell
2292 the debugger how to interpret the underlying bits. */
2293 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2294 gnat_name = Packed_Array_Impl_Type (gnat_entity);
2296 gnat_name = gnat_entity;
2297 create_type_decl (create_concat_name (gnat_name, "XUP"), gnu_fat_type,
2298 !Comes_From_Source (gnat_entity), debug_info_p,
2301 /* Create the type to be designated by thin pointers: a record type for
2302 the array and its template. We used to shift the fields to have the
2303 template at a negative offset, but this was somewhat of a kludge; we
2304 now shift thin pointer values explicitly but only those which have a
2305 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. */
2306 tem = build_unc_object_type (gnu_template_type, tem,
2307 create_concat_name (gnat_name, "XUT"),
2310 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2311 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2315 case E_String_Subtype:
2316 case E_Array_Subtype:
2318 /* This is the actual data type for array variables. Multidimensional
2319 arrays are implemented as arrays of arrays. Note that arrays which
2320 have sparse enumeration subtypes as index components create sparse
2321 arrays, which is obviously space inefficient but so much easier to
2324 Also note that the subtype never refers to the unconstrained array
2325 type, which is somewhat at variance with Ada semantics.
2327 First check to see if this is simply a renaming of the array type.
2328 If so, the result is the array type. */
2330 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2331 if (!Is_Constrained (gnat_entity))
2335 Entity_Id gnat_index, gnat_base_index;
2336 const bool convention_fortran_p
2337 = (Convention (gnat_entity) == Convention_Fortran);
2338 const int ndim = Number_Dimensions (gnat_entity);
2339 tree gnu_base_type = gnu_type;
2340 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2341 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2342 bool need_index_type_struct = false;
2345 /* First create the GCC type for each index and find out whether
2346 special types are needed for debugging information. */
2347 for (index = (convention_fortran_p ? ndim - 1 : 0),
2348 gnat_index = First_Index (gnat_entity),
2350 = First_Index (Implementation_Base_Type (gnat_entity));
2351 0 <= index && index < ndim;
2352 index += (convention_fortran_p ? - 1 : 1),
2353 gnat_index = Next_Index (gnat_index),
2354 gnat_base_index = Next_Index (gnat_base_index))
2356 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2357 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2358 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2359 tree gnu_min = convert (sizetype, gnu_orig_min);
2360 tree gnu_max = convert (sizetype, gnu_orig_max);
2361 tree gnu_base_index_type
2362 = get_unpadded_type (Etype (gnat_base_index));
2363 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2364 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2367 /* See if the base array type is already flat. If it is, we
2368 are probably compiling an ACATS test but it will cause the
2369 code below to malfunction if we don't handle it specially. */
2370 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2371 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2372 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2374 gnu_min = size_one_node;
2375 gnu_max = size_zero_node;
2379 /* Similarly, if one of the values overflows in sizetype and the
2380 range is null, use 1..0 for the sizetype bounds. */
2381 else if (TREE_CODE (gnu_min) == INTEGER_CST
2382 && TREE_CODE (gnu_max) == INTEGER_CST
2383 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2384 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2386 gnu_min = size_one_node;
2387 gnu_max = size_zero_node;
2391 /* If the minimum and maximum values both overflow in sizetype,
2392 but the difference in the original type does not overflow in
2393 sizetype, ignore the overflow indication. */
2394 else if (TREE_CODE (gnu_min) == INTEGER_CST
2395 && TREE_CODE (gnu_max) == INTEGER_CST
2396 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2399 fold_build2 (MINUS_EXPR, gnu_index_type,
2403 TREE_OVERFLOW (gnu_min) = 0;
2404 TREE_OVERFLOW (gnu_max) = 0;
2408 /* Compute the size of this dimension in the general case. We
2409 need to provide GCC with an upper bound to use but have to
2410 deal with the "superflat" case. There are three ways to do
2411 this. If we can prove that the array can never be superflat,
2412 we can just use the high bound of the index type. */
2413 else if ((Nkind (gnat_index) == N_Range
2414 && cannot_be_superflat_p (gnat_index))
2415 /* Bit-Packed Array Types are never superflat. */
2416 || (Is_Packed_Array_Impl_Type (gnat_entity)
2417 && Is_Bit_Packed_Array
2418 (Original_Array_Type (gnat_entity))))
2421 /* Otherwise, if the high bound is constant but the low bound is
2422 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2423 lower bound. Note that the comparison must be done in the
2424 original type to avoid any overflow during the conversion. */
2425 else if (TREE_CODE (gnu_max) == INTEGER_CST
2426 && TREE_CODE (gnu_min) != INTEGER_CST)
2430 = build_cond_expr (sizetype,
2431 build_binary_op (GE_EXPR,
2436 int_const_binop (PLUS_EXPR, gnu_max,
2440 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2441 in all the other cases. Note that, here as well as above,
2442 the condition used in the comparison must be equivalent to
2443 the condition (length != 0). This is relied upon in order
2444 to optimize array comparisons in compare_arrays. Moreover
2445 we use int_const_binop for the shift by 1 if the bound is
2446 constant to avoid any unwanted overflow. */
2449 = build_cond_expr (sizetype,
2450 build_binary_op (GE_EXPR,
2455 TREE_CODE (gnu_min) == INTEGER_CST
2456 ? int_const_binop (MINUS_EXPR, gnu_min,
2458 : size_binop (MINUS_EXPR, gnu_min,
2461 /* Reuse the index type for the range type. Then make an index
2462 type with the size range in sizetype. */
2463 gnu_index_types[index]
2464 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2467 /* Update the maximum size of the array in elements. Here we
2468 see if any constraint on the index type of the base type
2469 can be used in the case of self-referential bound on the
2470 index type of the subtype. We look for a non-"infinite"
2471 and non-self-referential bound from any type involved and
2472 handle each bound separately. */
2475 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2476 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2477 tree gnu_base_index_base_type
2478 = get_base_type (gnu_base_index_type);
2479 tree gnu_base_base_min
2480 = convert (sizetype,
2481 TYPE_MIN_VALUE (gnu_base_index_base_type));
2482 tree gnu_base_base_max
2483 = convert (sizetype,
2484 TYPE_MAX_VALUE (gnu_base_index_base_type));
2486 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2487 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2488 && !TREE_OVERFLOW (gnu_base_min)))
2489 gnu_base_min = gnu_min;
2491 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2492 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2493 && !TREE_OVERFLOW (gnu_base_max)))
2494 gnu_base_max = gnu_max;
2496 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2497 && TREE_OVERFLOW (gnu_base_min))
2498 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2499 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2500 && TREE_OVERFLOW (gnu_base_max))
2501 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2502 gnu_max_size = NULL_TREE;
2506 = size_binop (MAX_EXPR,
2507 size_binop (PLUS_EXPR, size_one_node,
2508 size_binop (MINUS_EXPR,
2513 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2514 && TREE_OVERFLOW (gnu_this_max))
2515 gnu_max_size = NULL_TREE;
2518 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2522 /* We need special types for debugging information to point to
2523 the index types if they have variable bounds, are not integer
2524 types, are biased or are wider than sizetype. */
2525 if (!integer_onep (gnu_orig_min)
2526 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2527 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2528 || (TREE_TYPE (gnu_index_type)
2529 && TREE_CODE (TREE_TYPE (gnu_index_type))
2531 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2532 || compare_tree_int (rm_size (gnu_index_type),
2533 TYPE_PRECISION (sizetype)) > 0)
2534 need_index_type_struct = true;
2537 /* Then flatten: create the array of arrays. For an array type
2538 used to implement a packed array, get the component type from
2539 the original array type since the representation clauses that
2540 can affect it are on the latter. */
2541 if (Is_Packed_Array_Impl_Type (gnat_entity)
2542 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2544 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2545 for (index = ndim - 1; index >= 0; index--)
2546 gnu_type = TREE_TYPE (gnu_type);
2548 /* One of the above calls might have caused us to be elaborated,
2549 so don't blow up if so. */
2550 if (present_gnu_tree (gnat_entity))
2552 maybe_present = true;
2558 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2561 /* One of the above calls might have caused us to be elaborated,
2562 so don't blow up if so. */
2563 if (present_gnu_tree (gnat_entity))
2565 maybe_present = true;
2570 /* Compute the maximum size of the array in units and bits. */
2573 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2574 TYPE_SIZE_UNIT (gnu_type));
2575 gnu_max_size = size_binop (MULT_EXPR,
2576 convert (bitsizetype, gnu_max_size),
2577 TYPE_SIZE (gnu_type));
2580 gnu_max_size_unit = NULL_TREE;
2582 /* Now build the array type. */
2583 for (index = ndim - 1; index >= 0; index --)
2585 gnu_type = build_nonshared_array_type (gnu_type,
2586 gnu_index_types[index]);
2587 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2588 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2589 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2591 /* See the E_Array_Type case for the rationale. */
2592 if (TYPE_MODE (gnu_type) != BLKmode
2593 && Is_By_Reference_Type (gnat_entity))
2594 SET_TYPE_MODE (gnu_type, BLKmode);
2597 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2599 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2600 TYPE_STUB_DECL (gnu_type)
2601 = create_type_stub_decl (gnu_entity_name, gnu_type);
2603 /* If we are at file level and this is a multi-dimensional array,
2604 we need to make a variable corresponding to the stride of the
2605 inner dimensions. */
2606 if (global_bindings_p () && ndim > 1)
2608 tree gnu_st_name = get_identifier ("ST");
2611 for (gnu_arr_type = TREE_TYPE (gnu_type);
2612 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2613 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2614 gnu_st_name = concat_name (gnu_st_name, "ST"))
2616 tree eltype = TREE_TYPE (gnu_arr_type);
2618 TYPE_SIZE (gnu_arr_type)
2619 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2620 gnat_entity, gnu_st_name,
2623 /* ??? For now, store the size as a multiple of the
2624 alignment of the element type in bytes so that we
2625 can see the alignment from the tree. */
2626 TYPE_SIZE_UNIT (gnu_arr_type)
2627 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2629 concat_name (gnu_st_name, "A_U"),
2631 TYPE_ALIGN (eltype));
2633 /* ??? create_type_decl is not invoked on the inner types so
2634 the MULT_EXPR node built above will never be marked. */
2635 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2639 /* If we need to write out a record type giving the names of the
2640 bounds for debugging purposes, do it now and make the record
2641 type a parallel type. This is not needed for a packed array
2642 since the bounds are conveyed by the original array type. */
2643 if (need_index_type_struct
2645 && !Is_Packed_Array_Impl_Type (gnat_entity))
2647 tree gnu_bound_rec = make_node (RECORD_TYPE);
2648 tree gnu_field_list = NULL_TREE;
2651 TYPE_NAME (gnu_bound_rec)
2652 = create_concat_name (gnat_entity, "XA");
2654 for (index = ndim - 1; index >= 0; index--)
2656 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2657 tree gnu_index_name = TYPE_IDENTIFIER (gnu_index);
2659 /* Make sure to reference the types themselves, and not just
2660 their names, as the debugger may fall back on them. */
2661 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2662 gnu_bound_rec, NULL_TREE,
2664 DECL_CHAIN (gnu_field) = gnu_field_list;
2665 gnu_field_list = gnu_field;
2668 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2669 add_parallel_type (gnu_type, gnu_bound_rec);
2672 /* If this is a packed array type, make the original array type a
2673 parallel type. Otherwise, do it for the base array type if it
2674 isn't artificial to make sure it is kept in the debug info. */
2677 if (Is_Packed_Array_Impl_Type (gnat_entity)
2678 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2679 add_parallel_type (gnu_type,
2681 (Original_Array_Type (gnat_entity)));
2685 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
2686 if (!DECL_ARTIFICIAL (gnu_base_decl))
2687 add_parallel_type (gnu_type,
2688 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2692 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2693 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2694 = (Is_Packed_Array_Impl_Type (gnat_entity)
2695 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2697 /* If the size is self-referential and the maximum size doesn't
2698 overflow, use it. */
2699 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2701 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2702 && TREE_OVERFLOW (gnu_max_size))
2703 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2704 && TREE_OVERFLOW (gnu_max_size_unit)))
2706 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2707 TYPE_SIZE (gnu_type));
2708 TYPE_SIZE_UNIT (gnu_type)
2709 = size_binop (MIN_EXPR, gnu_max_size_unit,
2710 TYPE_SIZE_UNIT (gnu_type));
2713 /* Set our alias set to that of our base type. This gives all
2714 array subtypes the same alias set. */
2715 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2717 /* If this is a packed type, make this type the same as the packed
2718 array type, but do some adjusting in the type first. */
2719 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2721 Entity_Id gnat_index;
2724 /* First finish the type we had been making so that we output
2725 debugging information for it. */
2726 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
2727 if (Treat_As_Volatile (gnat_entity))
2729 = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
2730 /* Make it artificial only if the base type was artificial too.
2731 That's sort of "morally" true and will make it possible for
2732 the debugger to look it up by name in DWARF, which is needed
2733 in order to decode the packed array type. */
2735 = create_type_decl (gnu_entity_name, gnu_type,
2736 !Comes_From_Source (Etype (gnat_entity))
2737 && !Comes_From_Source (gnat_entity),
2738 debug_info_p, gnat_entity);
2740 /* Save it as our equivalent in case the call below elaborates
2742 save_gnu_tree (gnat_entity, gnu_decl, false);
2745 = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
2747 this_made_decl = true;
2748 gnu_type = TREE_TYPE (gnu_decl);
2749 save_gnu_tree (gnat_entity, NULL_TREE, false);
2751 gnu_inner = gnu_type;
2752 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2753 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2754 || TYPE_PADDING_P (gnu_inner)))
2755 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2757 /* We need to attach the index type to the type we just made so
2758 that the actual bounds can later be put into a template. */
2759 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2760 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2761 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2762 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2764 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2766 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2767 TYPE_MODULUS for modular types so we make an extra
2768 subtype if necessary. */
2769 if (TYPE_MODULAR_P (gnu_inner))
2772 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2773 TREE_TYPE (gnu_subtype) = gnu_inner;
2774 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2775 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2776 TYPE_MIN_VALUE (gnu_inner));
2777 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2778 TYPE_MAX_VALUE (gnu_inner));
2779 gnu_inner = gnu_subtype;
2782 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2784 #ifdef ENABLE_CHECKING
2785 /* Check for other cases of overloading. */
2786 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2790 for (gnat_index = First_Index (gnat_entity);
2791 Present (gnat_index);
2792 gnat_index = Next_Index (gnat_index))
2793 SET_TYPE_ACTUAL_BOUNDS
2795 tree_cons (NULL_TREE,
2796 get_unpadded_type (Etype (gnat_index)),
2797 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2799 if (Convention (gnat_entity) != Convention_Fortran)
2800 SET_TYPE_ACTUAL_BOUNDS
2801 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2803 if (TREE_CODE (gnu_type) == RECORD_TYPE
2804 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2805 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2810 /* Abort if packed array with no Packed_Array_Impl_Type. */
2811 gcc_assert (!Is_Packed (gnat_entity));
2815 case E_String_Literal_Subtype:
2816 /* Create the type for a string literal. */
2818 Entity_Id gnat_full_type
2819 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2820 && Present (Full_View (Etype (gnat_entity)))
2821 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2822 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2823 tree gnu_string_array_type
2824 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2825 tree gnu_string_index_type
2826 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2827 (TYPE_DOMAIN (gnu_string_array_type))));
2828 tree gnu_lower_bound
2829 = convert (gnu_string_index_type,
2830 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2832 = UI_To_gnu (String_Literal_Length (gnat_entity),
2833 gnu_string_index_type);
2834 tree gnu_upper_bound
2835 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2837 int_const_binop (MINUS_EXPR, gnu_length,
2838 convert (gnu_string_index_type,
2839 integer_one_node)));
2841 = create_index_type (convert (sizetype, gnu_lower_bound),
2842 convert (sizetype, gnu_upper_bound),
2843 create_range_type (gnu_string_index_type,
2849 = build_nonshared_array_type (gnat_to_gnu_type
2850 (Component_Type (gnat_entity)),
2852 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2853 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2854 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2858 /* Record Types and Subtypes
2860 The following fields are defined on record types:
2862 Has_Discriminants True if the record has discriminants
2863 First_Discriminant Points to head of list of discriminants
2864 First_Entity Points to head of list of fields
2865 Is_Tagged_Type True if the record is tagged
2867 Implementation of Ada records and discriminated records:
2869 A record type definition is transformed into the equivalent of a C
2870 struct definition. The fields that are the discriminants which are
2871 found in the Full_Type_Declaration node and the elements of the
2872 Component_List found in the Record_Type_Definition node. The
2873 Component_List can be a recursive structure since each Variant of
2874 the Variant_Part of the Component_List has a Component_List.
2876 Processing of a record type definition comprises starting the list of
2877 field declarations here from the discriminants and the calling the
2878 function components_to_record to add the rest of the fields from the
2879 component list and return the gnu type node. The function
2880 components_to_record will call itself recursively as it traverses
2884 if (Has_Complex_Representation (gnat_entity))
2887 = build_complex_type
2889 (Etype (Defining_Entity
2890 (First (Component_Items
2893 (Declaration_Node (gnat_entity)))))))));
2899 Node_Id full_definition = Declaration_Node (gnat_entity);
2900 Node_Id record_definition = Type_Definition (full_definition);
2901 Node_Id gnat_constr;
2902 Entity_Id gnat_field;
2903 tree gnu_field, gnu_field_list = NULL_TREE;
2904 tree gnu_get_parent;
2905 /* Set PACKED in keeping with gnat_to_gnu_field. */
2907 = Is_Packed (gnat_entity)
2909 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2911 : (Known_Alignment (gnat_entity)
2912 || (Strict_Alignment (gnat_entity)
2913 && Known_RM_Size (gnat_entity)))
2916 const bool has_discr = Has_Discriminants (gnat_entity);
2917 const bool has_rep = Has_Specified_Layout (gnat_entity);
2918 const bool is_extension
2919 = (Is_Tagged_Type (gnat_entity)
2920 && Nkind (record_definition) == N_Derived_Type_Definition);
2921 const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2922 bool all_rep = has_rep;
2924 /* See if all fields have a rep clause. Stop when we find one
2927 for (gnat_field = First_Entity (gnat_entity);
2928 Present (gnat_field);
2929 gnat_field = Next_Entity (gnat_field))
2930 if ((Ekind (gnat_field) == E_Component
2931 || Ekind (gnat_field) == E_Discriminant)
2932 && No (Component_Clause (gnat_field)))
2938 /* If this is a record extension, go a level further to find the
2939 record definition. Also, verify we have a Parent_Subtype. */
2942 if (!type_annotate_only
2943 || Present (Record_Extension_Part (record_definition)))
2944 record_definition = Record_Extension_Part (record_definition);
2946 gcc_assert (type_annotate_only
2947 || Present (Parent_Subtype (gnat_entity)));
2950 /* Make a node for the record. If we are not defining the record,
2951 suppress expanding incomplete types. */
2952 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2953 TYPE_NAME (gnu_type) = gnu_entity_name;
2954 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2955 if (Reverse_Storage_Order (gnat_entity))
2956 sorry ("non-default Scalar_Storage_Order");
2957 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
2961 defer_incomplete_level++;
2962 this_deferred = true;
2965 /* If both a size and rep clause was specified, put the size in
2966 the record type now so that it can get the proper mode. */
2967 if (has_rep && Known_RM_Size (gnat_entity))
2968 TYPE_SIZE (gnu_type)
2969 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2971 /* Always set the alignment here so that it can be used to
2972 set the mode, if it is making the alignment stricter. If
2973 it is invalid, it will be checked again below. If this is to
2974 be Atomic, choose a default alignment of a word unless we know
2975 the size and it's smaller. */
2976 if (Known_Alignment (gnat_entity))
2977 TYPE_ALIGN (gnu_type)
2978 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2979 else if (Is_Atomic (gnat_entity) && Known_Esize (gnat_entity))
2981 unsigned int size = UI_To_Int (Esize (gnat_entity));
2982 TYPE_ALIGN (gnu_type)
2983 = size >= BITS_PER_WORD ? BITS_PER_WORD : ceil_pow2 (size);
2985 /* If a type needs strict alignment, the minimum size will be the
2986 type size instead of the RM size (see validate_size). Cap the
2987 alignment, lest it causes this type size to become too large. */
2988 else if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity))
2990 unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity));
2991 unsigned int raw_align = raw_size & -raw_size;
2992 if (raw_align < BIGGEST_ALIGNMENT)
2993 TYPE_ALIGN (gnu_type) = raw_align;
2996 TYPE_ALIGN (gnu_type) = 0;
2998 /* If we have a Parent_Subtype, make a field for the parent. If
2999 this record has rep clauses, force the position to zero. */
3000 if (Present (Parent_Subtype (gnat_entity)))
3002 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
3003 tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
3006 /* A major complexity here is that the parent subtype will
3007 reference our discriminants in its Stored_Constraint list.
3008 But those must reference the parent component of this record
3009 which is precisely of the parent subtype we have not built yet!
3010 To break the circle we first build a dummy COMPONENT_REF which
3011 represents the "get to the parent" operation and initialize
3012 each of those discriminants to a COMPONENT_REF of the above
3013 dummy parent referencing the corresponding discriminant of the
3014 base type of the parent subtype. */
3015 gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type,
3016 build0 (PLACEHOLDER_EXPR, gnu_type),
3017 build_decl (input_location,
3018 FIELD_DECL, NULL_TREE,
3019 gnu_dummy_parent_type),
3023 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3024 Present (gnat_field);
3025 gnat_field = Next_Stored_Discriminant (gnat_field))
3026 if (Present (Corresponding_Discriminant (gnat_field)))
3029 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3033 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3034 gnu_get_parent, gnu_field, NULL_TREE),
3038 /* Then we build the parent subtype. If it has discriminants but
3039 the type itself has unknown discriminants, this means that it
3040 doesn't contain information about how the discriminants are
3041 derived from those of the ancestor type, so it cannot be used
3042 directly. Instead it is built by cloning the parent subtype
3043 of the underlying record view of the type, for which the above
3044 derivation of discriminants has been made explicit. */
3045 if (Has_Discriminants (gnat_parent)
3046 && Has_Unknown_Discriminants (gnat_entity))
3048 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3050 /* If we are defining the type, the underlying record
3051 view must already have been elaborated at this point.
3052 Otherwise do it now as its parent subtype cannot be
3053 technically elaborated on its own. */
3055 gcc_assert (present_gnu_tree (gnat_uview));
3057 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
3059 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3061 /* Substitute the "get to the parent" of the type for that
3062 of its underlying record view in the cloned type. */
3063 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3064 Present (gnat_field);
3065 gnat_field = Next_Stored_Discriminant (gnat_field))
3066 if (Present (Corresponding_Discriminant (gnat_field)))
3068 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3070 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3071 gnu_get_parent, gnu_field, NULL_TREE);
3073 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3077 gnu_parent = gnat_to_gnu_type (gnat_parent);
3079 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3080 initially built. The discriminants must reference the fields
3081 of the parent subtype and not those of its base type for the
3082 placeholder machinery to properly work. */
3085 /* The actual parent subtype is the full view. */
3086 if (IN (Ekind (gnat_parent), Private_Kind))
3088 if (Present (Full_View (gnat_parent)))
3089 gnat_parent = Full_View (gnat_parent);
3091 gnat_parent = Underlying_Full_View (gnat_parent);
3094 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3095 Present (gnat_field);
3096 gnat_field = Next_Stored_Discriminant (gnat_field))
3097 if (Present (Corresponding_Discriminant (gnat_field)))
3099 Entity_Id field = Empty;
3100 for (field = First_Stored_Discriminant (gnat_parent);
3102 field = Next_Stored_Discriminant (field))
3103 if (same_discriminant_p (gnat_field, field))
3105 gcc_assert (Present (field));
3106 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3107 = gnat_to_gnu_field_decl (field);
3111 /* The "get to the parent" COMPONENT_REF must be given its
3113 TREE_TYPE (gnu_get_parent) = gnu_parent;
3115 /* ...and reference the _Parent field of this record. */
3117 = create_field_decl (parent_name_id,
3118 gnu_parent, gnu_type,
3120 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3122 ? bitsize_zero_node : NULL_TREE,
3124 DECL_INTERNAL_P (gnu_field) = 1;
3125 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3126 TYPE_FIELDS (gnu_type) = gnu_field;
3129 /* Make the fields for the discriminants and put them into the record
3130 unless it's an Unchecked_Union. */
3132 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3133 Present (gnat_field);
3134 gnat_field = Next_Stored_Discriminant (gnat_field))
3136 /* If this is a record extension and this discriminant is the
3137 renaming of another discriminant, we've handled it above. */
3138 if (Present (Parent_Subtype (gnat_entity))
3139 && Present (Corresponding_Discriminant (gnat_field)))
3143 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3146 /* Make an expression using a PLACEHOLDER_EXPR from the
3147 FIELD_DECL node just created and link that with the
3148 corresponding GNAT defining identifier. */
3149 save_gnu_tree (gnat_field,
3150 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3151 build0 (PLACEHOLDER_EXPR, gnu_type),
3152 gnu_field, NULL_TREE),
3155 if (!is_unchecked_union)
3157 DECL_CHAIN (gnu_field) = gnu_field_list;
3158 gnu_field_list = gnu_field;
3162 /* If we have a derived untagged type that renames discriminants in
3163 the root type, the (stored) discriminants are a just copy of the
3164 discriminants of the root type. This means that any constraints
3165 added by the renaming in the derivation are disregarded as far
3166 as the layout of the derived type is concerned. To rescue them,
3167 we change the type of the (stored) discriminants to a subtype
3168 with the bounds of the type of the visible discriminants. */
3171 && Stored_Constraint (gnat_entity) != No_Elist)
3172 for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
3173 gnat_constr != No_Elmt;
3174 gnat_constr = Next_Elmt (gnat_constr))
3175 if (Nkind (Node (gnat_constr)) == N_Identifier
3176 /* Ignore access discriminants. */
3177 && !Is_Access_Type (Etype (Node (gnat_constr)))
3178 && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
3180 Entity_Id gnat_discr = Entity (Node (gnat_constr));
3181 tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
3183 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
3186 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3187 just above for one of the stored discriminants. */
3188 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
3190 if (gnu_discr_type != TREE_TYPE (gnu_ref))
3192 const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref));
3194 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref))
3195 ? make_unsigned_type (prec) : make_signed_type (prec);
3196 TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref);
3197 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
3198 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
3199 TYPE_MIN_VALUE (gnu_discr_type));
3200 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
3201 TYPE_MAX_VALUE (gnu_discr_type));
3203 = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype;
3207 /* Add the fields into the record type and finish it up. */
3208 components_to_record (gnu_type, Component_List (record_definition),
3209 gnu_field_list, packed, definition, false,
3210 all_rep, is_unchecked_union,
3211 !Comes_From_Source (gnat_entity), debug_info_p,
3212 false, OK_To_Reorder_Components (gnat_entity),
3213 all_rep ? NULL_TREE : bitsize_zero_node, NULL);
3215 /* If it is passed by reference, force BLKmode to ensure that objects
3216 of this type will always be put in memory. */
3217 if (TYPE_MODE (gnu_type) != BLKmode
3218 && Is_By_Reference_Type (gnat_entity))
3219 SET_TYPE_MODE (gnu_type, BLKmode);
3221 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3223 /* Fill in locations of fields. */
3224 annotate_rep (gnat_entity, gnu_type);
3226 /* If there are any entities in the chain corresponding to components
3227 that we did not elaborate, ensure we elaborate their types if they
3229 for (gnat_temp = First_Entity (gnat_entity);
3230 Present (gnat_temp);
3231 gnat_temp = Next_Entity (gnat_temp))
3232 if ((Ekind (gnat_temp) == E_Component
3233 || Ekind (gnat_temp) == E_Discriminant)
3234 && Is_Itype (Etype (gnat_temp))
3235 && !present_gnu_tree (gnat_temp))
3236 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3238 /* If this is a record type associated with an exception definition,
3239 equate its fields to those of the standard exception type. This
3240 will make it possible to convert between them. */
3241 if (gnu_entity_name == exception_data_name_id)
3244 for (gnu_field = TYPE_FIELDS (gnu_type),
3245 gnu_std_field = TYPE_FIELDS (except_type_node);
3247 gnu_field = DECL_CHAIN (gnu_field),
3248 gnu_std_field = DECL_CHAIN (gnu_std_field))
3249 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3250 gcc_assert (!gnu_std_field);
3255 case E_Class_Wide_Subtype:
3256 /* If an equivalent type is present, that is what we should use.
3257 Otherwise, fall through to handle this like a record subtype
3258 since it may have constraints. */
3259 if (gnat_equiv_type != gnat_entity)
3261 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3262 maybe_present = true;
3266 /* ... fall through ... */
3268 case E_Record_Subtype:
3269 /* If Cloned_Subtype is Present it means this record subtype has
3270 identical layout to that type or subtype and we should use
3271 that GCC type for this one. The front end guarantees that
3272 the component list is shared. */
3273 if (Present (Cloned_Subtype (gnat_entity)))
3275 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3277 maybe_present = true;
3281 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3282 changing the type, make a new type with each field having the type of
3283 the field in the new subtype but the position computed by transforming
3284 every discriminant reference according to the constraints. We don't
3285 see any difference between private and non-private type here since
3286 derivations from types should have been deferred until the completion
3287 of the private type. */
3290 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3295 defer_incomplete_level++;
3296 this_deferred = true;
3299 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
3301 if (present_gnu_tree (gnat_entity))
3303 maybe_present = true;
3307 /* If this is a record subtype associated with a dispatch table,
3308 strip the suffix. This is necessary to make sure 2 different
3309 subtypes associated with the imported and exported views of a
3310 dispatch table are properly merged in LTO mode. */
3311 if (Is_Dispatch_Table_Entity (gnat_entity))
3314 Get_Encoded_Name (gnat_entity);
3315 p = strchr (Name_Buffer, '_');
3317 strcpy (p+2, "dtS");
3318 gnu_entity_name = get_identifier (Name_Buffer);
3321 /* When the subtype has discriminants and these discriminants affect
3322 the initial shape it has inherited, factor them in. But for an
3323 Unchecked_Union (it must be an Itype), just return the type.
3324 We can't just test Is_Constrained because private subtypes without
3325 discriminants of types with discriminants with default expressions
3326 are Is_Constrained but aren't constrained! */
3327 if (IN (Ekind (gnat_base_type), Record_Kind)
3328 && !Is_Unchecked_Union (gnat_base_type)
3329 && !Is_For_Access_Subtype (gnat_entity)
3330 && Has_Discriminants (gnat_entity)
3331 && Is_Constrained (gnat_entity)
3332 && Stored_Constraint (gnat_entity) != No_Elist)
3334 vec<subst_pair> gnu_subst_list
3335 = build_subst_list (gnat_entity, gnat_base_type, definition);
3336 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part;
3337 tree gnu_pos_list, gnu_field_list = NULL_TREE;
3338 bool selected_variant = false, all_constant_pos = true;
3339 Entity_Id gnat_field;
3340 vec<variant_desc> gnu_variant_list;
3342 gnu_type = make_node (RECORD_TYPE);
3343 TYPE_NAME (gnu_type) = gnu_entity_name;
3344 TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
3345 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3347 /* Set the size, alignment and alias set of the new type to
3348 match that of the old one, doing required substitutions. */
3349 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3352 if (TYPE_IS_PADDING_P (gnu_base_type))
3353 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3355 gnu_unpad_base_type = gnu_base_type;
3357 /* Look for REP and variant parts in the base type. */
3358 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
3359 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
3361 /* If there is a variant part, we must compute whether the
3362 constraints statically select a particular variant. If
3363 so, we simply drop the qualified union and flatten the
3364 list of fields. Otherwise we'll build a new qualified
3365 union for the variants that are still relevant. */
3366 if (gnu_variant_part)
3372 = build_variant_list (TREE_TYPE (gnu_variant_part),
3376 /* If all the qualifiers are unconditionally true, the
3377 innermost variant is statically selected. */
3378 selected_variant = true;
3379 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3380 if (!integer_onep (v->qual))
3382 selected_variant = false;
3386 /* Otherwise, create the new variants. */
3387 if (!selected_variant)
3388 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3390 tree old_variant = v->type;
3391 tree new_variant = make_node (RECORD_TYPE);
3393 = concat_name (DECL_NAME (gnu_variant_part),
3395 (DECL_NAME (v->field)));
3396 TYPE_NAME (new_variant)
3397 = concat_name (TYPE_NAME (gnu_type),
3398 IDENTIFIER_POINTER (suffix));
3399 copy_and_substitute_in_size (new_variant, old_variant,
3401 v->new_type = new_variant;
3406 gnu_variant_list.create (0);
3407 selected_variant = false;
3410 /* Make a list of fields and their position in the base type. */
3412 = build_position_list (gnu_unpad_base_type,
3413 gnu_variant_list.exists ()
3414 && !selected_variant,
3415 size_zero_node, bitsize_zero_node,
3416 BIGGEST_ALIGNMENT, NULL_TREE);
3418 /* Now go down every component in the subtype and compute its
3419 size and position from those of the component in the base
3420 type and from the constraints of the subtype. */
3421 for (gnat_field = First_Entity (gnat_entity);
3422 Present (gnat_field);
3423 gnat_field = Next_Entity (gnat_field))
3424 if ((Ekind (gnat_field) == E_Component
3425 || Ekind (gnat_field) == E_Discriminant)
3426 && !(Present (Corresponding_Discriminant (gnat_field))
3427 && Is_Tagged_Type (gnat_base_type))
3429 (Scope (Original_Record_Component (gnat_field)))
3432 Name_Id gnat_name = Chars (gnat_field);
3433 Entity_Id gnat_old_field
3434 = Original_Record_Component (gnat_field);
3436 = gnat_to_gnu_field_decl (gnat_old_field);
3437 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3438 tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
3439 tree gnu_cont_type, gnu_last = NULL_TREE;
3441 /* If the type is the same, retrieve the GCC type from the
3442 old field to take into account possible adjustments. */
3443 if (Etype (gnat_field) == Etype (gnat_old_field))
3444 gnu_field_type = TREE_TYPE (gnu_old_field);
3446 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3448 /* If there was a component clause, the field types must be
3449 the same for the type and subtype, so copy the data from
3450 the old field to avoid recomputation here. Also if the
3451 field is justified modular and the optimization in
3452 gnat_to_gnu_field was applied. */
3453 if (Present (Component_Clause (gnat_old_field))
3454 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3455 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3456 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3457 == TREE_TYPE (gnu_old_field)))
3459 gnu_size = DECL_SIZE (gnu_old_field);
3460 gnu_field_type = TREE_TYPE (gnu_old_field);
3463 /* If the old field was packed and of constant size, we
3464 have to get the old size here, as it might differ from
3465 what the Etype conveys and the latter might overlap
3466 onto the following field. Try to arrange the type for
3467 possible better packing along the way. */
3468 else if (DECL_PACKED (gnu_old_field)
3469 && TREE_CODE (DECL_SIZE (gnu_old_field))
3472 gnu_size = DECL_SIZE (gnu_old_field);
3473 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
3474 && !TYPE_FAT_POINTER_P (gnu_field_type)
3475 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
3477 = make_packable_type (gnu_field_type, true);
3481 gnu_size = TYPE_SIZE (gnu_field_type);
3483 /* If the context of the old field is the base type or its
3484 REP part (if any), put the field directly in the new
3485 type; otherwise look up the context in the variant list
3486 and put the field either in the new type if there is a
3487 selected variant or in one of the new variants. */
3488 if (gnu_context == gnu_unpad_base_type
3490 && gnu_context == TREE_TYPE (gnu_rep_part)))
3491 gnu_cont_type = gnu_type;
3498 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
3499 if (gnu_context == v->type
3500 || ((rep_part = get_rep_part (v->type))
3501 && gnu_context == TREE_TYPE (rep_part)))
3505 if (selected_variant)
3506 gnu_cont_type = gnu_type;
3508 gnu_cont_type = v->new_type;
3511 /* The front-end may pass us "ghost" components if
3512 it fails to recognize that a constrained subtype
3513 is statically constrained. Discard them. */
3517 /* Now create the new field modeled on the old one. */
3519 = create_field_decl_from (gnu_old_field, gnu_field_type,
3520 gnu_cont_type, gnu_size,
3521 gnu_pos_list, gnu_subst_list);
3522 gnu_pos = DECL_FIELD_OFFSET (gnu_field);
3524 /* Put it in one of the new variants directly. */
3525 if (gnu_cont_type != gnu_type)
3527 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3528 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3531 /* To match the layout crafted in components_to_record,
3532 if this is the _Tag or _Parent field, put it before
3533 any other fields. */
3534 else if (gnat_name == Name_uTag
3535 || gnat_name == Name_uParent)
3536 gnu_field_list = chainon (gnu_field_list, gnu_field);
3538 /* Similarly, if this is the _Controller field, put
3539 it before the other fields except for the _Tag or
3541 else if (gnat_name == Name_uController && gnu_last)
3543 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
3544 DECL_CHAIN (gnu_last) = gnu_field;
3547 /* Otherwise, if this is a regular field, put it after
3548 the other fields. */
3551 DECL_CHAIN (gnu_field) = gnu_field_list;
3552 gnu_field_list = gnu_field;
3554 gnu_last = gnu_field;
3555 if (TREE_CODE (gnu_pos) != INTEGER_CST)
3556 all_constant_pos = false;
3559 save_gnu_tree (gnat_field, gnu_field, false);
3562 /* If there is a variant list, a selected variant and the fields
3563 all have a constant position, put them in order of increasing
3564 position to match that of constant CONSTRUCTORs. Likewise if
3565 there is no variant list but a REP part, since the latter has
3566 been flattened in the process. */
3567 if (((gnu_variant_list.exists () && selected_variant)
3568 || (!gnu_variant_list.exists () && gnu_rep_part))
3569 && all_constant_pos)
3571 const int len = list_length (gnu_field_list);
3572 tree *field_arr = XALLOCAVEC (tree, len), t;
3575 for (t = gnu_field_list, i = 0; t; t = DECL_CHAIN (t), i++)
3578 qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
3580 gnu_field_list = NULL_TREE;
3581 for (i = 0; i < len; i++)
3583 DECL_CHAIN (field_arr[i]) = gnu_field_list;
3584 gnu_field_list = field_arr[i];
3588 /* If there is a variant list and no selected variant, we need
3589 to create the nest of variant parts from the old nest. */
3590 else if (gnu_variant_list.exists () && !selected_variant)
3592 tree new_variant_part
3593 = create_variant_part_from (gnu_variant_part,
3594 gnu_variant_list, gnu_type,
3595 gnu_pos_list, gnu_subst_list);
3596 DECL_CHAIN (new_variant_part) = gnu_field_list;
3597 gnu_field_list = new_variant_part;
3600 /* Now go through the entities again looking for Itypes that
3601 we have not elaborated but should (e.g., Etypes of fields
3602 that have Original_Components). */
3603 for (gnat_field = First_Entity (gnat_entity);
3604 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3605 if ((Ekind (gnat_field) == E_Discriminant
3606 || Ekind (gnat_field) == E_Component)
3607 && !present_gnu_tree (Etype (gnat_field)))
3608 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3610 /* Do not emit debug info for the type yet since we're going to
3612 finish_record_type (gnu_type, nreverse (gnu_field_list), 2,
3614 compute_record_mode (gnu_type);
3616 /* See the E_Record_Type case for the rationale. */
3617 if (TYPE_MODE (gnu_type) != BLKmode
3618 && Is_By_Reference_Type (gnat_entity))
3619 SET_TYPE_MODE (gnu_type, BLKmode);
3621 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3623 /* Fill in locations of fields. */
3624 annotate_rep (gnat_entity, gnu_type);
3626 /* If debugging information is being written for the type, write
3627 a record that shows what we are a subtype of and also make a
3628 variable that indicates our size, if still variable. */
3631 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3632 tree gnu_unpad_base_name
3633 = TYPE_IDENTIFIER (gnu_unpad_base_type);
3634 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3636 TYPE_NAME (gnu_subtype_marker)
3637 = create_concat_name (gnat_entity, "XVS");
3638 finish_record_type (gnu_subtype_marker,
3639 create_field_decl (gnu_unpad_base_name,
3640 build_reference_type
3641 (gnu_unpad_base_type),
3643 NULL_TREE, NULL_TREE,
3647 add_parallel_type (gnu_type, gnu_subtype_marker);
3650 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3651 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3652 TYPE_SIZE_UNIT (gnu_subtype_marker)
3653 = create_var_decl (create_concat_name (gnat_entity,
3655 NULL_TREE, sizetype, gnu_size_unit,
3656 false, false, false, false, NULL,
3660 gnu_variant_list.release ();
3661 gnu_subst_list.release ();
3663 /* Now we can finalize it. */
3664 rest_of_record_type_compilation (gnu_type);
3667 /* Otherwise, go down all the components in the new type and make
3668 them equivalent to those in the base type. */
3671 gnu_type = gnu_base_type;
3673 for (gnat_temp = First_Entity (gnat_entity);
3674 Present (gnat_temp);
3675 gnat_temp = Next_Entity (gnat_temp))
3676 if ((Ekind (gnat_temp) == E_Discriminant
3677 && !Is_Unchecked_Union (gnat_base_type))
3678 || Ekind (gnat_temp) == E_Component)
3679 save_gnu_tree (gnat_temp,
3680 gnat_to_gnu_field_decl
3681 (Original_Record_Component (gnat_temp)),
3687 case E_Access_Subprogram_Type:
3688 /* Use the special descriptor type for dispatch tables if needed,
3689 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3690 Note that we are only required to do so for static tables in
3691 order to be compatible with the C++ ABI, but Ada 2005 allows
3692 to extend library level tagged types at the local level so
3693 we do it in the non-static case as well. */
3694 if (TARGET_VTABLE_USES_DESCRIPTORS
3695 && Is_Dispatch_Table_Entity (gnat_entity))
3697 gnu_type = fdesc_type_node;
3698 gnu_size = TYPE_SIZE (gnu_type);
3702 /* ... fall through ... */
3704 case E_Anonymous_Access_Subprogram_Type:
3705 /* If we are not defining this entity, and we have incomplete
3706 entities being processed above us, make a dummy type and
3707 fill it in later. */
3708 if (!definition && defer_incomplete_level != 0)
3710 struct incomplete *p = XNEW (struct incomplete);
3713 = build_pointer_type
3714 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3715 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3716 !Comes_From_Source (gnat_entity),
3717 debug_info_p, gnat_entity);
3718 this_made_decl = true;
3719 gnu_type = TREE_TYPE (gnu_decl);
3720 save_gnu_tree (gnat_entity, gnu_decl, false);
3723 p->old_type = TREE_TYPE (gnu_type);
3724 p->full_type = Directly_Designated_Type (gnat_entity);
3725 p->next = defer_incomplete_list;
3726 defer_incomplete_list = p;
3730 /* ... fall through ... */
3732 case E_Allocator_Type:
3734 case E_Access_Attribute_Type:
3735 case E_Anonymous_Access_Type:
3736 case E_General_Access_Type:
3738 /* The designated type and its equivalent type for gigi. */
3739 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3740 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3741 /* Whether it comes from a limited with. */
3742 bool is_from_limited_with
3743 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3744 && From_Limited_With (gnat_desig_equiv));
3745 /* The "full view" of the designated type. If this is an incomplete
3746 entity from a limited with, treat its non-limited view as the full
3747 view. Otherwise, if this is an incomplete or private type, use the
3748 full view. In the former case, we might point to a private type,
3749 in which case, we need its full view. Also, we want to look at the
3750 actual type used for the representation, so this takes a total of
3752 Entity_Id gnat_desig_full_direct_first
3753 = (is_from_limited_with
3754 ? Non_Limited_View (gnat_desig_equiv)
3755 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3756 ? Full_View (gnat_desig_equiv) : Empty));
3757 Entity_Id gnat_desig_full_direct
3758 = ((is_from_limited_with
3759 && Present (gnat_desig_full_direct_first)
3760 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3761 ? Full_View (gnat_desig_full_direct_first)
3762 : gnat_desig_full_direct_first);
3763 Entity_Id gnat_desig_full
3764 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3765 /* The type actually used to represent the designated type, either
3766 gnat_desig_full or gnat_desig_equiv. */
3767 Entity_Id gnat_desig_rep;
3768 /* True if this is a pointer to an unconstrained array. */
3769 bool is_unconstrained_array;
3770 /* We want to know if we'll be seeing the freeze node for any
3771 incomplete type we may be pointing to. */
3773 = (Present (gnat_desig_full)
3774 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3775 : In_Extended_Main_Code_Unit (gnat_desig_type));
3776 /* True if we make a dummy type here. */
3777 bool made_dummy = false;
3778 /* The mode to be used for the pointer type. */
3779 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3780 /* The GCC type used for the designated type. */
3781 tree gnu_desig_type = NULL_TREE;
3783 if (!targetm.valid_pointer_mode (p_mode))
3786 /* If either the designated type or its full view is an unconstrained
3787 array subtype, replace it with the type it's a subtype of. This
3788 avoids problems with multiple copies of unconstrained array types.
3789 Likewise, if the designated type is a subtype of an incomplete
3790 record type, use the parent type to avoid order of elaboration
3791 issues. This can lose some code efficiency, but there is no
3793 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3794 && !Is_Constrained (gnat_desig_equiv))
3795 gnat_desig_equiv = Etype (gnat_desig_equiv);
3796 if (Present (gnat_desig_full)
3797 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3798 && !Is_Constrained (gnat_desig_full))
3799 || (Ekind (gnat_desig_full) == E_Record_Subtype
3800 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3801 gnat_desig_full = Etype (gnat_desig_full);
3803 /* Set the type that's actually the representation of the designated
3804 type and also flag whether we have a unconstrained array. */
3806 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3807 is_unconstrained_array
3808 = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
3810 /* If we are pointing to an incomplete type whose completion is an
3811 unconstrained array, make dummy fat and thin pointer types to it.
3812 Likewise if the type itself is dummy or an unconstrained array. */
3813 if (is_unconstrained_array
3814 && (Present (gnat_desig_full)
3815 || (present_gnu_tree (gnat_desig_equiv)
3817 (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
3819 && defer_incomplete_level != 0
3820 && !present_gnu_tree (gnat_desig_equiv))
3822 && is_from_limited_with
3823 && Present (Freeze_Node (gnat_desig_equiv)))))
3825 if (present_gnu_tree (gnat_desig_rep))
3826 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3829 gnu_desig_type = make_dummy_type (gnat_desig_rep);
3833 /* If the call above got something that has a pointer, the pointer
3834 is our type. This could have happened either because the type
3835 was elaborated or because somebody else executed the code. */
3836 if (!TYPE_POINTER_TO (gnu_desig_type))
3837 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3838 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3841 /* If we already know what the full type is, use it. */
3842 else if (Present (gnat_desig_full)
3843 && present_gnu_tree (gnat_desig_full))
3844 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3846 /* Get the type of the thing we are to point to and build a pointer to
3847 it. If it is a reference to an incomplete or private type with a
3848 full view that is a record, make a dummy type node and get the
3849 actual type later when we have verified it is safe. */
3850 else if ((!in_main_unit
3851 && !present_gnu_tree (gnat_desig_equiv)
3852 && Present (gnat_desig_full)
3853 && !present_gnu_tree (gnat_desig_full)
3854 && Is_Record_Type (gnat_desig_full))
3855 /* Likewise if we are pointing to a record or array and we are
3856 to defer elaborating incomplete types. We do this as this
3857 access type may be the full view of a private type. Note
3858 that the unconstrained array case is handled above. */
3859 || ((!in_main_unit || imported_p)
3860 && defer_incomplete_level != 0
3861 && !present_gnu_tree (gnat_desig_equiv)
3862 && (Is_Record_Type (gnat_desig_rep)
3863 || Is_Array_Type (gnat_desig_rep)))
3864 /* If this is a reference from a limited_with type back to our
3865 main unit and there's a freeze node for it, either we have
3866 already processed the declaration and made the dummy type,
3867 in which case we just reuse the latter, or we have not yet,
3868 in which case we make the dummy type and it will be reused
3869 when the declaration is finally processed. In both cases,
3870 the pointer eventually created below will be automatically
3871 adjusted when the freeze node is processed. Note that the
3872 unconstrained array case is handled above. */
3874 && is_from_limited_with
3875 && Present (Freeze_Node (gnat_desig_rep))))
3877 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3881 /* Otherwise handle the case of a pointer to itself. */
3882 else if (gnat_desig_equiv == gnat_entity)
3885 = build_pointer_type_for_mode (void_type_node, p_mode,
3886 No_Strict_Aliasing (gnat_entity));
3887 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3890 /* If expansion is disabled, the equivalent type of a concurrent type
3891 is absent, so build a dummy pointer type. */
3892 else if (type_annotate_only && No (gnat_desig_equiv))
3893 gnu_type = ptr_void_type_node;
3895 /* Finally, handle the default case where we can just elaborate our
3898 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3900 /* It is possible that a call to gnat_to_gnu_type above resolved our
3901 type. If so, just return it. */
3902 if (present_gnu_tree (gnat_entity))
3904 maybe_present = true;
3908 /* If we haven't done it yet, build the pointer type the usual way. */
3911 /* Modify the designated type if we are pointing only to constant
3912 objects, but don't do it for unconstrained arrays. */
3913 if (Is_Access_Constant (gnat_entity)
3914 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3917 = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
3919 /* Some extra processing is required if we are building a
3920 pointer to an incomplete type (in the GCC sense). We might
3921 have such a type if we just made a dummy, or directly out
3922 of the call to gnat_to_gnu_type above if we are processing
3923 an access type for a record component designating the
3924 record type itself. */
3925 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3927 /* We must ensure that the pointer to variant we make will
3928 be processed by update_pointer_to when the initial type
3929 is completed. Pretend we made a dummy and let further
3930 processing act as usual. */
3933 /* We must ensure that update_pointer_to will not retrieve
3934 the dummy variant when building a properly qualified
3935 version of the complete type. We take advantage of the
3936 fact that get_qualified_type is requiring TYPE_NAMEs to
3937 match to influence build_qualified_type and then also
3938 update_pointer_to here. */
3939 TYPE_NAME (gnu_desig_type)
3940 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3945 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3946 No_Strict_Aliasing (gnat_entity));
3949 /* If we are not defining this object and we have made a dummy pointer,
3950 save our current definition, evaluate the actual type, and replace
3951 the tentative type we made with the actual one. If we are to defer
3952 actually looking up the actual type, make an entry in the deferred
3953 list. If this is from a limited with, we may have to defer to the
3954 end of the current unit. */
3955 if ((!in_main_unit || is_from_limited_with) && made_dummy)
3957 tree gnu_old_desig_type;
3959 if (TYPE_IS_FAT_POINTER_P (gnu_type))
3961 gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
3962 if (esize == POINTER_SIZE)
3963 gnu_type = build_pointer_type
3964 (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
3967 gnu_old_desig_type = TREE_TYPE (gnu_type);
3969 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
3970 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3971 !Comes_From_Source (gnat_entity),
3972 debug_info_p, gnat_entity);
3973 this_made_decl = true;
3974 gnu_type = TREE_TYPE (gnu_decl);
3975 save_gnu_tree (gnat_entity, gnu_decl, false);
3978 /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
3979 update gnu_old_desig_type directly, in which case it will not be
3980 a dummy type any more when we get into update_pointer_to.
3982 This can happen e.g. when the designated type is a record type,
3983 because their elaboration starts with an initial node from
3984 make_dummy_type, which may be the same node as the one we got.
3986 Besides, variants of this non-dummy type might have been created
3987 along the way. update_pointer_to is expected to properly take
3988 care of those situations. */
3989 if (defer_incomplete_level == 0 && !is_from_limited_with)
3991 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
3992 gnat_to_gnu_type (gnat_desig_equiv));
3996 struct incomplete *p = XNEW (struct incomplete);
3997 struct incomplete **head
3998 = (is_from_limited_with
3999 ? &defer_limited_with : &defer_incomplete_list);
4000 p->old_type = gnu_old_desig_type;
4001 p->full_type = gnat_desig_equiv;
4009 case E_Access_Protected_Subprogram_Type:
4010 case E_Anonymous_Access_Protected_Subprogram_Type:
4011 if (type_annotate_only && No (gnat_equiv_type))
4012 gnu_type = ptr_void_type_node;
4015 /* The run-time representation is the equivalent type. */
4016 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4017 maybe_present = true;
4020 if (Is_Itype (Directly_Designated_Type (gnat_entity))
4021 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
4022 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
4023 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
4024 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
4029 case E_Access_Subtype:
4031 /* We treat this as identical to its base type; any constraint is
4032 meaningful only to the front-end.
4034 The designated type must be elaborated as well, if it does
4035 not have its own freeze node. Designated (sub)types created
4036 for constrained components of records with discriminants are
4037 not frozen by the front-end and thus not elaborated by gigi,
4038 because their use may appear before the base type is frozen,
4039 and because it is not clear that they are needed anywhere in
4040 gigi. With the current model, there is no correct place where
4041 they could be elaborated. */
4043 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
4044 if (Is_Itype (Directly_Designated_Type (gnat_entity))
4045 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
4046 && Is_Frozen (Directly_Designated_Type (gnat_entity))
4047 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
4049 /* If we are not defining this entity, and we have incomplete
4050 entities being processed above us, make a dummy type and
4051 elaborate it later. */
4052 if (!definition && defer_incomplete_level != 0)
4054 struct incomplete *p = XNEW (struct incomplete);
4057 = make_dummy_type (Directly_Designated_Type (gnat_entity));
4058 p->full_type = Directly_Designated_Type (gnat_entity);
4059 p->next = defer_incomplete_list;
4060 defer_incomplete_list = p;
4062 else if (!IN (Ekind (Base_Type
4063 (Directly_Designated_Type (gnat_entity))),
4064 Incomplete_Or_Private_Kind))
4065 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
4069 maybe_present = true;
4072 /* Subprogram Entities
4074 The following access functions are defined for subprograms:
4076 Etype Return type or Standard_Void_Type.
4077 First_Formal The first formal parameter.
4078 Is_Imported Indicates that the subprogram has appeared in
4079 an INTERFACE or IMPORT pragma. For now we
4080 assume that the external language is C.
4081 Is_Exported Likewise but for an EXPORT pragma.
4082 Is_Inlined True if the subprogram is to be inlined.
4084 Each parameter is first checked by calling must_pass_by_ref on its
4085 type to determine if it is passed by reference. For parameters which
4086 are copied in, if they are Ada In Out or Out parameters, their return
4087 value becomes part of a record which becomes the return type of the
4088 function (C function - note that this applies only to Ada procedures
4089 so there is no Ada return type). Additional code to store back the
4090 parameters will be generated on the caller side. This transformation
4091 is done here, not in the front-end.
4093 The intended result of the transformation can be seen from the
4094 equivalent source rewritings that follow:
4096 struct temp {int a,b};
4097 procedure P (A,B: In Out ...) is temp P (int A,B)
4100 end P; return {A,B};
4107 For subprogram types we need to perform mainly the same conversions to
4108 GCC form that are needed for procedures and function declarations. The
4109 only difference is that at the end, we make a type declaration instead
4110 of a function declaration. */
4112 case E_Subprogram_Type:
4116 /* The type returned by a function or else Standard_Void_Type for a
4118 Entity_Id gnat_return_type = Etype (gnat_entity);
4119 tree gnu_return_type;
4120 /* The first GCC parameter declaration (a PARM_DECL node). The
4121 PARM_DECL nodes are chained through the DECL_CHAIN field, so this
4122 actually is the head of this parameter list. */
4123 tree gnu_param_list = NULL_TREE;
4124 /* Likewise for the stub associated with an exported procedure. */
4125 tree gnu_stub_param_list = NULL_TREE;
4126 /* Non-null for subprograms containing parameters passed by copy-in
4127 copy-out (Ada In Out or Out parameters not passed by reference),
4128 in which case it is the list of nodes used to specify the values
4129 of the In Out/Out parameters that are returned as a record upon
4130 procedure return. The TREE_PURPOSE of an element of this list is
4131 a field of the record and the TREE_VALUE is the PARM_DECL
4132 corresponding to that field. This list will be saved in the
4133 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
4134 tree gnu_cico_list = NULL_TREE;
4135 /* List of fields in return type of procedure with copy-in copy-out
4137 tree gnu_field_list = NULL_TREE;
4138 /* If an import pragma asks to map this subprogram to a GCC builtin,
4139 this is the builtin DECL node. */
4140 tree gnu_builtin_decl = NULL_TREE;
4141 /* For the stub associated with an exported procedure. */
4142 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
4143 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
4144 Entity_Id gnat_param;
4145 enum inline_status_t inline_status
4146 = Has_Pragma_No_Inline (gnat_entity)
4148 : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled);
4149 bool public_flag = Is_Public (gnat_entity) || imported_p;
4151 = (Is_Public (gnat_entity) && !definition) || imported_p;
4152 bool artificial_flag = !Comes_From_Source (gnat_entity);
4153 /* The semantics of "pure" in Ada essentially matches that of "const"
4154 in the back-end. In particular, both properties are orthogonal to
4155 the "nothrow" property if the EH circuitry is explicit in the
4156 internal representation of the back-end. If we are to completely
4157 hide the EH circuitry from it, we need to declare that calls to pure
4158 Ada subprograms that can throw have side effects since they can
4159 trigger an "abnormal" transfer of control flow; thus they can be
4160 neither "const" nor "pure" in the back-end sense. */
4162 = (Exception_Mechanism == Back_End_Exceptions
4163 && Is_Pure (gnat_entity));
4164 bool volatile_flag = No_Return (gnat_entity);
4165 bool return_by_direct_ref_p = false;
4166 bool return_by_invisi_ref_p = false;
4167 bool return_unconstrained_p = false;
4168 bool has_stub = false;
4171 /* A parameter may refer to this type, so defer completion of any
4172 incomplete types. */
4173 if (kind == E_Subprogram_Type && !definition)
4175 defer_incomplete_level++;
4176 this_deferred = true;
4179 /* If the subprogram has an alias, it is probably inherited, so
4180 we can use the original one. If the original "subprogram"
4181 is actually an enumeration literal, it may be the first use
4182 of its type, so we must elaborate that type now. */
4183 if (Present (Alias (gnat_entity)))
4185 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
4186 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
4188 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
4190 /* Elaborate any Itypes in the parameters of this entity. */
4191 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
4192 Present (gnat_temp);
4193 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4194 if (Is_Itype (Etype (gnat_temp)))
4195 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
4200 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
4201 corresponding DECL node. Proper generation of calls later on need
4202 proper parameter associations so we don't "break;" here. */
4203 if (Convention (gnat_entity) == Convention_Intrinsic
4204 && Present (Interface_Name (gnat_entity)))
4206 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
4208 /* Inability to find the builtin decl most often indicates a
4209 genuine mistake, but imports of unregistered intrinsics are
4210 sometimes issued on purpose to allow hooking in alternate
4211 bodies. We post a warning conditioned on Wshadow in this case,
4212 to let developers be notified on demand without risking false
4213 positives with common default sets of options. */
4215 if (gnu_builtin_decl == NULL_TREE && warn_shadow)
4216 post_error ("?gcc intrinsic not found for&!", gnat_entity);
4219 /* ??? What if we don't find the builtin node above ? warn ? err ?
4220 In the current state we neither warn nor err, and calls will just
4221 be handled as for regular subprograms. */
4223 /* Look into the return type and get its associated GCC tree. If it
4224 is not void, compute various flags for the subprogram type. */
4225 if (Ekind (gnat_return_type) == E_Void)
4226 gnu_return_type = void_type_node;
4229 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4230 context may now appear in parameter and result profiles. If
4231 we are only annotating types, break circularities here. */
4232 if (type_annotate_only
4233 && IN (Ekind (gnat_return_type), Incomplete_Kind)
4234 && From_Limited_With (gnat_return_type)
4235 && In_Extended_Main_Code_Unit
4236 (Non_Limited_View (gnat_return_type))
4237 && !present_gnu_tree (Non_Limited_View (gnat_return_type)))
4238 gnu_return_type = ptr_void_type_node;
4240 gnu_return_type = gnat_to_gnu_type (gnat_return_type);
4242 /* If this function returns by reference, make the actual return
4243 type the pointer type and make a note of that. */
4244 if (Returns_By_Ref (gnat_entity))
4246 gnu_return_type = build_pointer_type (gnu_return_type);
4247 return_by_direct_ref_p = true;
4250 /* If we are supposed to return an unconstrained array type, make
4251 the actual return type the fat pointer type. */
4252 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
4254 gnu_return_type = TREE_TYPE (gnu_return_type);
4255 return_unconstrained_p = true;
4258 /* Likewise, if the return type requires a transient scope, the
4259 return value will be allocated on the secondary stack so the
4260 actual return type is the pointer type. */
4261 else if (Requires_Transient_Scope (gnat_return_type))
4263 gnu_return_type = build_pointer_type (gnu_return_type);
4264 return_unconstrained_p = true;
4267 /* If the Mechanism is By_Reference, ensure this function uses the
4268 target's by-invisible-reference mechanism, which may not be the
4269 same as above (e.g. it might be passing an extra parameter). */
4270 else if (kind == E_Function
4271 && Mechanism (gnat_entity) == By_Reference)
4272 return_by_invisi_ref_p = true;
4274 /* Likewise, if the return type is itself By_Reference. */
4275 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
4276 return_by_invisi_ref_p = true;
4278 /* If the type is a padded type and the underlying type would not
4279 be passed by reference or the function has a foreign convention,
4280 return the underlying type. */
4281 else if (TYPE_IS_PADDING_P (gnu_return_type)
4282 && (!default_pass_by_ref
4283 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
4284 || Has_Foreign_Convention (gnat_entity)))
4285 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
4287 /* If the return type is unconstrained, that means it must have a
4288 maximum size. Use the padded type as the effective return type.
4289 And ensure the function uses the target's by-invisible-reference
4290 mechanism to avoid copying too much data when it returns. */
4291 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
4293 tree orig_type = gnu_return_type;
4296 = maybe_pad_type (gnu_return_type,
4297 max_size (TYPE_SIZE (gnu_return_type),
4299 0, gnat_entity, false, false, false, true);
4301 /* Declare it now since it will never be declared otherwise.
4302 This is necessary to ensure that its subtrees are properly
4304 if (gnu_return_type != orig_type
4305 && !DECL_P (TYPE_NAME (gnu_return_type)))
4306 create_type_decl (TYPE_NAME (gnu_return_type),
4307 gnu_return_type, true, debug_info_p,
4310 return_by_invisi_ref_p = true;
4313 /* If the return type has a size that overflows, we cannot have
4314 a function that returns that type. This usage doesn't make
4315 sense anyway, so give an error here. */
4316 if (TYPE_SIZE_UNIT (gnu_return_type)
4317 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
4318 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
4320 post_error ("cannot return type whose size overflows",
4322 gnu_return_type = copy_node (gnu_return_type);
4323 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
4324 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
4325 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
4326 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
4330 /* Loop over the parameters and get their associated GCC tree. While
4331 doing this, build a copy-in copy-out structure if we need one. */
4332 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
4333 Present (gnat_param);
4334 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
4336 Entity_Id gnat_param_type = Etype (gnat_param);
4337 tree gnu_param_name = get_entity_name (gnat_param);
4338 tree gnu_param_type, gnu_param, gnu_field;
4339 Mechanism_Type mech = Mechanism (gnat_param);
4340 bool copy_in_copy_out = false, fake_param_type;
4342 /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
4343 context may now appear in parameter and result profiles. If
4344 we are only annotating types, break circularities here. */
4345 if (type_annotate_only
4346 && IN (Ekind (gnat_param_type), Incomplete_Kind)
4347 && From_Limited_With (Etype (gnat_param_type))
4348 && In_Extended_Main_Code_Unit
4349 (Non_Limited_View (gnat_param_type))
4350 && !present_gnu_tree (Non_Limited_View (gnat_param_type)))
4352 gnu_param_type = ptr_void_type_node;
4353 fake_param_type = true;
4357 gnu_param_type = gnat_to_gnu_type (gnat_param_type);
4358 fake_param_type = false;
4361 /* Builtins are expanded inline and there is no real call sequence
4362 involved. So the type expected by the underlying expander is
4363 always the type of each argument "as is". */
4364 if (gnu_builtin_decl)
4366 /* Handle the first parameter of a valued procedure specially. */
4367 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
4368 mech = By_Copy_Return;
4369 /* Otherwise, see if a Mechanism was supplied that forced this
4370 parameter to be passed one way or another. */
4371 else if (mech == Default
4372 || mech == By_Copy || mech == By_Reference)
4374 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
4375 mech = By_Descriptor;
4377 else if (By_Short_Descriptor_Last <= mech &&
4378 mech <= By_Short_Descriptor)
4379 mech = By_Short_Descriptor;
4383 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
4384 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
4385 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
4387 mech = By_Reference;
4393 post_error ("unsupported mechanism for&", gnat_param);
4397 /* Do not call gnat_to_gnu_param for a fake parameter type since
4398 it will try to use the real type again. */
4399 if (fake_param_type)
4401 if (Ekind (gnat_param) == E_Out_Parameter)
4402 gnu_param = NULL_TREE;
4406 = create_param_decl (gnu_param_name, gnu_param_type,
4408 Set_Mechanism (gnat_param,
4409 mech == Default ? By_Copy : mech);
4410 if (Ekind (gnat_param) == E_In_Out_Parameter)
4411 copy_in_copy_out = true;
4416 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4417 Has_Foreign_Convention (gnat_entity),
4420 /* We are returned either a PARM_DECL or a type if no parameter
4421 needs to be passed; in either case, adjust the type. */
4422 if (DECL_P (gnu_param))
4423 gnu_param_type = TREE_TYPE (gnu_param);
4426 gnu_param_type = gnu_param;
4427 gnu_param = NULL_TREE;
4430 /* The failure of this assertion will very likely come from an
4431 order of elaboration issue for the type of the parameter. */
4432 gcc_assert (kind == E_Subprogram_Type
4433 || !TYPE_IS_DUMMY_P (gnu_param_type)
4434 || type_annotate_only);
4438 /* If it's an exported subprogram, we build a parameter list
4439 in parallel, in case we need to emit a stub for it. */
4440 if (Is_Exported (gnat_entity))
4443 = chainon (gnu_param, gnu_stub_param_list);
4444 /* Change By_Descriptor parameter to By_Reference for
4445 the internal version of an exported subprogram. */
4446 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4449 = gnat_to_gnu_param (gnat_param, By_Reference,
4455 gnu_param = copy_node (gnu_param);
4458 gnu_param_list = chainon (gnu_param, gnu_param_list);
4459 Sloc_to_locus (Sloc (gnat_param),
4460 &DECL_SOURCE_LOCATION (gnu_param));
4461 save_gnu_tree (gnat_param, gnu_param, false);
4463 /* If a parameter is a pointer, this function may modify
4464 memory through it and thus shouldn't be considered
4465 a const function. Also, the memory may be modified
4466 between two calls, so they can't be CSE'ed. The latter
4467 case also handles by-ref parameters. */
4468 if (POINTER_TYPE_P (gnu_param_type)
4469 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4473 if (copy_in_copy_out)
4477 tree gnu_new_ret_type = make_node (RECORD_TYPE);
4479 /* If this is a function, we also need a field for the
4480 return value to be placed. */
4481 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
4484 = create_field_decl (get_identifier ("RETVAL"),
4486 gnu_new_ret_type, NULL_TREE,
4488 Sloc_to_locus (Sloc (gnat_entity),
4489 &DECL_SOURCE_LOCATION (gnu_field));
4490 gnu_field_list = gnu_field;
4492 = tree_cons (gnu_field, void_type_node, NULL_TREE);
4495 gnu_return_type = gnu_new_ret_type;
4496 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4497 /* Set a default alignment to speed up accesses. But we
4498 shouldn't increase the size of the structure too much,
4499 lest it doesn't fit in return registers anymore. */
4500 TYPE_ALIGN (gnu_return_type)
4501 = get_mode_alignment (ptr_mode);
4505 = create_field_decl (gnu_param_name, gnu_param_type,
4506 gnu_return_type, NULL_TREE, NULL_TREE,
4508 Sloc_to_locus (Sloc (gnat_param),
4509 &DECL_SOURCE_LOCATION (gnu_field));
4510 DECL_CHAIN (gnu_field) = gnu_field_list;
4511 gnu_field_list = gnu_field;
4513 = tree_cons (gnu_field, gnu_param, gnu_cico_list);
4519 /* If we have a CICO list but it has only one entry, we convert
4520 this function into a function that returns this object. */
4521 if (list_length (gnu_cico_list) == 1)
4522 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
4524 /* Do not finalize the return type if the subprogram is stubbed
4525 since structures are incomplete for the back-end. */
4526 else if (Convention (gnat_entity) != Convention_Stubbed)
4528 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4531 /* Try to promote the mode of the return type if it is passed
4532 in registers, again to speed up accesses. */
4533 if (TYPE_MODE (gnu_return_type) == BLKmode
4534 && !targetm.calls.return_in_memory (gnu_return_type,
4538 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
4539 unsigned int i = BITS_PER_UNIT;
4540 enum machine_mode mode;
4544 mode = mode_for_size (i, MODE_INT, 0);
4545 if (mode != BLKmode)
4547 SET_TYPE_MODE (gnu_return_type, mode);
4548 TYPE_ALIGN (gnu_return_type)
4549 = GET_MODE_ALIGNMENT (mode);
4550 TYPE_SIZE (gnu_return_type)
4551 = bitsize_int (GET_MODE_BITSIZE (mode));
4552 TYPE_SIZE_UNIT (gnu_return_type)
4553 = size_int (GET_MODE_SIZE (mode));
4558 rest_of_record_type_compilation (gnu_return_type);
4562 /* Deal with platform-specific calling conventions. */
4563 if (Has_Stdcall_Convention (gnat_entity))
4564 prepend_one_attribute
4565 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4566 get_identifier ("stdcall"), NULL_TREE,
4568 else if (Has_Thiscall_Convention (gnat_entity))
4569 prepend_one_attribute
4570 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4571 get_identifier ("thiscall"), NULL_TREE,
4574 /* If we should request stack realignment for a foreign convention
4575 subprogram, do so. Note that this applies to task entry points
4577 if (FOREIGN_FORCE_REALIGN_STACK
4578 && Has_Foreign_Convention (gnat_entity))
4579 prepend_one_attribute
4580 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4581 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4584 /* Deal with a pragma Linker_Section on a subprogram. */
4585 if ((kind == E_Function || kind == E_Procedure)
4586 && Present (Linker_Section_Pragma (gnat_entity)))
4587 prepend_one_attribute_pragma (&attr_list,
4588 Linker_Section_Pragma (gnat_entity));
4590 /* The lists have been built in reverse. */
4591 gnu_param_list = nreverse (gnu_param_list);
4593 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4594 gnu_cico_list = nreverse (gnu_cico_list);
4596 if (kind == E_Function)
4597 Set_Mechanism (gnat_entity, return_unconstrained_p
4598 || return_by_direct_ref_p
4599 || return_by_invisi_ref_p
4600 ? By_Reference : By_Copy);
4602 = create_subprog_type (gnu_return_type, gnu_param_list,
4603 gnu_cico_list, return_unconstrained_p,
4604 return_by_direct_ref_p,
4605 return_by_invisi_ref_p);
4609 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4610 gnu_cico_list, return_unconstrained_p,
4611 return_by_direct_ref_p,
4612 return_by_invisi_ref_p);
4614 /* A subprogram (something that doesn't return anything) shouldn't
4615 be considered const since there would be no reason for such a
4616 subprogram. Note that procedures with Out (or In Out) parameters
4617 have already been converted into a function with a return type. */
4618 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4621 if (const_flag || volatile_flag)
4624 = (const_flag ? TYPE_QUAL_CONST : 0)
4625 | (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
4627 gnu_type = change_qualified_type (gnu_type, quals);
4630 gnu_stub_type = change_qualified_type (gnu_stub_type, quals);
4633 /* If we have a builtin decl for that function, use it. Check if the
4634 profiles are compatible and warn if they are not. The checker is
4635 expected to post extra diagnostics in this case. */
4636 if (gnu_builtin_decl)
4638 intrin_binding_t inb;
4640 inb.gnat_entity = gnat_entity;
4641 inb.ada_fntype = gnu_type;
4642 inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
4644 if (!intrin_profiles_compatible_p (&inb))
4646 ("?profile of& doesn''t match the builtin it binds!",
4649 gnu_decl = gnu_builtin_decl;
4650 gnu_type = TREE_TYPE (gnu_builtin_decl);
4654 /* If there was no specified Interface_Name and the external and
4655 internal names of the subprogram are the same, only use the
4656 internal name to allow disambiguation of nested subprograms. */
4657 if (No (Interface_Name (gnat_entity))
4658 && gnu_ext_name == gnu_entity_name)
4659 gnu_ext_name = NULL_TREE;
4661 /* If we are defining the subprogram and it has an Address clause
4662 we must get the address expression from the saved GCC tree for the
4663 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4664 the address expression here since the front-end has guaranteed
4665 in that case that the elaboration has no effects. If there is
4666 an Address clause and we are not defining the object, just
4667 make it a constant. */
4668 if (Present (Address_Clause (gnat_entity)))
4670 tree gnu_address = NULL_TREE;
4674 = (present_gnu_tree (gnat_entity)
4675 ? get_gnu_tree (gnat_entity)
4676 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4678 save_gnu_tree (gnat_entity, NULL_TREE, false);
4680 /* Convert the type of the object to a reference type that can
4681 alias everything as per 13.3(19). */
4683 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4685 gnu_address = convert (gnu_type, gnu_address);
4688 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4689 gnu_address, false, Is_Public (gnat_entity),
4690 extern_flag, false, NULL, gnat_entity);
4691 DECL_BY_REF_P (gnu_decl) = 1;
4694 else if (kind == E_Subprogram_Type)
4696 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4698 = create_type_decl (gnu_entity_name, gnu_type, artificial_flag,
4699 debug_info_p, gnat_entity);
4705 gnu_stub_name = gnu_ext_name;
4706 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4707 public_flag = false;
4708 artificial_flag = true;
4712 = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4713 gnu_param_list, inline_status,
4714 public_flag, extern_flag, artificial_flag,
4715 attr_list, gnat_entity);
4719 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4720 gnu_stub_type, gnu_stub_param_list,
4721 inline_status, true, extern_flag,
4722 false, attr_list, gnat_entity);
4723 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4726 /* This is unrelated to the stub built right above. */
4727 DECL_STUBBED_P (gnu_decl)
4728 = Convention (gnat_entity) == Convention_Stubbed;
4733 case E_Incomplete_Type:
4734 case E_Incomplete_Subtype:
4735 case E_Private_Type:
4736 case E_Private_Subtype:
4737 case E_Limited_Private_Type:
4738 case E_Limited_Private_Subtype:
4739 case E_Record_Type_With_Private:
4740 case E_Record_Subtype_With_Private:
4742 /* Get the "full view" of this entity. If this is an incomplete
4743 entity from a limited with, treat its non-limited view as the
4744 full view. Otherwise, use either the full view or the underlying
4745 full view, whichever is present. This is used in all the tests
4748 = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity))
4749 ? Non_Limited_View (gnat_entity)
4750 : Present (Full_View (gnat_entity))
4751 ? Full_View (gnat_entity)
4752 : Underlying_Full_View (gnat_entity);
4754 /* If this is an incomplete type with no full view, it must be a Taft
4755 Amendment type, in which case we return a dummy type. Otherwise,
4756 just get the type from its Etype. */
4759 if (kind == E_Incomplete_Type)
4761 gnu_type = make_dummy_type (gnat_entity);
4762 gnu_decl = TYPE_STUB_DECL (gnu_type);
4766 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4768 maybe_present = true;
4773 /* If we already made a type for the full view, reuse it. */
4774 else if (present_gnu_tree (full_view))
4776 gnu_decl = get_gnu_tree (full_view);
4780 /* Otherwise, if we are not defining the type now, get the type
4781 from the full view. But always get the type from the full view
4782 for define on use types, since otherwise we won't see them! */
4783 else if (!definition
4784 || (Is_Itype (full_view) && No (Freeze_Node (gnat_entity)))
4785 || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view))))
4787 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4788 maybe_present = true;
4792 /* For incomplete types, make a dummy type entry which will be
4793 replaced later. Save it as the full declaration's type so
4794 we can do any needed updates when we see it. */
4795 gnu_type = make_dummy_type (gnat_entity);
4796 gnu_decl = TYPE_STUB_DECL (gnu_type);
4797 if (Has_Completion_In_Body (gnat_entity))
4798 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4799 save_gnu_tree (full_view, gnu_decl, 0);
4803 case E_Class_Wide_Type:
4804 /* Class-wide types are always transformed into their root type. */
4805 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4806 maybe_present = true;
4810 case E_Task_Subtype:
4811 case E_Protected_Type:
4812 case E_Protected_Subtype:
4813 /* Concurrent types are always transformed into their record type. */
4814 if (type_annotate_only && No (gnat_equiv_type))
4815 gnu_type = void_type_node;
4817 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4818 maybe_present = true;
4822 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4827 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4828 we've already saved it, so we don't try to. */
4829 gnu_decl = error_mark_node;
4833 case E_Abstract_State:
4834 /* This is a SPARK annotation that only reaches here when compiling in
4835 ASIS mode and has no characteristics to annotate. */
4836 gcc_assert (type_annotate_only);
4837 return error_mark_node;
4843 /* If we had a case where we evaluated another type and it might have
4844 defined this one, handle it here. */
4845 if (maybe_present && present_gnu_tree (gnat_entity))
4847 gnu_decl = get_gnu_tree (gnat_entity);
4851 /* If we are processing a type and there is either no decl for it or
4852 we just made one, do some common processing for the type, such as
4853 handling alignment and possible padding. */
4854 if (is_type && (!gnu_decl || this_made_decl))
4856 /* Process the attributes, if not already done. Note that the type is
4857 already defined so we cannot pass true for IN_PLACE here. */
4858 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4860 /* Tell the middle-end that objects of tagged types are guaranteed to
4861 be properly aligned. This is necessary because conversions to the
4862 class-wide type are translated into conversions to the root type,
4863 which can be less aligned than some of its derived types. */
4864 if (Is_Tagged_Type (gnat_entity)
4865 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4866 TYPE_ALIGN_OK (gnu_type) = 1;
4868 /* Record whether the type is passed by reference. */
4869 if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4870 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4872 /* ??? Don't set the size for a String_Literal since it is either
4873 confirming or we don't handle it properly (if the low bound is
4875 if (!gnu_size && kind != E_String_Literal_Subtype)
4877 Uint gnat_size = Known_Esize (gnat_entity)
4878 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4880 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4881 false, Has_Size_Clause (gnat_entity));
4884 /* If a size was specified, see if we can make a new type of that size
4885 by rearranging the type, for example from a fat to a thin pointer. */
4889 = make_type_from_size (gnu_type, gnu_size,
4890 Has_Biased_Representation (gnat_entity));
4892 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4893 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4894 gnu_size = NULL_TREE;
4897 /* If the alignment has not already been processed and this is not
4898 an unconstrained array type, see if an alignment is specified.
4899 If not, we pick a default alignment for atomic objects. */
4900 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4902 else if (Known_Alignment (gnat_entity))
4904 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4905 TYPE_ALIGN (gnu_type));
4907 /* Warn on suspiciously large alignments. This should catch
4908 errors about the (alignment,byte)/(size,bit) discrepancy. */
4909 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4913 /* If a size was specified, take it into account. Otherwise
4914 use the RM size for records or unions as the type size has
4915 already been adjusted to the alignment. */
4918 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
4919 && !TYPE_FAT_POINTER_P (gnu_type))
4920 size = rm_size (gnu_type);
4922 size = TYPE_SIZE (gnu_type);
4924 /* Consider an alignment as suspicious if the alignment/size
4925 ratio is greater or equal to the byte/bit ratio. */
4926 if (tree_fits_uhwi_p (size)
4927 && align >= tree_to_uhwi (size) * BITS_PER_UNIT)
4928 post_error_ne ("?suspiciously large alignment specified for&",
4929 Expression (Alignment_Clause (gnat_entity)),
4933 else if (Is_Atomic (gnat_entity) && !gnu_size
4934 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
4935 && integer_pow2p (TYPE_SIZE (gnu_type)))
4936 align = MIN (BIGGEST_ALIGNMENT,
4937 tree_to_uhwi (TYPE_SIZE (gnu_type)));
4938 else if (Is_Atomic (gnat_entity) && gnu_size
4939 && tree_fits_uhwi_p (gnu_size)
4940 && integer_pow2p (gnu_size))
4941 align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
4943 /* See if we need to pad the type. If we did, and made a record,
4944 the name of the new type may be changed. So get it back for
4945 us when we make the new TYPE_DECL below. */
4946 if (gnu_size || align > 0)
4947 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4948 false, !gnu_decl, definition, false);
4950 if (TYPE_IS_PADDING_P (gnu_type))
4951 gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
4953 /* Now set the RM size of the type. We cannot do it before padding
4954 because we need to accept arbitrary RM sizes on integral types. */
4955 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4957 /* If we are at global level, GCC will have applied variable_size to
4958 the type, but that won't have done anything. So, if it's not
4959 a constant or self-referential, call elaborate_expression_1 to
4960 make a variable for the size rather than calculating it each time.
4961 Handle both the RM size and the actual size. */
4962 if (global_bindings_p ()
4963 && TYPE_SIZE (gnu_type)
4964 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4965 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4967 tree size = TYPE_SIZE (gnu_type);
4969 TYPE_SIZE (gnu_type)
4970 = elaborate_expression_1 (size, gnat_entity,
4971 get_identifier ("SIZE"),
4974 /* ??? For now, store the size as a multiple of the alignment in
4975 bytes so that we can see the alignment from the tree. */
4976 TYPE_SIZE_UNIT (gnu_type)
4977 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4978 get_identifier ("SIZE_A_UNIT"),
4980 TYPE_ALIGN (gnu_type));
4982 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4983 may not be marked by the call to create_type_decl below. */
4984 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4986 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4988 tree variant_part = get_variant_part (gnu_type);
4989 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4993 tree union_type = TREE_TYPE (variant_part);
4994 tree offset = DECL_FIELD_OFFSET (variant_part);
4996 /* If the position of the variant part is constant, subtract
4997 it from the size of the type of the parent to get the new
4998 size. This manual CSE reduces the data size. */
4999 if (TREE_CODE (offset) == INTEGER_CST)
5001 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
5002 TYPE_SIZE (union_type)
5003 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
5004 bit_from_pos (offset, bitpos));
5005 TYPE_SIZE_UNIT (union_type)
5006 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
5007 byte_from_pos (offset, bitpos));
5011 TYPE_SIZE (union_type)
5012 = elaborate_expression_1 (TYPE_SIZE (union_type),
5014 get_identifier ("VSIZE"),
5017 /* ??? For now, store the size as a multiple of the
5018 alignment in bytes so that we can see the alignment
5020 TYPE_SIZE_UNIT (union_type)
5021 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
5026 TYPE_ALIGN (union_type));
5028 /* ??? For now, store the offset as a multiple of the
5029 alignment in bytes so that we can see the alignment
5031 DECL_FIELD_OFFSET (variant_part)
5032 = elaborate_expression_2 (offset,
5034 get_identifier ("VOFFSET"),
5040 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
5041 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
5044 if (operand_equal_p (ada_size, size, 0))
5045 ada_size = TYPE_SIZE (gnu_type);
5048 = elaborate_expression_1 (ada_size, gnat_entity,
5049 get_identifier ("RM_SIZE"),
5051 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
5055 /* If this is a record type or subtype, call elaborate_expression_2 on
5056 any field position. Do this for both global and local types.
5057 Skip any fields that we haven't made trees for to avoid problems with
5058 class wide types. */
5059 if (IN (kind, Record_Kind))
5060 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
5061 gnat_temp = Next_Entity (gnat_temp))
5062 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
5064 tree gnu_field = get_gnu_tree (gnat_temp);
5066 /* ??? For now, store the offset as a multiple of the alignment
5067 in bytes so that we can see the alignment from the tree. */
5068 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
5070 DECL_FIELD_OFFSET (gnu_field)
5071 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
5073 get_identifier ("OFFSET"),
5075 DECL_OFFSET_ALIGN (gnu_field));
5077 /* ??? The context of gnu_field is not necessarily gnu_type
5078 so the MULT_EXPR node built above may not be marked by
5079 the call to create_type_decl below. */
5080 if (global_bindings_p ())
5081 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
5085 if (Is_Atomic (gnat_entity))
5086 check_ok_for_atomic (gnu_type, gnat_entity, false);
5088 /* If this is not an unconstrained array type, set some flags. */
5089 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5091 if (Treat_As_Volatile (gnat_entity))
5092 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
5094 if (Present (Alignment_Clause (gnat_entity)))
5095 TYPE_USER_ALIGN (gnu_type) = 1;
5097 if (Universal_Aliasing (gnat_entity))
5098 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
5102 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
5103 !Comes_From_Source (gnat_entity),
5104 debug_info_p, gnat_entity);
5107 TREE_TYPE (gnu_decl) = gnu_type;
5108 TYPE_STUB_DECL (gnu_type) = gnu_decl;
5112 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
5114 gnu_type = TREE_TYPE (gnu_decl);
5116 /* If this is a derived type, relate its alias set to that of its parent
5117 to avoid troubles when a call to an inherited primitive is inlined in
5118 a context where a derived object is accessed. The inlined code works
5119 on the parent view so the resulting code may access the same object
5120 using both the parent and the derived alias sets, which thus have to
5121 conflict. As the same issue arises with component references, the
5122 parent alias set also has to conflict with composite types enclosing
5123 derived components. For instance, if we have:
5130 we want T to conflict with both D and R, in addition to R being a
5131 superset of D by record/component construction.
5133 One way to achieve this is to perform an alias set copy from the
5134 parent to the derived type. This is not quite appropriate, though,
5135 as we don't want separate derived types to conflict with each other:
5137 type I1 is new Integer;
5138 type I2 is new Integer;
5140 We want I1 and I2 to both conflict with Integer but we do not want
5141 I1 to conflict with I2, and an alias set copy on derivation would
5144 The option chosen is to make the alias set of the derived type a
5145 superset of that of its parent type. It trivially fulfills the
5146 simple requirement for the Integer derivation example above, and
5147 the component case as well by superset transitivity:
5150 R ----------> D ----------> T
5152 However, for composite types, conversions between derived types are
5153 translated into VIEW_CONVERT_EXPRs so a sequence like:
5155 type Comp1 is new Comp;
5156 type Comp2 is new Comp;
5157 procedure Proc (C : Comp1);
5165 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
5167 and gimplified into:
5174 i.e. generates code involving type punning. Therefore, Comp1 needs
5175 to conflict with Comp2 and an alias set copy is required.
5177 The language rules ensure the parent type is already frozen here. */
5178 if (Is_Derived_Type (gnat_entity) && !type_annotate_only)
5180 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
5181 relate_alias_sets (gnu_type, gnu_parent_type,
5182 Is_Composite_Type (gnat_entity)
5183 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
5186 /* Back-annotate the Alignment of the type if not already in the
5187 tree. Likewise for sizes. */
5188 if (Unknown_Alignment (gnat_entity))
5190 unsigned int double_align, align;
5191 bool is_capped_double, align_clause;
5193 /* If the default alignment of "double" or larger scalar types is
5194 specifically capped and this is not an array with an alignment
5195 clause on the component type, return the cap. */
5196 if ((double_align = double_float_alignment) > 0)
5198 = is_double_float_or_array (gnat_entity, &align_clause);
5199 else if ((double_align = double_scalar_alignment) > 0)
5201 = is_double_scalar_or_array (gnat_entity, &align_clause);
5203 is_capped_double = align_clause = false;
5205 if (is_capped_double && !align_clause)
5206 align = double_align;
5208 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
5210 Set_Alignment (gnat_entity, UI_From_Int (align));
5213 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
5215 tree gnu_size = TYPE_SIZE (gnu_type);
5217 /* If the size is self-referential, annotate the maximum value. */
5218 if (CONTAINS_PLACEHOLDER_P (gnu_size))
5219 gnu_size = max_size (gnu_size, true);
5221 /* If we are just annotating types and the type is tagged, the tag
5222 and the parent components are not generated by the front-end so
5223 sizes must be adjusted if there is no representation clause. */
5224 if (type_annotate_only
5225 && Is_Tagged_Type (gnat_entity)
5226 && !VOID_TYPE_P (gnu_type)
5227 && (!TYPE_FIELDS (gnu_type)
5228 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
5230 tree pointer_size = bitsize_int (POINTER_SIZE), offset;
5233 if (Is_Derived_Type (gnat_entity))
5235 Entity_Id gnat_parent = Etype (Base_Type (gnat_entity));
5236 offset = UI_To_gnu (Esize (gnat_parent), bitsizetype);
5237 Set_Alignment (gnat_entity, Alignment (gnat_parent));
5240 offset = pointer_size;
5242 if (TYPE_FIELDS (gnu_type))
5244 = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type)));
5246 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
5247 gnu_size = round_up (gnu_size, POINTER_SIZE);
5248 uint_size = annotate_value (gnu_size);
5249 Set_Esize (gnat_entity, uint_size);
5250 Set_RM_Size (gnat_entity, uint_size);
5253 Set_Esize (gnat_entity, annotate_value (gnu_size));
5256 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
5257 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
5260 /* If we really have a ..._DECL node, set a couple of flags on it. But we
5261 cannot do so if we are reusing the ..._DECL node made for an equivalent
5262 type or an alias or a renamed object as the predicates don't apply to it
5263 but to GNAT_ENTITY. */
5264 if (DECL_P (gnu_decl)
5265 && !(is_type && gnat_equiv_type != gnat_entity)
5266 && !Present (Alias (gnat_entity))
5267 && !(Present (Renamed_Object (gnat_entity)) && saved))
5269 if (!Comes_From_Source (gnat_entity))
5270 DECL_ARTIFICIAL (gnu_decl) = 1;
5273 DECL_IGNORED_P (gnu_decl) = 1;
5276 /* If we haven't already, associate the ..._DECL node that we just made with
5277 the input GNAT entity node. */
5279 save_gnu_tree (gnat_entity, gnu_decl, false);
5281 /* If this is an enumeration or floating-point type, we were not able to set
5282 the bounds since they refer to the type. These are always static. */
5283 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
5284 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
5286 tree gnu_scalar_type = gnu_type;
5287 tree gnu_low_bound, gnu_high_bound;
5289 /* If this is a padded type, we need to use the underlying type. */
5290 if (TYPE_IS_PADDING_P (gnu_scalar_type))
5291 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
5293 /* If this is a floating point type and we haven't set a floating
5294 point type yet, use this in the evaluation of the bounds. */
5295 if (!longest_float_type_node && kind == E_Floating_Point_Type)
5296 longest_float_type_node = gnu_scalar_type;
5298 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
5299 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
5301 if (kind == E_Enumeration_Type)
5303 /* Enumeration types have specific RM bounds. */
5304 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
5305 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
5309 /* Floating-point types don't have specific RM bounds. */
5310 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
5311 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
5315 /* If we deferred processing of incomplete types, re-enable it. If there
5316 were no other disables and we have deferred types to process, do so. */
5318 && --defer_incomplete_level == 0
5319 && defer_incomplete_list)
5321 struct incomplete *p, *next;
5323 /* We are back to level 0 for the deferring of incomplete types.
5324 But processing these incomplete types below may itself require
5325 deferring, so preserve what we have and restart from scratch. */
5326 p = defer_incomplete_list;
5327 defer_incomplete_list = NULL;
5334 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5335 gnat_to_gnu_type (p->full_type));
5340 /* If we are not defining this type, see if it's on one of the lists of
5341 incomplete types. If so, handle the list entry now. */
5342 if (is_type && !definition)
5344 struct incomplete *p;
5346 for (p = defer_incomplete_list; p; p = p->next)
5347 if (p->old_type && p->full_type == gnat_entity)
5349 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5350 TREE_TYPE (gnu_decl));
5351 p->old_type = NULL_TREE;
5354 for (p = defer_limited_with; p; p = p->next)
5355 if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
5357 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5358 TREE_TYPE (gnu_decl));
5359 p->old_type = NULL_TREE;
5366 /* If this is a packed array type whose original array type is itself
5367 an Itype without freeze node, make sure the latter is processed. */
5368 if (Is_Packed_Array_Impl_Type (gnat_entity)
5369 && Is_Itype (Original_Array_Type (gnat_entity))
5370 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5371 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5372 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
5377 /* Similar, but if the returned value is a COMPONENT_REF, return the
5381 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5383 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5385 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5386 gnu_field = TREE_OPERAND (gnu_field, 1);
5391 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5392 the GCC type corresponding to that entity. */
5395 gnat_to_gnu_type (Entity_Id gnat_entity)
5399 /* The back end never attempts to annotate generic types. */
5400 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5401 return void_type_node;
5403 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5404 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5406 return TREE_TYPE (gnu_decl);
5409 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5410 the unpadded version of the GCC type corresponding to that entity. */
5413 get_unpadded_type (Entity_Id gnat_entity)
5415 tree type = gnat_to_gnu_type (gnat_entity);
5417 if (TYPE_IS_PADDING_P (type))
5418 type = TREE_TYPE (TYPE_FIELDS (type));
5423 /* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
5424 type has been changed to that of the parameterless procedure, except if an
5425 alias is already present, in which case it is returned instead. */
5428 get_minimal_subprog_decl (Entity_Id gnat_entity)
5430 tree gnu_entity_name, gnu_ext_name;
5431 struct attrib *attr_list = NULL;
5433 /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
5434 of the handling applied here. */
5436 while (Present (Alias (gnat_entity)))
5438 gnat_entity = Alias (gnat_entity);
5439 if (present_gnu_tree (gnat_entity))
5440 return get_gnu_tree (gnat_entity);
5443 gnu_entity_name = get_entity_name (gnat_entity);
5444 gnu_ext_name = create_concat_name (gnat_entity, NULL);
5446 if (Has_Stdcall_Convention (gnat_entity))
5447 prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
5448 get_identifier ("stdcall"), NULL_TREE,
5450 else if (Has_Thiscall_Convention (gnat_entity))
5451 prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
5452 get_identifier ("thiscall"), NULL_TREE,
5455 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
5456 gnu_ext_name = NULL_TREE;
5459 create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
5460 is_disabled, true, true, true, attr_list, gnat_entity);
5463 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
5464 a C++ imported method or equivalent.
5466 We use the predicate on 32-bit x86/Windows to find out whether we need to
5467 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
5468 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
5471 is_cplusplus_method (Entity_Id gnat_entity)
5473 if (Convention (gnat_entity) != Convention_CPP)
5476 /* This is the main case: C++ method imported as a primitive operation. */
5477 if (Is_Dispatching_Operation (gnat_entity))
5480 /* A thunk needs to be handled like its associated primitive operation. */
5481 if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
5484 /* C++ classes with no virtual functions can be imported as limited
5485 record types, but we need to return true for the constructors. */
5486 if (Is_Constructor (gnat_entity))
5489 /* This is set on the E_Subprogram_Type built for a dispatching call. */
5490 if (Is_Dispatch_Table_Entity (gnat_entity))
5496 /* Finalize the processing of From_Limited_With incomplete types. */
5499 finalize_from_limited_with (void)
5501 struct incomplete *p, *next;
5503 p = defer_limited_with;
5504 defer_limited_with = NULL;
5511 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5512 gnat_to_gnu_type (p->full_type));
5517 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
5518 kind of type (such E_Task_Type) that has a different type which Gigi
5519 uses for its representation. If the type does not have a special type
5520 for its representation, return GNAT_ENTITY. If a type is supposed to
5521 exist, but does not, abort unless annotating types, in which case
5522 return Empty. If GNAT_ENTITY is Empty, return Empty. */
5525 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5527 Entity_Id gnat_equiv = gnat_entity;
5529 if (No (gnat_entity))
5532 switch (Ekind (gnat_entity))
5534 case E_Class_Wide_Subtype:
5535 if (Present (Equivalent_Type (gnat_entity)))
5536 gnat_equiv = Equivalent_Type (gnat_entity);
5539 case E_Access_Protected_Subprogram_Type:
5540 case E_Anonymous_Access_Protected_Subprogram_Type:
5541 gnat_equiv = Equivalent_Type (gnat_entity);
5544 case E_Class_Wide_Type:
5545 gnat_equiv = Root_Type (gnat_entity);
5549 case E_Task_Subtype:
5550 case E_Protected_Type:
5551 case E_Protected_Subtype:
5552 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5559 gcc_assert (Present (gnat_equiv) || type_annotate_only);
5564 /* Return a GCC tree for a type corresponding to the component type of the
5565 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5566 is for an array being defined. DEBUG_INFO_P is true if we need to write
5567 debug information for other types that we may create in the process. */
5570 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5573 const Entity_Id gnat_type = Component_Type (gnat_array);
5574 tree gnu_type = gnat_to_gnu_type (gnat_type);
5577 /* Try to get a smaller form of the component if needed. */
5578 if ((Is_Packed (gnat_array)
5579 || Has_Component_Size_Clause (gnat_array))
5580 && !Is_Bit_Packed_Array (gnat_array)
5581 && !Has_Aliased_Components (gnat_array)
5582 && !Strict_Alignment (gnat_type)
5583 && RECORD_OR_UNION_TYPE_P (gnu_type)
5584 && !TYPE_FAT_POINTER_P (gnu_type)
5585 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
5586 gnu_type = make_packable_type (gnu_type, false);
5588 if (Has_Atomic_Components (gnat_array))
5589 check_ok_for_atomic (gnu_type, gnat_array, true);
5591 /* Get and validate any specified Component_Size. */
5593 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5594 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5595 true, Has_Component_Size_Clause (gnat_array));
5597 /* If the array has aliased components and the component size can be zero,
5598 force at least unit size to ensure that the components have distinct
5601 && Has_Aliased_Components (gnat_array)
5602 && (integer_zerop (TYPE_SIZE (gnu_type))
5603 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5604 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5606 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5608 /* If the component type is a RECORD_TYPE that has a self-referential size,
5609 then use the maximum size for the component size. */
5611 && TREE_CODE (gnu_type) == RECORD_TYPE
5612 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5613 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5615 /* Honor the component size. This is not needed for bit-packed arrays. */
5616 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5618 tree orig_type = gnu_type;
5619 unsigned int max_align;
5621 /* If an alignment is specified, use it as a cap on the component type
5622 so that it can be honored for the whole type. But ignore it for the
5623 original type of packed array types. */
5624 if (No (Packed_Array_Impl_Type (gnat_array))
5625 && Known_Alignment (gnat_array))
5626 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5630 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5631 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5632 gnu_type = orig_type;
5634 orig_type = gnu_type;
5636 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5637 true, false, definition, true);
5639 /* If a padding record was made, declare it now since it will never be
5640 declared otherwise. This is necessary to ensure that its subtrees
5641 are properly marked. */
5642 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5643 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5647 if (Has_Volatile_Components (gnat_array))
5648 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
5653 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5654 using MECH as its passing mechanism, to be placed in the parameter
5655 list built for GNAT_SUBPROG. Assume a foreign convention for the
5656 latter if FOREIGN is true. Also set CICO to true if the parameter
5657 must use the copy-in copy-out implementation mechanism.
5659 The returned tree is a PARM_DECL, except for those cases where no
5660 parameter needs to be actually passed to the subprogram; the type
5661 of this "shadow" parameter is then returned instead. */
5664 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5665 Entity_Id gnat_subprog, bool foreign, bool *cico)
5667 tree gnu_param_name = get_entity_name (gnat_param);
5668 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5669 tree gnu_param_type_alt = NULL_TREE;
5670 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5671 /* The parameter can be indirectly modified if its address is taken. */
5672 bool ro_param = in_param && !Address_Taken (gnat_param);
5673 bool by_return = false, by_component_ptr = false;
5674 bool by_ref = false;
5677 /* Copy-return is used only for the first parameter of a valued procedure.
5678 It's a copy mechanism for which a parameter is never allocated. */
5679 if (mech == By_Copy_Return)
5681 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5686 /* If this is either a foreign function or if the underlying type won't
5687 be passed by reference, strip off possible padding type. */
5688 if (TYPE_IS_PADDING_P (gnu_param_type))
5690 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5692 if (mech == By_Reference
5694 || (!must_pass_by_ref (unpadded_type)
5695 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5696 gnu_param_type = unpadded_type;
5699 /* If this is a read-only parameter, make a variant of the type that is
5700 read-only. ??? However, if this is an unconstrained array, that type
5701 can be very complex, so skip it for now. Likewise for any other
5702 self-referential type. */
5704 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5705 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5706 gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5708 /* For foreign conventions, pass arrays as pointers to the element type.
5709 First check for unconstrained array and get the underlying array. */
5710 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5712 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5714 /* For GCC builtins, pass Address integer types as (void *) */
5715 if (Convention (gnat_subprog) == Convention_Intrinsic
5716 && Present (Interface_Name (gnat_subprog))
5717 && Is_Descendent_Of_Address (Etype (gnat_param)))
5718 gnu_param_type = ptr_void_type_node;
5720 /* VMS descriptors are themselves passed by reference. */
5721 if (mech == By_Short_Descriptor ||
5722 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !flag_vms_malloc64))
5724 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5725 Mechanism (gnat_param),
5727 else if (mech == By_Descriptor)
5729 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5730 chosen in fill_vms_descriptor. */
5732 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5733 Mechanism (gnat_param),
5736 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5737 Mechanism (gnat_param),
5741 /* Arrays are passed as pointers to element type for foreign conventions. */
5744 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5746 /* Strip off any multi-dimensional entries, then strip
5747 off the last array to get the component type. */
5748 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5749 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5750 gnu_param_type = TREE_TYPE (gnu_param_type);
5752 by_component_ptr = true;
5753 gnu_param_type = TREE_TYPE (gnu_param_type);
5757 = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5759 gnu_param_type = build_pointer_type (gnu_param_type);
5762 /* Fat pointers are passed as thin pointers for foreign conventions. */
5763 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5765 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5767 /* If we must pass or were requested to pass by reference, do so.
5768 If we were requested to pass by copy, do so.
5769 Otherwise, for foreign conventions, pass In Out or Out parameters
5770 or aggregates by reference. For COBOL and Fortran, pass all
5771 integer and FP types that way too. For Convention Ada, use
5772 the standard Ada default. */
5773 else if (must_pass_by_ref (gnu_param_type)
5774 || mech == By_Reference
5777 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5779 && (Convention (gnat_subprog) == Convention_Fortran
5780 || Convention (gnat_subprog) == Convention_COBOL)
5781 && (INTEGRAL_TYPE_P (gnu_param_type)
5782 || FLOAT_TYPE_P (gnu_param_type)))
5784 && default_pass_by_ref (gnu_param_type)))))
5786 /* We take advantage of 6.2(12) by considering that references built for
5787 parameters whose type isn't by-ref and for which the mechanism hasn't
5788 been forced to by-ref are restrict-qualified in the C sense. */
5790 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5791 gnu_param_type = build_reference_type (gnu_param_type);
5794 = change_qualified_type (gnu_param_type, TYPE_QUAL_RESTRICT);
5798 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5802 if (mech == By_Copy && (by_ref || by_component_ptr))
5803 post_error ("?cannot pass & by copy", gnat_param);
5805 /* If this is an Out parameter that isn't passed by reference and isn't
5806 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5807 it will be a VAR_DECL created when we process the procedure, so just
5808 return its type. For the special parameter of a valued procedure,
5811 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5812 Out parameters with discriminants or implicit initial values to be
5813 handled like In Out parameters. These type are normally built as
5814 aggregates, hence passed by reference, except for some packed arrays
5815 which end up encoded in special integer types. Note that scalars can
5816 be given implicit initial values using the Default_Value aspect.
5818 The exception we need to make is then for packed arrays of records
5819 with discriminants or implicit initial values. We have no light/easy
5820 way to check for the latter case, so we merely check for packed arrays
5821 of records. This may lead to useless copy-in operations, but in very
5822 rare cases only, as these would be exceptions in a set of already
5823 exceptional situations. */
5824 if (Ekind (gnat_param) == E_Out_Parameter
5827 || (mech != By_Descriptor
5828 && mech != By_Short_Descriptor
5829 && !POINTER_TYPE_P (gnu_param_type)
5830 && !AGGREGATE_TYPE_P (gnu_param_type)
5831 && !Has_Default_Aspect (Etype (gnat_param))))
5832 && !(Is_Array_Type (Etype (gnat_param))
5833 && Is_Packed (Etype (gnat_param))
5834 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5835 return gnu_param_type;
5837 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5838 ro_param || by_ref || by_component_ptr);
5839 DECL_BY_REF_P (gnu_param) = by_ref;
5840 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5841 DECL_BY_DESCRIPTOR_P (gnu_param)
5842 = (mech == By_Descriptor || mech == By_Short_Descriptor);
5843 DECL_POINTS_TO_READONLY_P (gnu_param)
5844 = (ro_param && (by_ref || by_component_ptr));
5845 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5847 /* Save the alternate descriptor type, if any. */
5848 if (gnu_param_type_alt)
5849 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5851 /* If no Mechanism was specified, indicate what we're using, then
5852 back-annotate it. */
5853 if (mech == Default)
5854 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5856 Set_Mechanism (gnat_param, mech);
5860 /* Like build_qualified_type, but TYPE_QUALS is added to the existing
5861 qualifiers on TYPE. */
5864 change_qualified_type (tree type, int type_quals)
5866 return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
5869 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5872 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5874 while (Present (Corresponding_Discriminant (discr1)))
5875 discr1 = Corresponding_Discriminant (discr1);
5877 while (Present (Corresponding_Discriminant (discr2)))
5878 discr2 = Corresponding_Discriminant (discr2);
5881 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5884 /* Return true if the array type GNU_TYPE, which represents a dimension of
5885 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5888 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5890 /* If the array type is not the innermost dimension of the GNAT type,
5891 then it has a non-aliased component. */
5892 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5893 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5896 /* If the array type has an aliased component in the front-end sense,
5897 then it also has an aliased component in the back-end sense. */
5898 if (Has_Aliased_Components (gnat_type))
5901 /* If this is a derived type, then it has a non-aliased component if
5902 and only if its parent type also has one. */
5903 if (Is_Derived_Type (gnat_type))
5905 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5907 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5909 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5910 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5911 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5912 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5915 /* Otherwise, rely exclusively on properties of the element type. */
5916 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5919 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5922 compile_time_known_address_p (Node_Id gnat_address)
5924 /* Catch System'To_Address. */
5925 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5926 gnat_address = Expression (gnat_address);
5928 return Compile_Time_Known_Value (gnat_address);
5931 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
5932 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
5935 cannot_be_superflat_p (Node_Id gnat_range)
5937 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5938 Node_Id scalar_range;
5939 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
5941 /* If the low bound is not constant, try to find an upper bound. */
5942 while (Nkind (gnat_lb) != N_Integer_Literal
5943 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5944 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5945 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5946 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5947 || Nkind (scalar_range) == N_Range))
5948 gnat_lb = High_Bound (scalar_range);
5950 /* If the high bound is not constant, try to find a lower bound. */
5951 while (Nkind (gnat_hb) != N_Integer_Literal
5952 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5953 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5954 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5955 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5956 || Nkind (scalar_range) == N_Range))
5957 gnat_hb = Low_Bound (scalar_range);
5959 /* If we have failed to find constant bounds, punt. */
5960 if (Nkind (gnat_lb) != N_Integer_Literal
5961 || Nkind (gnat_hb) != N_Integer_Literal)
5964 /* We need at least a signed 64-bit type to catch most cases. */
5965 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
5966 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
5967 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
5970 /* If the low bound is the smallest integer, nothing can be smaller. */
5971 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
5972 if (TREE_OVERFLOW (gnu_lb_minus_one))
5975 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
5978 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
5981 constructor_address_p (tree gnu_expr)
5983 while (TREE_CODE (gnu_expr) == NOP_EXPR
5984 || TREE_CODE (gnu_expr) == CONVERT_EXPR
5985 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
5986 gnu_expr = TREE_OPERAND (gnu_expr, 0);
5988 return (TREE_CODE (gnu_expr) == ADDR_EXPR
5989 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
5992 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5993 be elaborated at the point of its definition, but do nothing else. */
5996 elaborate_entity (Entity_Id gnat_entity)
5998 switch (Ekind (gnat_entity))
6000 case E_Signed_Integer_Subtype:
6001 case E_Modular_Integer_Subtype:
6002 case E_Enumeration_Subtype:
6003 case E_Ordinary_Fixed_Point_Subtype:
6004 case E_Decimal_Fixed_Point_Subtype:
6005 case E_Floating_Point_Subtype:
6007 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
6008 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
6010 /* ??? Tests to avoid Constraint_Error in static expressions
6011 are needed until after the front stops generating bogus
6012 conversions on bounds of real types. */
6013 if (!Raises_Constraint_Error (gnat_lb))
6014 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
6015 true, false, Needs_Debug_Info (gnat_entity));
6016 if (!Raises_Constraint_Error (gnat_hb))
6017 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
6018 true, false, Needs_Debug_Info (gnat_entity));
6022 case E_Record_Subtype:
6023 case E_Private_Subtype:
6024 case E_Limited_Private_Subtype:
6025 case E_Record_Subtype_With_Private:
6026 if (Has_Discriminants (gnat_entity) && Is_Constrained (gnat_entity))
6028 Node_Id gnat_discriminant_expr;
6029 Entity_Id gnat_field;
6032 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
6033 gnat_discriminant_expr
6034 = First_Elmt (Discriminant_Constraint (gnat_entity));
6035 Present (gnat_field);
6036 gnat_field = Next_Discriminant (gnat_field),
6037 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
6038 /* Ignore access discriminants. */
6039 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
6040 elaborate_expression (Node (gnat_discriminant_expr),
6041 gnat_entity, get_entity_name (gnat_field),
6042 true, false, false);
6049 /* Return true if the size in units represented by GNU_SIZE can be handled by
6050 an allocation. If STATIC_P is true, consider only what can be done with a
6051 static allocation. */
6054 allocatable_size_p (tree gnu_size, bool static_p)
6056 /* We can allocate a fixed size if it is a valid for the middle-end. */
6057 if (TREE_CODE (gnu_size) == INTEGER_CST)
6058 return valid_constant_size_p (gnu_size);
6060 /* We can allocate a variable size if this isn't a static allocation. */
6065 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6066 NAME, ARGS and ERROR_POINT. */
6069 prepend_one_attribute (struct attrib **attr_list,
6070 enum attr_type attr_type,
6073 Node_Id attr_error_point)
6075 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
6077 attr->type = attr_type;
6078 attr->name = attr_name;
6079 attr->args = attr_args;
6080 attr->error_point = attr_error_point;
6082 attr->next = *attr_list;
6086 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
6089 prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma)
6091 const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma);
6092 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
6093 enum attr_type etype;
6095 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
6096 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
6098 case Pragma_Machine_Attribute:
6099 etype = ATTR_MACHINE_ATTRIBUTE;
6102 case Pragma_Linker_Alias:
6103 etype = ATTR_LINK_ALIAS;
6106 case Pragma_Linker_Section:
6107 etype = ATTR_LINK_SECTION;
6110 case Pragma_Linker_Constructor:
6111 etype = ATTR_LINK_CONSTRUCTOR;
6114 case Pragma_Linker_Destructor:
6115 etype = ATTR_LINK_DESTRUCTOR;
6118 case Pragma_Weak_External:
6119 etype = ATTR_WEAK_EXTERNAL;
6122 case Pragma_Thread_Local_Storage:
6123 etype = ATTR_THREAD_LOCAL_STORAGE;
6130 /* See what arguments we have and turn them into GCC trees for attribute
6131 handlers. These expect identifier for strings. We handle at most two
6132 arguments and static expressions only. */
6133 if (Present (gnat_arg) && Present (First (gnat_arg)))
6135 Node_Id gnat_arg0 = Next (First (gnat_arg));
6136 Node_Id gnat_arg1 = Empty;
6138 if (Present (gnat_arg0)
6139 && Is_OK_Static_Expression (Expression (gnat_arg0)))
6141 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
6143 if (TREE_CODE (gnu_arg0) == STRING_CST)
6145 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6146 if (IDENTIFIER_LENGTH (gnu_arg0) == 0)
6150 gnat_arg1 = Next (gnat_arg0);
6153 if (Present (gnat_arg1)
6154 && Is_OK_Static_Expression (Expression (gnat_arg1)))
6156 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6158 if (TREE_CODE (gnu_arg1) == STRING_CST)
6159 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6163 /* Prepend to the list. Make a list of the argument we might have, as GCC
6165 prepend_one_attribute (attr_list, etype, gnu_arg0,
6167 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6168 Present (Next (First (gnat_arg)))
6169 ? Expression (Next (First (gnat_arg))) : gnat_pragma);
6172 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6175 prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
6179 /* Attributes are stored as Representation Item pragmas. */
6180 for (gnat_temp = First_Rep_Item (gnat_entity);
6181 Present (gnat_temp);
6182 gnat_temp = Next_Rep_Item (gnat_temp))
6183 if (Nkind (gnat_temp) == N_Pragma)
6184 prepend_one_attribute_pragma (attr_list, gnat_temp);
6187 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6188 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6189 return the GCC tree to use for that expression. GNU_NAME is the suffix
6190 to use if a variable needs to be created and DEFINITION is true if this
6191 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6192 otherwise, we are just elaborating the expression for side-effects. If
6193 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6194 isn't needed for code generation. */
6197 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
6198 bool definition, bool need_value, bool need_debug)
6202 /* If we already elaborated this expression (e.g. it was involved
6203 in the definition of a private type), use the old value. */
6204 if (present_gnu_tree (gnat_expr))
6205 return get_gnu_tree (gnat_expr);
6207 /* If we don't need a value and this is static or a discriminant,
6208 we don't need to do anything. */
6210 && (Is_OK_Static_Expression (gnat_expr)
6211 || (Nkind (gnat_expr) == N_Identifier
6212 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6215 /* If it's a static expression, we don't need a variable for debugging. */
6216 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6219 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6220 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
6221 gnu_name, definition, need_debug);
6223 /* Save the expression in case we try to elaborate this entity again. Since
6224 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6225 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6226 save_gnu_tree (gnat_expr, gnu_expr, true);
6228 return need_value ? gnu_expr : error_mark_node;
6231 /* Similar, but take a GNU expression and always return a result. */
6234 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6235 bool definition, bool need_debug)
6237 const bool expr_public_p = Is_Public (gnat_entity);
6238 const bool expr_global_p = expr_public_p || global_bindings_p ();
6239 bool expr_variable_p, use_variable;
6241 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
6242 reference will have been replaced with a COMPONENT_REF when the type
6243 is being elaborated. However, there are some cases involving child
6244 types where we will. So convert it to a COMPONENT_REF. We hope it
6245 will be at the highest level of the expression in these cases. */
6246 if (TREE_CODE (gnu_expr) == FIELD_DECL)
6247 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
6248 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
6249 gnu_expr, NULL_TREE);
6251 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6252 that an expression cannot contain both a discriminant and a variable. */
6253 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6256 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6257 a variable that is initialized to contain the expression when the package
6258 containing the definition is elaborated. If this entity is defined at top
6259 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6260 if this is necessary. */
6261 if (CONSTANT_CLASS_P (gnu_expr))
6262 expr_variable_p = false;
6265 /* Skip any conversions and simple constant arithmetics to see if the
6266 expression is based on a read-only variable.
6267 ??? This really should remain read-only, but we have to think about
6268 the typing of the tree here. */
6269 tree inner = remove_conversions (gnu_expr, true);
6271 inner = skip_simple_constant_arithmetic (inner);
6273 if (handled_component_p (inner))
6275 HOST_WIDE_INT bitsize, bitpos;
6277 enum machine_mode mode;
6278 int unsignedp, volatilep;
6280 inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
6281 &mode, &unsignedp, &volatilep, false);
6282 /* If the offset is variable, err on the side of caution. */
6289 && TREE_CODE (inner) == VAR_DECL
6290 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6293 /* We only need to use the variable if we are in a global context since GCC
6294 can do the right thing in the local case. However, when not optimizing,
6295 use it for bounds of loop iteration scheme to avoid code duplication. */
6296 use_variable = expr_variable_p
6300 && Is_Itype (gnat_entity)
6301 && Nkind (Associated_Node_For_Itype (gnat_entity))
6302 == N_Loop_Parameter_Specification));
6304 /* Now create it, possibly only for debugging purposes. */
6305 if (use_variable || need_debug)
6309 (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)),
6310 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p,
6311 !definition, expr_global_p, !need_debug, NULL, gnat_entity);
6317 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6320 /* Similar, but take an alignment factor and make it explicit in the tree. */
6323 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
6324 bool definition, bool need_debug, unsigned int align)
6326 tree unit_align = size_int (align / BITS_PER_UNIT);
6328 size_binop (MULT_EXPR,
6329 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6332 gnat_entity, gnu_name, definition,
6337 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6338 the value passed against the list of choices. */
6341 choices_to_gnu (tree operand, Node_Id choices)
6345 tree result = boolean_false_node;
6346 tree this_test, low = 0, high = 0, single = 0;
6348 for (choice = First (choices); Present (choice); choice = Next (choice))
6350 switch (Nkind (choice))
6353 low = gnat_to_gnu (Low_Bound (choice));
6354 high = gnat_to_gnu (High_Bound (choice));
6357 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6358 build_binary_op (GE_EXPR, boolean_type_node,
6360 build_binary_op (LE_EXPR, boolean_type_node,
6365 case N_Subtype_Indication:
6366 gnat_temp = Range_Expression (Constraint (choice));
6367 low = gnat_to_gnu (Low_Bound (gnat_temp));
6368 high = gnat_to_gnu (High_Bound (gnat_temp));
6371 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6372 build_binary_op (GE_EXPR, boolean_type_node,
6374 build_binary_op (LE_EXPR, boolean_type_node,
6379 case N_Expanded_Name:
6380 /* This represents either a subtype range, an enumeration
6381 literal, or a constant Ekind says which. If an enumeration
6382 literal or constant, fall through to the next case. */
6383 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6384 && Ekind (Entity (choice)) != E_Constant)
6386 tree type = gnat_to_gnu_type (Entity (choice));
6388 low = TYPE_MIN_VALUE (type);
6389 high = TYPE_MAX_VALUE (type);
6392 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6393 build_binary_op (GE_EXPR, boolean_type_node,
6395 build_binary_op (LE_EXPR, boolean_type_node,
6400 /* ... fall through ... */
6402 case N_Character_Literal:
6403 case N_Integer_Literal:
6404 single = gnat_to_gnu (choice);
6405 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6409 case N_Others_Choice:
6410 this_test = boolean_true_node;
6417 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6424 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6425 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6428 adjust_packed (tree field_type, tree record_type, int packed)
6430 /* If the field contains an item of variable size, we cannot pack it
6431 because we cannot create temporaries of non-fixed size in case
6432 we need to take the address of the field. See addressable_p and
6433 the notes on the addressability issues for further details. */
6434 if (type_has_variable_size (field_type))
6437 /* If the alignment of the record is specified and the field type
6438 is over-aligned, request Storage_Unit alignment for the field. */
6441 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6450 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6451 placed in GNU_RECORD_TYPE.
6453 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6454 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6455 record has a specified alignment.
6457 DEFINITION is true if this field is for a record being defined.
6459 DEBUG_INFO_P is true if we need to write debug information for types
6460 that we may create in the process. */
6463 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6464 bool definition, bool debug_info_p)
6466 const Entity_Id gnat_field_type = Etype (gnat_field);
6467 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6468 tree gnu_field_id = get_entity_name (gnat_field);
6469 tree gnu_field, gnu_size, gnu_pos;
6471 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6472 bool needs_strict_alignment
6474 || Is_Aliased (gnat_field)
6475 || Strict_Alignment (gnat_field_type));
6477 /* If this field requires strict alignment, we cannot pack it because
6478 it would very likely be under-aligned in the record. */
6479 if (needs_strict_alignment)
6482 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6484 /* If a size is specified, use it. Otherwise, if the record type is packed,
6485 use the official RM size. See "Handling of Type'Size Values" in Einfo
6486 for further details. */
6487 if (Known_Esize (gnat_field))
6488 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6489 gnat_field, FIELD_DECL, false, true);
6490 else if (packed == 1)
6491 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6492 gnat_field, FIELD_DECL, false, true);
6494 gnu_size = NULL_TREE;
6496 /* If we have a specified size that is smaller than that of the field's type,
6497 or a position is specified, and the field's type is a record that doesn't
6498 require strict alignment, see if we can get either an integral mode form
6499 of the type or a smaller form. If we can, show a size was specified for
6500 the field if there wasn't one already, so we know to make this a bitfield
6501 and avoid making things wider.
6503 Changing to an integral mode form is useful when the record is packed as
6504 we can then place the field at a non-byte-aligned position and so achieve
6505 tighter packing. This is in addition required if the field shares a byte
6506 with another field and the front-end lets the back-end handle the access
6507 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6509 Changing to a smaller form is required if the specified size is smaller
6510 than that of the field's type and the type contains sub-fields that are
6511 padded, in order to avoid generating accesses to these sub-fields that
6512 are wider than the field.
6514 We avoid the transformation if it is not required or potentially useful,
6515 as it might entail an increase of the field's alignment and have ripple
6516 effects on the outer record type. A typical case is a field known to be
6517 byte-aligned and not to share a byte with another field. */
6518 if (!needs_strict_alignment
6519 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
6520 && !TYPE_FAT_POINTER_P (gnu_field_type)
6521 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
6524 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6525 || (Present (Component_Clause (gnat_field))
6526 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6527 % BITS_PER_UNIT == 0
6528 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6530 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6531 if (gnu_packable_type != gnu_field_type)
6533 gnu_field_type = gnu_packable_type;
6535 gnu_size = rm_size (gnu_field_type);
6539 if (Is_Atomic (gnat_field))
6540 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6542 if (Present (Component_Clause (gnat_field)))
6544 Entity_Id gnat_parent
6545 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6547 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6548 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6549 gnat_field, FIELD_DECL, false, true);
6551 /* Ensure the position does not overlap with the parent subtype, if there
6552 is one. This test is omitted if the parent of the tagged type has a
6553 full rep clause since, in this case, component clauses are allowed to
6554 overlay the space allocated for the parent type and the front-end has
6555 checked that there are no overlapping components. */
6556 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6558 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6560 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6561 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6564 ("offset of& must be beyond parent{, minimum allowed is ^}",
6565 First_Bit (Component_Clause (gnat_field)), gnat_field,
6566 TYPE_SIZE_UNIT (gnu_parent));
6570 /* If this field needs strict alignment, check that the record is
6571 sufficiently aligned and that position and size are consistent with
6572 the alignment. But don't do it if we are just annotating types and
6573 the field's type is tagged, since tagged types aren't fully laid out
6574 in this mode. Also, note that atomic implies volatile so the inner
6575 test sequences ordering is significant here. */
6576 if (needs_strict_alignment
6577 && !(type_annotate_only && Is_Tagged_Type (gnat_field_type)))
6579 TYPE_ALIGN (gnu_record_type)
6580 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6583 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6585 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
6587 ("atomic field& must be natural size of type{ (^)}",
6588 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6589 TYPE_SIZE (gnu_field_type));
6591 else if (is_volatile)
6593 ("volatile field& must be natural size of type{ (^)}",
6594 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6595 TYPE_SIZE (gnu_field_type));
6597 else if (Is_Aliased (gnat_field))
6599 ("size of aliased field& must be ^ bits",
6600 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6601 TYPE_SIZE (gnu_field_type));
6603 else if (Strict_Alignment (gnat_field_type))
6605 ("size of & with aliased or tagged components not ^ bits",
6606 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6607 TYPE_SIZE (gnu_field_type));
6612 gnu_size = NULL_TREE;
6615 if (!integer_zerop (size_binop
6616 (TRUNC_MOD_EXPR, gnu_pos,
6617 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6619 if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
6621 ("position of atomic field& must be multiple of ^ bits",
6622 First_Bit (Component_Clause (gnat_field)), gnat_field,
6623 TYPE_ALIGN (gnu_field_type));
6625 else if (is_volatile)
6627 ("position of volatile field& must be multiple of ^ bits",
6628 First_Bit (Component_Clause (gnat_field)), gnat_field,
6629 TYPE_ALIGN (gnu_field_type));
6631 else if (Is_Aliased (gnat_field))
6633 ("position of aliased field& must be multiple of ^ bits",
6634 First_Bit (Component_Clause (gnat_field)), gnat_field,
6635 TYPE_ALIGN (gnu_field_type));
6637 else if (Strict_Alignment (gnat_field_type))
6639 ("position of & is not compatible with alignment required "
6640 "by its components",
6641 First_Bit (Component_Clause (gnat_field)), gnat_field);
6646 gnu_pos = NULL_TREE;
6651 /* If the record has rep clauses and this is the tag field, make a rep
6652 clause for it as well. */
6653 else if (Has_Specified_Layout (Scope (gnat_field))
6654 && Chars (gnat_field) == Name_uTag)
6656 gnu_pos = bitsize_zero_node;
6657 gnu_size = TYPE_SIZE (gnu_field_type);
6662 gnu_pos = NULL_TREE;
6664 /* If we are packing the record and the field is BLKmode, round the
6665 size up to a byte boundary. */
6666 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6667 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6670 /* We need to make the size the maximum for the type if it is
6671 self-referential and an unconstrained type. In that case, we can't
6672 pack the field since we can't make a copy to align it. */
6673 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6675 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6676 && !Is_Constrained (Underlying_Type (gnat_field_type)))
6678 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6682 /* If a size is specified, adjust the field's type to it. */
6685 tree orig_field_type;
6687 /* If the field's type is justified modular, we would need to remove
6688 the wrapper to (better) meet the layout requirements. However we
6689 can do so only if the field is not aliased to preserve the unique
6690 layout and if the prescribed size is not greater than that of the
6691 packed array to preserve the justification. */
6692 if (!needs_strict_alignment
6693 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6694 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6695 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6697 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6699 /* Similarly if the field's type is a misaligned integral type, but
6700 there is no restriction on the size as there is no justification. */
6701 if (!needs_strict_alignment
6702 && TYPE_IS_PADDING_P (gnu_field_type)
6703 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
6704 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6707 = make_type_from_size (gnu_field_type, gnu_size,
6708 Has_Biased_Representation (gnat_field));
6710 orig_field_type = gnu_field_type;
6711 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6712 false, false, definition, true);
6714 /* If a padding record was made, declare it now since it will never be
6715 declared otherwise. This is necessary to ensure that its subtrees
6716 are properly marked. */
6717 if (gnu_field_type != orig_field_type
6718 && !DECL_P (TYPE_NAME (gnu_field_type)))
6719 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true,
6720 debug_info_p, gnat_field);
6723 /* Otherwise (or if there was an error), don't specify a position. */
6725 gnu_pos = NULL_TREE;
6727 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6728 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6730 /* Now create the decl for the field. */
6732 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6733 gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
6734 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6735 DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field);
6736 TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
6738 if (Ekind (gnat_field) == E_Discriminant)
6739 DECL_DISCRIMINANT_NUMBER (gnu_field)
6740 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6745 /* Return true if at least one member of COMPONENT_LIST needs strict
6749 components_need_strict_alignment (Node_Id component_list)
6751 Node_Id component_decl;
6753 for (component_decl = First_Non_Pragma (Component_Items (component_list));
6754 Present (component_decl);
6755 component_decl = Next_Non_Pragma (component_decl))
6757 Entity_Id gnat_field = Defining_Entity (component_decl);
6759 if (Is_Aliased (gnat_field))
6762 if (Strict_Alignment (Etype (gnat_field)))
6769 /* Return true if TYPE is a type with variable size or a padding type with a
6770 field of variable size or a record that has a field with such a type. */
6773 type_has_variable_size (tree type)
6777 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6780 if (TYPE_IS_PADDING_P (type)
6781 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6784 if (!RECORD_OR_UNION_TYPE_P (type))
6787 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
6788 if (type_has_variable_size (TREE_TYPE (field)))
6794 /* Return true if FIELD is an artificial field. */
6797 field_is_artificial (tree field)
6799 /* These fields are generated by the front-end proper. */
6800 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
6803 /* These fields are generated by gigi. */
6804 if (DECL_INTERNAL_P (field))
6810 /* Return true if FIELD is a non-artificial aliased field. */
6813 field_is_aliased (tree field)
6815 if (field_is_artificial (field))
6818 return DECL_ALIASED_P (field);
6821 /* Return true if FIELD is a non-artificial field with self-referential
6825 field_has_self_size (tree field)
6827 if (field_is_artificial (field))
6830 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
6833 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
6836 /* Return true if FIELD is a non-artificial field with variable size. */
6839 field_has_variable_size (tree field)
6841 if (field_is_artificial (field))
6844 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
6847 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
6850 /* qsort comparer for the bit positions of two record components. */
6853 compare_field_bitpos (const PTR rt1, const PTR rt2)
6855 const_tree const field1 = * (const_tree const *) rt1;
6856 const_tree const field2 = * (const_tree const *) rt2;
6858 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6860 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6863 /* Structure holding information for a given variant. */
6864 typedef struct vinfo
6866 /* The record type of the variant. */
6869 /* The name of the variant. */
6872 /* The qualifier of the variant. */
6875 /* Whether the variant has a rep clause. */
6878 /* Whether the variant is packed. */
6883 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set the
6884 result as the field list of GNU_RECORD_TYPE and finish it up. Return true
6885 if GNU_RECORD_TYPE has a rep clause which affects the layout (see below).
6886 When called from gnat_to_gnu_entity during the processing of a record type
6887 definition, the GCC node for the parent, if any, will be the single field
6888 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6889 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6890 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6892 PACKED is 1 if this is for a packed record, -1 if this is for a record
6893 with Component_Alignment of Storage_Unit, -2 if this is for a record
6894 with a specified alignment.
6896 DEFINITION is true if we are defining this record type.
6898 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
6899 out the record. This means the alignment only serves to force fields to
6900 be bitfields, but not to require the record to be that aligned. This is
6903 ALL_REP is true if a rep clause is present for all the fields.
6905 UNCHECKED_UNION is true if we are building this type for a record with a
6906 Pragma Unchecked_Union.
6908 ARTIFICIAL is true if this is a type that was generated by the compiler.
6910 DEBUG_INFO is true if we need to write debug information about the type.
6912 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
6913 mean that its contents may be unused as well, only the container itself.
6915 REORDER is true if we are permitted to reorder components of this type.
6917 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
6918 the outer record type down to this variant level. It is nonzero only if
6919 all the fields down to this level have a rep clause and ALL_REP is false.
6921 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6922 with a rep clause is to be added; in this case, that is all that should
6923 be done with such fields and the return value will be false. */
6926 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
6927 tree gnu_field_list, int packed, bool definition,
6928 bool cancel_alignment, bool all_rep,
6929 bool unchecked_union, bool artificial,
6930 bool debug_info, bool maybe_unused, bool reorder,
6931 tree first_free_pos, tree *p_gnu_rep_list)
6933 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6934 bool variants_have_rep = all_rep;
6935 bool layout_with_rep = false;
6936 bool has_self_field = false;
6937 bool has_aliased_after_self_field = false;
6938 Node_Id component_decl, variant_part;
6939 tree gnu_field, gnu_next, gnu_last;
6940 tree gnu_variant_part = NULL_TREE;
6941 tree gnu_rep_list = NULL_TREE;
6942 tree gnu_var_list = NULL_TREE;
6943 tree gnu_self_list = NULL_TREE;
6944 tree gnu_zero_list = NULL_TREE;
6946 /* For each component referenced in a component declaration create a GCC
6947 field and add it to the list, skipping pragmas in the GNAT list. */
6948 gnu_last = tree_last (gnu_field_list);
6949 if (Present (Component_Items (gnat_component_list)))
6951 = First_Non_Pragma (Component_Items (gnat_component_list));
6952 Present (component_decl);
6953 component_decl = Next_Non_Pragma (component_decl))
6955 Entity_Id gnat_field = Defining_Entity (component_decl);
6956 Name_Id gnat_name = Chars (gnat_field);
6958 /* If present, the _Parent field must have been created as the single
6959 field of the record type. Put it before any other fields. */
6960 if (gnat_name == Name_uParent)
6962 gnu_field = TYPE_FIELDS (gnu_record_type);
6963 gnu_field_list = chainon (gnu_field_list, gnu_field);
6967 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
6968 definition, debug_info);
6970 /* If this is the _Tag field, put it before any other fields. */
6971 if (gnat_name == Name_uTag)
6972 gnu_field_list = chainon (gnu_field_list, gnu_field);
6974 /* If this is the _Controller field, put it before the other
6975 fields except for the _Tag or _Parent field. */
6976 else if (gnat_name == Name_uController && gnu_last)
6978 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
6979 DECL_CHAIN (gnu_last) = gnu_field;
6982 /* If this is a regular field, put it after the other fields. */
6985 DECL_CHAIN (gnu_field) = gnu_field_list;
6986 gnu_field_list = gnu_field;
6988 gnu_last = gnu_field;
6990 /* And record information for the final layout. */
6991 if (field_has_self_size (gnu_field))
6992 has_self_field = true;
6993 else if (has_self_field && field_is_aliased (gnu_field))
6994 has_aliased_after_self_field = true;
6998 save_gnu_tree (gnat_field, gnu_field, false);
7001 /* At the end of the component list there may be a variant part. */
7002 variant_part = Variant_Part (gnat_component_list);
7004 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7005 mutually exclusive and should go in the same memory. To do this we need
7006 to treat each variant as a record whose elements are created from the
7007 component list for the variant. So here we create the records from the
7008 lists for the variants and put them all into the QUAL_UNION_TYPE.
7009 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7010 use GNU_RECORD_TYPE if there are no fields so far. */
7011 if (Present (variant_part))
7013 Node_Id gnat_discr = Name (variant_part), variant;
7014 tree gnu_discr = gnat_to_gnu (gnat_discr);
7015 tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
7017 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7019 tree gnu_union_type, gnu_union_name;
7020 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
7021 bool union_field_needs_strict_alignment = false;
7022 auto_vec <vinfo_t, 16> variant_types;
7023 vinfo_t *gnu_variant;
7024 unsigned int variants_align = 0;
7028 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7030 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7031 are all in the variant part, to match the layout of C unions. There
7032 is an associated check below. */
7033 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
7034 gnu_union_type = gnu_record_type;
7038 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7040 TYPE_NAME (gnu_union_type) = gnu_union_name;
7041 TYPE_ALIGN (gnu_union_type) = 0;
7042 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7045 /* If all the fields down to this level have a rep clause, find out
7046 whether all the fields at this level also have one. If so, then
7047 compute the new first free position to be passed downward. */
7048 this_first_free_pos = first_free_pos;
7049 if (this_first_free_pos)
7051 for (gnu_field = gnu_field_list;
7053 gnu_field = DECL_CHAIN (gnu_field))
7054 if (DECL_FIELD_OFFSET (gnu_field))
7056 tree pos = bit_position (gnu_field);
7057 if (!tree_int_cst_lt (pos, this_first_free_pos))
7059 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
7063 this_first_free_pos = NULL_TREE;
7068 /* We build the variants in two passes. The bulk of the work is done in
7069 the first pass, that is to say translating the GNAT nodes, building
7070 the container types and computing the associated properties. However
7071 we cannot finish up the container types during this pass because we
7072 don't know where the variant part will be placed until the end. */
7073 for (variant = First_Non_Pragma (Variants (variant_part));
7075 variant = Next_Non_Pragma (variant))
7077 tree gnu_variant_type = make_node (RECORD_TYPE);
7078 tree gnu_inner_name, gnu_qual;
7083 Get_Variant_Encoding (variant);
7084 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7085 TYPE_NAME (gnu_variant_type)
7086 = concat_name (gnu_union_name,
7087 IDENTIFIER_POINTER (gnu_inner_name));
7089 /* Set the alignment of the inner type in case we need to make
7090 inner objects into bitfields, but then clear it out so the
7091 record actually gets only the alignment required. */
7092 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
7093 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7095 /* Similarly, if the outer record has a size specified and all
7096 the fields have a rep clause, we can propagate the size. */
7097 if (all_rep_and_size)
7099 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7100 TYPE_SIZE_UNIT (gnu_variant_type)
7101 = TYPE_SIZE_UNIT (gnu_record_type);
7104 /* Add the fields into the record type for the variant. Note that
7105 we aren't sure to really use it at this point, see below. */
7107 = components_to_record (gnu_variant_type, Component_List (variant),
7108 NULL_TREE, packed, definition,
7109 !all_rep_and_size, all_rep,
7111 true, debug_info, true, reorder,
7112 this_first_free_pos,
7113 all_rep || this_first_free_pos
7114 ? NULL : &gnu_rep_list);
7116 /* Translate the qualifier and annotate the GNAT node. */
7117 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7118 Set_Present_Expr (variant, annotate_value (gnu_qual));
7120 /* Deal with packedness like in gnat_to_gnu_field. */
7121 if (components_need_strict_alignment (Component_List (variant)))
7124 union_field_needs_strict_alignment = true;
7128 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7130 /* Push this variant onto the stack for the second pass. */
7131 vinfo.type = gnu_variant_type;
7132 vinfo.name = gnu_inner_name;
7133 vinfo.qual = gnu_qual;
7134 vinfo.has_rep = has_rep;
7135 vinfo.packed = field_packed;
7136 variant_types.safe_push (vinfo);
7138 /* Compute the global properties that will determine the placement of
7139 the variant part. */
7140 variants_have_rep |= has_rep;
7141 if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align)
7142 variants_align = TYPE_ALIGN (gnu_variant_type);
7145 /* Round up the first free position to the alignment of the variant part
7146 for the variants without rep clause. This will guarantee a consistent
7147 layout independently of the placement of the variant part. */
7148 if (variants_have_rep && variants_align > 0 && this_first_free_pos)
7149 this_first_free_pos = round_up (this_first_free_pos, variants_align);
7151 /* In the second pass, the container types are adjusted if necessary and
7152 finished up, then the corresponding fields of the variant part are
7153 built with their qualifier, unless this is an unchecked union. */
7154 FOR_EACH_VEC_ELT (variant_types, i, gnu_variant)
7156 tree gnu_variant_type = gnu_variant->type;
7157 tree gnu_field_list = TYPE_FIELDS (gnu_variant_type);
7159 /* If this is an Unchecked_Union whose fields are all in the variant
7160 part and we have a single field with no representation clause or
7161 placed at offset zero, use the field directly to match the layout
7163 if (TREE_CODE (gnu_record_type) == UNION_TYPE
7165 && !DECL_CHAIN (gnu_field_list)
7166 && (!DECL_FIELD_OFFSET (gnu_field_list)
7167 || integer_zerop (bit_position (gnu_field_list))))
7169 gnu_field = gnu_field_list;
7170 DECL_CONTEXT (gnu_field) = gnu_record_type;
7174 /* Finalize the variant type now. We used to throw away empty
7175 record types but we no longer do that because we need them to
7176 generate complete debug info for the variant; otherwise, the
7177 union type definition will be lacking the fields associated
7178 with these empty variants. */
7179 if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep)
7181 /* The variant part will be at offset 0 so we need to ensure
7182 that the fields are laid out starting from the first free
7183 position at this level. */
7184 tree gnu_rep_type = make_node (RECORD_TYPE);
7186 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
7188 = create_rep_part (gnu_rep_type, gnu_variant_type,
7189 this_first_free_pos);
7190 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7191 gnu_field_list = gnu_rep_part;
7192 finish_record_type (gnu_variant_type, gnu_field_list, 0,
7197 rest_of_record_type_compilation (gnu_variant_type);
7198 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7199 true, debug_info, gnat_component_list);
7202 = create_field_decl (gnu_variant->name, gnu_variant_type,
7205 ? TYPE_SIZE (gnu_variant_type) : 0,
7206 variants_have_rep ? bitsize_zero_node : 0,
7207 gnu_variant->packed, 0);
7209 DECL_INTERNAL_P (gnu_field) = 1;
7211 if (!unchecked_union)
7212 DECL_QUALIFIER (gnu_field) = gnu_variant->qual;
7215 DECL_CHAIN (gnu_field) = gnu_variant_list;
7216 gnu_variant_list = gnu_field;
7219 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7220 if (gnu_variant_list)
7222 int union_field_packed;
7224 if (all_rep_and_size)
7226 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7227 TYPE_SIZE_UNIT (gnu_union_type)
7228 = TYPE_SIZE_UNIT (gnu_record_type);
7231 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7232 all_rep_and_size ? 1 : 0, debug_info);
7234 /* If GNU_UNION_TYPE is our record type, it means we must have an
7235 Unchecked_Union with no fields. Verify that and, if so, just
7237 if (gnu_union_type == gnu_record_type)
7239 gcc_assert (unchecked_union
7242 return variants_have_rep;
7245 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true,
7246 debug_info, gnat_component_list);
7248 /* Deal with packedness like in gnat_to_gnu_field. */
7249 if (union_field_needs_strict_alignment)
7250 union_field_packed = 0;
7253 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7256 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7258 ? TYPE_SIZE (gnu_union_type) : 0,
7259 variants_have_rep ? bitsize_zero_node : 0,
7260 union_field_packed, 0);
7262 DECL_INTERNAL_P (gnu_variant_part) = 1;
7266 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
7267 permitted to reorder components, self-referential sizes or variable sizes.
7268 If they do, pull them out and put them onto the appropriate list. We have
7269 to do this in a separate pass since we want to handle the discriminants
7270 but can't play with them until we've used them in debugging data above.
7272 Similarly, pull out the fields with zero size and no rep clause, as they
7273 would otherwise modify the layout and thus very likely run afoul of the
7274 Ada semantics, which are different from those of C here.
7276 ??? If we reorder them, debugging information will be wrong but there is
7277 nothing that can be done about this at the moment. */
7278 gnu_last = NULL_TREE;
7280 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7283 DECL_CHAIN (gnu_last) = gnu_next; \
7285 gnu_field_list = gnu_next; \
7287 DECL_CHAIN (gnu_field) = (LIST); \
7288 (LIST) = gnu_field; \
7291 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7293 gnu_next = DECL_CHAIN (gnu_field);
7295 if (DECL_FIELD_OFFSET (gnu_field))
7297 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7301 if ((reorder || has_aliased_after_self_field)
7302 && field_has_self_size (gnu_field))
7304 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7308 if (reorder && field_has_variable_size (gnu_field))
7310 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7314 if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
7316 DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
7317 SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
7318 DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
7319 if (field_is_aliased (gnu_field))
7320 TYPE_ALIGN (gnu_record_type)
7321 = MAX (TYPE_ALIGN (gnu_record_type),
7322 TYPE_ALIGN (TREE_TYPE (gnu_field)));
7323 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
7327 gnu_last = gnu_field;
7330 #undef MOVE_FROM_FIELD_LIST_TO
7332 gnu_field_list = nreverse (gnu_field_list);
7334 /* If permitted, we reorder the fields as follows:
7336 1) all fixed length fields,
7337 2) all fields whose length doesn't depend on discriminants,
7338 3) all fields whose length depends on discriminants,
7339 4) the variant part,
7341 within the record and within each variant recursively. */
7344 = chainon (gnu_field_list, chainon (gnu_var_list, gnu_self_list));
7346 /* Otherwise, if there is an aliased field placed after a field whose length
7347 depends on discriminants, we put all the fields of the latter sort, last.
7348 We need to do this in case an object of this record type is mutable. */
7349 else if (has_aliased_after_self_field)
7350 gnu_field_list = chainon (gnu_field_list, gnu_self_list);
7352 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7353 in our REP list to the previous level because this level needs them in
7354 order to do a correct layout, i.e. avoid having overlapping fields. */
7355 if (p_gnu_rep_list && gnu_rep_list)
7356 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7358 /* Otherwise, sort the fields by bit position and put them into their own
7359 record, before the others, if we also have fields without rep clause. */
7360 else if (gnu_rep_list)
7362 tree gnu_rep_type, gnu_rep_part;
7363 int i, len = list_length (gnu_rep_list);
7364 tree *gnu_arr = XALLOCAVEC (tree, len);
7366 /* If all the fields have a rep clause, we can do a flat layout. */
7367 layout_with_rep = !gnu_field_list
7368 && (!gnu_variant_part || variants_have_rep);
7370 = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE);
7372 for (gnu_field = gnu_rep_list, i = 0;
7374 gnu_field = DECL_CHAIN (gnu_field), i++)
7375 gnu_arr[i] = gnu_field;
7377 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7379 /* Put the fields in the list in order of increasing position, which
7380 means we start from the end. */
7381 gnu_rep_list = NULL_TREE;
7382 for (i = len - 1; i >= 0; i--)
7384 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7385 gnu_rep_list = gnu_arr[i];
7386 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7389 if (layout_with_rep)
7390 gnu_field_list = gnu_rep_list;
7393 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
7395 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
7396 without rep clause are laid out starting from this position.
7397 Therefore, we force it as a minimal size on the REP part. */
7399 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
7401 /* Chain the REP part at the beginning of the field list. */
7402 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7403 gnu_field_list = gnu_rep_part;
7407 /* Chain the variant part at the end of the field list. */
7408 if (gnu_variant_part)
7409 gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
7411 if (cancel_alignment)
7412 TYPE_ALIGN (gnu_record_type) = 0;
7414 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
7416 finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0,
7417 debug_info && !maybe_unused);
7419 /* Chain the fields with zero size at the beginning of the field list. */
7421 TYPE_FIELDS (gnu_record_type)
7422 = chainon (gnu_zero_list, TYPE_FIELDS (gnu_record_type));
7424 return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
7427 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7428 placed into an Esize, Component_Bit_Offset, or Component_Size value
7429 in the GNAT tree. */
7432 annotate_value (tree gnu_size)
7435 Node_Ref_Or_Val ops[3], ret, pre_op1 = No_Uint;
7436 struct tree_int_map in;
7439 /* See if we've already saved the value for this node. */
7440 if (EXPR_P (gnu_size))
7442 struct tree_int_map *e;
7444 in.base.from = gnu_size;
7445 e = (struct tree_int_map *) htab_find (annotate_value_cache, &in);
7448 return (Node_Ref_Or_Val) e->to;
7451 in.base.from = NULL_TREE;
7453 /* If we do not return inside this switch, TCODE will be set to the
7454 code to use for a Create_Node operand and LEN (set above) will be
7455 the number of recursive calls for us to make. */
7457 switch (TREE_CODE (gnu_size))
7460 return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
7463 /* The only case we handle here is a simple discriminant reference. */
7464 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7466 tree n = DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1));
7468 /* Climb up the chain of successive extensions, if any. */
7469 while (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == COMPONENT_REF
7470 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 1))
7472 gnu_size = TREE_OPERAND (gnu_size, 0);
7474 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR)
7476 Create_Node (Discrim_Val, annotate_value (n), No_Uint, No_Uint);
7481 CASE_CONVERT: case NON_LVALUE_EXPR:
7482 return annotate_value (TREE_OPERAND (gnu_size, 0));
7484 /* Now just list the operations we handle. */
7485 case COND_EXPR: tcode = Cond_Expr; break;
7486 case PLUS_EXPR: tcode = Plus_Expr; break;
7487 case MINUS_EXPR: tcode = Minus_Expr; break;
7488 case MULT_EXPR: tcode = Mult_Expr; break;
7489 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7490 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7491 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7492 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7493 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7494 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7495 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7496 case NEGATE_EXPR: tcode = Negate_Expr; break;
7497 case MIN_EXPR: tcode = Min_Expr; break;
7498 case MAX_EXPR: tcode = Max_Expr; break;
7499 case ABS_EXPR: tcode = Abs_Expr; break;
7500 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7501 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7502 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7503 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7504 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7505 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7506 case LT_EXPR: tcode = Lt_Expr; break;
7507 case LE_EXPR: tcode = Le_Expr; break;
7508 case GT_EXPR: tcode = Gt_Expr; break;
7509 case GE_EXPR: tcode = Ge_Expr; break;
7510 case EQ_EXPR: tcode = Eq_Expr; break;
7511 case NE_EXPR: tcode = Ne_Expr; break;
7514 tcode = Bit_And_Expr;
7515 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
7516 Such values appear in expressions with aligning patterns. Note that,
7517 since sizetype is unsigned, we have to jump through some hoops. */
7518 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
7520 tree op1 = TREE_OPERAND (gnu_size, 1);
7521 wide_int signed_op1 = wi::sext (op1, TYPE_PRECISION (sizetype));
7522 if (wi::neg_p (signed_op1))
7524 op1 = wide_int_to_tree (sizetype, wi::neg (signed_op1));
7525 pre_op1 = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
7531 /* In regular mode, inline back only if symbolic annotation is requested
7532 in order to avoid memory explosion on big discriminated record types.
7533 But not in ASIS mode, as symbolic annotation is required for DDA. */
7534 if (List_Representation_Info == 3 || type_annotate_only)
7536 tree t = maybe_inline_call_in_expr (gnu_size);
7538 return annotate_value (t);
7541 return Uint_Minus_1;
7543 /* Fall through... */
7549 /* Now get each of the operands that's relevant for this code. If any
7550 cannot be expressed as a repinfo node, say we can't. */
7551 for (i = 0; i < 3; i++)
7554 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
7556 if (i == 1 && pre_op1 != No_Uint)
7559 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7560 if (ops[i] == No_Uint)
7564 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7566 /* Save the result in the cache. */
7569 struct tree_int_map **h;
7570 /* We can't assume the hash table data hasn't moved since the initial
7571 look up, so we have to search again. Allocating and inserting an
7572 entry at that point would be an alternative, but then we'd better
7573 discard the entry if we decided not to cache it. */
7574 h = (struct tree_int_map **)
7575 htab_find_slot (annotate_value_cache, &in, INSERT);
7577 *h = ggc_alloc<tree_int_map> ();
7578 (*h)->base.from = gnu_size;
7585 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7586 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7587 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7588 BY_REF is true if the object is used by reference. */
7591 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7595 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7596 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7598 gnu_type = TREE_TYPE (gnu_type);
7601 if (Unknown_Esize (gnat_entity))
7603 if (TREE_CODE (gnu_type) == RECORD_TYPE
7604 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7605 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
7607 size = TYPE_SIZE (gnu_type);
7610 Set_Esize (gnat_entity, annotate_value (size));
7613 if (Unknown_Alignment (gnat_entity))
7614 Set_Alignment (gnat_entity,
7615 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7618 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
7619 Return NULL_TREE if there is no such element in the list. */
7622 purpose_member_field (const_tree elem, tree list)
7626 tree field = TREE_PURPOSE (list);
7627 if (SAME_FIELD_P (field, elem))
7629 list = TREE_CHAIN (list);
7634 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7635 set Component_Bit_Offset and Esize of the components to the position and
7636 size used by Gigi. */
7639 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7641 Entity_Id gnat_field;
7644 /* We operate by first making a list of all fields and their position (we
7645 can get the size easily) and then update all the sizes in the tree. */
7647 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7648 BIGGEST_ALIGNMENT, NULL_TREE);
7650 for (gnat_field = First_Entity (gnat_entity);
7651 Present (gnat_field);
7652 gnat_field = Next_Entity (gnat_field))
7653 if (Ekind (gnat_field) == E_Component
7654 || (Ekind (gnat_field) == E_Discriminant
7655 && !Is_Unchecked_Union (Scope (gnat_field))))
7657 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7663 /* If we are just annotating types and the type is tagged, the tag
7664 and the parent components are not generated by the front-end so
7665 we need to add the appropriate offset to each component without
7666 representation clause. */
7667 if (type_annotate_only
7668 && Is_Tagged_Type (gnat_entity)
7669 && No (Component_Clause (gnat_field)))
7671 /* For a component appearing in the current extension, the
7672 offset is the size of the parent. */
7673 if (Is_Derived_Type (gnat_entity)
7674 && Original_Record_Component (gnat_field) == gnat_field)
7676 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7679 parent_offset = bitsize_int (POINTER_SIZE);
7681 if (TYPE_FIELDS (gnu_type))
7683 = round_up (parent_offset,
7684 DECL_ALIGN (TYPE_FIELDS (gnu_type)));
7687 parent_offset = bitsize_zero_node;
7689 Set_Component_Bit_Offset
7692 (size_binop (PLUS_EXPR,
7693 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7694 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7697 Set_Esize (gnat_field,
7698 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7700 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7702 /* If there is no entry, this is an inherited component whose
7703 position is the same as in the parent type. */
7704 Set_Component_Bit_Offset
7706 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7708 Set_Esize (gnat_field,
7709 Esize (Original_Record_Component (gnat_field)));
7714 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7715 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7716 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7717 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7718 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7719 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7720 pre-existing list to be chained to the newly created entries. */
7723 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7724 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7728 for (gnu_field = TYPE_FIELDS (gnu_type);
7730 gnu_field = DECL_CHAIN (gnu_field))
7732 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7733 DECL_FIELD_BIT_OFFSET (gnu_field));
7734 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7735 DECL_FIELD_OFFSET (gnu_field));
7736 unsigned int our_offset_align
7737 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7738 tree v = make_tree_vec (3);
7740 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7741 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7742 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7743 gnu_list = tree_cons (gnu_field, v, gnu_list);
7745 /* Recurse on internal fields, flattening the nested fields except for
7746 those in the variant part, if requested. */
7747 if (DECL_INTERNAL_P (gnu_field))
7749 tree gnu_field_type = TREE_TYPE (gnu_field);
7750 if (do_not_flatten_variant
7751 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7753 = build_position_list (gnu_field_type, do_not_flatten_variant,
7754 size_zero_node, bitsize_zero_node,
7755 BIGGEST_ALIGNMENT, gnu_list);
7758 = build_position_list (gnu_field_type, do_not_flatten_variant,
7759 gnu_our_offset, gnu_our_bitpos,
7760 our_offset_align, gnu_list);
7767 /* Return a list describing the substitutions needed to reflect the
7768 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7769 be in any order. The values in an element of the list are in the form
7770 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
7771 a definition of GNAT_SUBTYPE. */
7773 static vec<subst_pair>
7774 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7776 vec<subst_pair> gnu_list = vNULL;
7777 Entity_Id gnat_discrim;
7778 Node_Id gnat_constr;
7780 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7781 gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
7782 Present (gnat_discrim);
7783 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7784 gnat_constr = Next_Elmt (gnat_constr))
7785 /* Ignore access discriminants. */
7786 if (!Is_Access_Type (Etype (Node (gnat_constr))))
7788 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7789 tree replacement = convert (TREE_TYPE (gnu_field),
7790 elaborate_expression
7791 (Node (gnat_constr), gnat_subtype,
7792 get_entity_name (gnat_discrim),
7793 definition, true, false));
7794 subst_pair s = {gnu_field, replacement};
7795 gnu_list.safe_push (s);
7801 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
7802 variants of QUAL_UNION_TYPE that are still relevant after applying
7803 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
7804 list to be prepended to the newly created entries. */
7806 static vec<variant_desc>
7807 build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
7808 vec<variant_desc> gnu_list)
7812 for (gnu_field = TYPE_FIELDS (qual_union_type);
7814 gnu_field = DECL_CHAIN (gnu_field))
7816 tree qual = DECL_QUALIFIER (gnu_field);
7820 FOR_EACH_VEC_ELT (subst_list, i, s)
7821 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
7823 /* If the new qualifier is not unconditionally false, its variant may
7824 still be accessed. */
7825 if (!integer_zerop (qual))
7827 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7828 variant_desc v = {variant_type, gnu_field, qual, NULL_TREE};
7830 gnu_list.safe_push (v);
7832 /* Recurse on the variant subpart of the variant, if any. */
7833 variant_subpart = get_variant_part (variant_type);
7834 if (variant_subpart)
7835 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
7836 subst_list, gnu_list);
7838 /* If the new qualifier is unconditionally true, the subsequent
7839 variants cannot be accessed. */
7840 if (integer_onep (qual))
7848 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7849 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
7850 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
7851 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
7852 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
7853 true if we are being called to process the Component_Size of GNAT_OBJECT;
7854 this is used only for error messages. ZERO_OK is true if a size of zero
7855 is permitted; if ZERO_OK is false, it means that a size of zero should be
7856 treated as an unspecified size. */
7859 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7860 enum tree_code kind, bool component_p, bool zero_ok)
7862 Node_Id gnat_error_node;
7863 tree type_size, size;
7865 /* Return 0 if no size was specified. */
7866 if (uint_size == No_Uint)
7869 /* Ignore a negative size since that corresponds to our back-annotation. */
7870 if (UI_Lt (uint_size, Uint_0))
7873 /* Find the node to use for error messages. */
7874 if ((Ekind (gnat_object) == E_Component
7875 || Ekind (gnat_object) == E_Discriminant)
7876 && Present (Component_Clause (gnat_object)))
7877 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7878 else if (Present (Size_Clause (gnat_object)))
7879 gnat_error_node = Expression (Size_Clause (gnat_object));
7881 gnat_error_node = gnat_object;
7883 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7884 but cannot be represented in bitsizetype. */
7885 size = UI_To_gnu (uint_size, bitsizetype);
7886 if (TREE_OVERFLOW (size))
7889 post_error_ne ("component size for& is too large", gnat_error_node,
7892 post_error_ne ("size for& is too large", gnat_error_node,
7897 /* Ignore a zero size if it is not permitted. */
7898 if (!zero_ok && integer_zerop (size))
7901 /* The size of objects is always a multiple of a byte. */
7902 if (kind == VAR_DECL
7903 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7906 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7907 gnat_error_node, gnat_object);
7909 post_error_ne ("size for& is not a multiple of Storage_Unit",
7910 gnat_error_node, gnat_object);
7914 /* If this is an integral type or a packed array type, the front-end has
7915 already verified the size, so we need not do it here (which would mean
7916 checking against the bounds). However, if this is an aliased object,
7917 it may not be smaller than the type of the object. */
7918 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7919 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7922 /* If the object is a record that contains a template, add the size of the
7923 template to the specified size. */
7924 if (TREE_CODE (gnu_type) == RECORD_TYPE
7925 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7926 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7928 if (kind == VAR_DECL
7929 /* If a type needs strict alignment, a component of this type in
7930 a packed record cannot be packed and thus uses the type size. */
7931 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7932 type_size = TYPE_SIZE (gnu_type);
7934 type_size = rm_size (gnu_type);
7936 /* Modify the size of a discriminated type to be the maximum size. */
7937 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7938 type_size = max_size (type_size, true);
7940 /* If this is an access type or a fat pointer, the minimum size is that given
7941 by the smallest integral mode that's valid for pointers. */
7942 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7944 enum machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7945 while (!targetm.valid_pointer_mode (p_mode))
7946 p_mode = GET_MODE_WIDER_MODE (p_mode);
7947 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7950 /* Issue an error either if the default size of the object isn't a constant
7951 or if the new size is smaller than it. */
7952 if (TREE_CODE (type_size) != INTEGER_CST
7953 || TREE_OVERFLOW (type_size)
7954 || tree_int_cst_lt (size, type_size))
7958 ("component size for& too small{, minimum allowed is ^}",
7959 gnat_error_node, gnat_object, type_size);
7962 ("size for& too small{, minimum allowed is ^}",
7963 gnat_error_node, gnat_object, type_size);
7970 /* Similarly, but both validate and process a value of RM size. This routine
7971 is only called for types. */
7974 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7976 Node_Id gnat_attr_node;
7977 tree old_size, size;
7979 /* Do nothing if no size was specified. */
7980 if (uint_size == No_Uint)
7983 /* Ignore a negative size since that corresponds to our back-annotation. */
7984 if (UI_Lt (uint_size, Uint_0))
7987 /* Only issue an error if a Value_Size clause was explicitly given.
7988 Otherwise, we'd be duplicating an error on the Size clause. */
7990 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7992 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
7993 but cannot be represented in bitsizetype. */
7994 size = UI_To_gnu (uint_size, bitsizetype);
7995 if (TREE_OVERFLOW (size))
7997 if (Present (gnat_attr_node))
7998 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8003 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8004 exists, or this is an integer type, in which case the front-end will
8005 have always set it. */
8006 if (No (gnat_attr_node)
8007 && integer_zerop (size)
8008 && !Has_Size_Clause (gnat_entity)
8009 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8012 old_size = rm_size (gnu_type);
8014 /* If the old size is self-referential, get the maximum size. */
8015 if (CONTAINS_PLACEHOLDER_P (old_size))
8016 old_size = max_size (old_size, true);
8018 /* Issue an error either if the old size of the object isn't a constant or
8019 if the new size is smaller than it. The front-end has already verified
8020 this for scalar and packed array types. */
8021 if (TREE_CODE (old_size) != INTEGER_CST
8022 || TREE_OVERFLOW (old_size)
8023 || (AGGREGATE_TYPE_P (gnu_type)
8024 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8025 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8026 && !(TYPE_IS_PADDING_P (gnu_type)
8027 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8028 && TYPE_PACKED_ARRAY_TYPE_P
8029 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8030 && tree_int_cst_lt (size, old_size)))
8032 if (Present (gnat_attr_node))
8034 ("Value_Size for& too small{, minimum allowed is ^}",
8035 gnat_attr_node, gnat_entity, old_size);
8039 /* Otherwise, set the RM size proper for integral types... */
8040 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8041 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8042 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8043 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8044 SET_TYPE_RM_SIZE (gnu_type, size);
8046 /* ...or the Ada size for record and union types. */
8047 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
8048 && !TYPE_FAT_POINTER_P (gnu_type))
8049 SET_TYPE_ADA_SIZE (gnu_type, size);
8052 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8053 a type or object whose present alignment is ALIGN. If this alignment is
8054 valid, return it. Otherwise, give an error and return ALIGN. */
8057 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8059 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8060 unsigned int new_align;
8061 Node_Id gnat_error_node;
8063 /* Don't worry about checking alignment if alignment was not specified
8064 by the source program and we already posted an error for this entity. */
8065 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8068 /* Post the error on the alignment clause if any. Note, for the implicit
8069 base type of an array type, the alignment clause is on the first
8071 if (Present (Alignment_Clause (gnat_entity)))
8072 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8074 else if (Is_Itype (gnat_entity)
8075 && Is_Array_Type (gnat_entity)
8076 && Etype (gnat_entity) == gnat_entity
8077 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8079 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8082 gnat_error_node = gnat_entity;
8084 /* Within GCC, an alignment is an integer, so we must make sure a value is
8085 specified that fits in that range. Also, there is an upper bound to
8086 alignments we can support/allow. */
8087 if (!UI_Is_In_Int_Range (alignment)
8088 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8089 post_error_ne_num ("largest supported alignment for& is ^",
8090 gnat_error_node, gnat_entity, max_allowed_alignment);
8091 else if (!(Present (Alignment_Clause (gnat_entity))
8092 && From_At_Mod (Alignment_Clause (gnat_entity)))
8093 && new_align * BITS_PER_UNIT < align)
8095 unsigned int double_align;
8096 bool is_capped_double, align_clause;
8098 /* If the default alignment of "double" or larger scalar types is
8099 specifically capped and the new alignment is above the cap, do
8100 not post an error and change the alignment only if there is an
8101 alignment clause; this makes it possible to have the associated
8102 GCC type overaligned by default for performance reasons. */
8103 if ((double_align = double_float_alignment) > 0)
8106 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8108 = is_double_float_or_array (gnat_type, &align_clause);
8110 else if ((double_align = double_scalar_alignment) > 0)
8113 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8115 = is_double_scalar_or_array (gnat_type, &align_clause);
8118 is_capped_double = align_clause = false;
8120 if (is_capped_double && new_align >= double_align)
8123 align = new_align * BITS_PER_UNIT;
8127 if (is_capped_double)
8128 align = double_align * BITS_PER_UNIT;
8130 post_error_ne_num ("alignment for& must be at least ^",
8131 gnat_error_node, gnat_entity,
8132 align / BITS_PER_UNIT);
8137 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8138 if (new_align > align)
8145 /* Verify that OBJECT, a type or decl, is something we can implement
8146 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
8147 if we require atomic components. */
8150 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
8152 Node_Id gnat_error_point = gnat_entity;
8154 enum machine_mode mode;
8158 /* There are three case of what OBJECT can be. It can be a type, in which
8159 case we take the size, alignment and mode from the type. It can be a
8160 declaration that was indirect, in which case the relevant values are
8161 that of the type being pointed to, or it can be a normal declaration,
8162 in which case the values are of the decl. The code below assumes that
8163 OBJECT is either a type or a decl. */
8164 if (TYPE_P (object))
8166 /* If this is an anonymous base type, nothing to check. Error will be
8167 reported on the source type. */
8168 if (!Comes_From_Source (gnat_entity))
8171 mode = TYPE_MODE (object);
8172 align = TYPE_ALIGN (object);
8173 size = TYPE_SIZE (object);
8175 else if (DECL_BY_REF_P (object))
8177 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
8178 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
8179 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
8183 mode = DECL_MODE (object);
8184 align = DECL_ALIGN (object);
8185 size = DECL_SIZE (object);
8188 /* Consider all floating-point types atomic and any types that that are
8189 represented by integers no wider than a machine word. */
8190 if (GET_MODE_CLASS (mode) == MODE_FLOAT
8191 || ((GET_MODE_CLASS (mode) == MODE_INT
8192 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
8193 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
8196 /* For the moment, also allow anything that has an alignment equal
8197 to its size and which is smaller than a word. */
8198 if (size && TREE_CODE (size) == INTEGER_CST
8199 && compare_tree_int (size, align) == 0
8200 && align <= BITS_PER_WORD)
8203 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
8204 gnat_node = Next_Rep_Item (gnat_node))
8206 if (!comp_p && Nkind (gnat_node) == N_Pragma
8207 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8209 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8210 else if (comp_p && Nkind (gnat_node) == N_Pragma
8211 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
8212 == Pragma_Atomic_Components))
8213 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8217 post_error_ne ("atomic access to component of & cannot be guaranteed",
8218 gnat_error_point, gnat_entity);
8220 post_error_ne ("atomic access to & cannot be guaranteed",
8221 gnat_error_point, gnat_entity);
8225 /* Helper for the intrin compatibility checks family. Evaluate whether
8226 two types are definitely incompatible. */
8229 intrin_types_incompatible_p (tree t1, tree t2)
8231 enum tree_code code;
8233 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8236 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8239 if (TREE_CODE (t1) != TREE_CODE (t2))
8242 code = TREE_CODE (t1);
8248 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8251 case REFERENCE_TYPE:
8252 /* Assume designated types are ok. We'd need to account for char * and
8253 void * variants to do better, which could rapidly get messy and isn't
8254 clearly worth the effort. */
8264 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8265 on the Ada/builtin argument lists for the INB binding. */
8268 intrin_arglists_compatible_p (intrin_binding_t * inb)
8270 function_args_iterator ada_iter, btin_iter;
8272 function_args_iter_init (&ada_iter, inb->ada_fntype);
8273 function_args_iter_init (&btin_iter, inb->btin_fntype);
8275 /* Sequence position of the last argument we checked. */
8280 tree ada_type = function_args_iter_cond (&ada_iter);
8281 tree btin_type = function_args_iter_cond (&btin_iter);
8283 /* If we've exhausted both lists simultaneously, we're done. */
8284 if (ada_type == NULL_TREE && btin_type == NULL_TREE)
8287 /* If one list is shorter than the other, they fail to match. */
8288 if (ada_type == NULL_TREE || btin_type == NULL_TREE)
8291 /* If we're done with the Ada args and not with the internal builtin
8292 args, or the other way around, complain. */
8293 if (ada_type == void_type_node
8294 && btin_type != void_type_node)
8296 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8300 if (btin_type == void_type_node
8301 && ada_type != void_type_node)
8303 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8304 inb->gnat_entity, inb->gnat_entity, argpos);
8308 /* Otherwise, check that types match for the current argument. */
8310 if (intrin_types_incompatible_p (ada_type, btin_type))
8312 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8313 inb->gnat_entity, inb->gnat_entity, argpos);
8318 function_args_iter_next (&ada_iter);
8319 function_args_iter_next (&btin_iter);
8325 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8326 on the Ada/builtin return values for the INB binding. */
8329 intrin_return_compatible_p (intrin_binding_t * inb)
8331 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8332 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8334 /* Accept function imported as procedure, common and convenient. */
8335 if (VOID_TYPE_P (ada_return_type)
8336 && !VOID_TYPE_P (btin_return_type))
8339 /* If return type is Address (integer type), map it to void *. */
8340 if (Is_Descendent_Of_Address (Etype (inb->gnat_entity)))
8341 ada_return_type = ptr_void_type_node;
8343 /* Check return types compatibility otherwise. Note that this
8344 handles void/void as well. */
8345 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8347 post_error ("?intrinsic binding type mismatch on return value!",
8355 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8356 compatible. Issue relevant warnings when they are not.
8358 This is intended as a light check to diagnose the most obvious cases, not
8359 as a full fledged type compatibility predicate. It is the programmer's
8360 responsibility to ensure correctness of the Ada declarations in Imports,
8361 especially when binding straight to a compiler internal. */
8364 intrin_profiles_compatible_p (intrin_binding_t * inb)
8366 /* Check compatibility on return values and argument lists, each responsible
8367 for posting warnings as appropriate. Ensure use of the proper sloc for
8370 bool arglists_compatible_p, return_compatible_p;
8371 location_t saved_location = input_location;
8373 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8375 return_compatible_p = intrin_return_compatible_p (inb);
8376 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8378 input_location = saved_location;
8380 return return_compatible_p && arglists_compatible_p;
8383 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
8384 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
8385 specified size for this field. POS_LIST is a position list describing
8386 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
8390 create_field_decl_from (tree old_field, tree field_type, tree record_type,
8391 tree size, tree pos_list,
8392 vec<subst_pair> subst_list)
8394 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8395 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8396 unsigned int offset_align = tree_to_uhwi (TREE_VEC_ELT (t, 1));
8397 tree new_pos, new_field;
8401 if (CONTAINS_PLACEHOLDER_P (pos))
8402 FOR_EACH_VEC_ELT (subst_list, i, s)
8403 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
8405 /* If the position is now a constant, we can set it as the position of the
8406 field when we make it. Otherwise, we need to deal with it specially. */
8407 if (TREE_CONSTANT (pos))
8408 new_pos = bit_from_pos (pos, bitpos);
8410 new_pos = NULL_TREE;
8413 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8414 size, new_pos, DECL_PACKED (old_field),
8415 !DECL_NONADDRESSABLE_P (old_field));
8419 normalize_offset (&pos, &bitpos, offset_align);
8420 /* Finalize the position. */
8421 DECL_FIELD_OFFSET (new_field) = variable_size (pos);
8422 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8423 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8424 DECL_SIZE (new_field) = size;
8425 DECL_SIZE_UNIT (new_field)
8426 = convert (sizetype,
8427 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8428 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8431 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8432 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
8433 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8434 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8439 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
8440 it is the minimal size the REP_PART must have. */
8443 create_rep_part (tree rep_type, tree record_type, tree min_size)
8447 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
8448 min_size = NULL_TREE;
8450 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
8451 min_size, NULL_TREE, 0, 1);
8452 DECL_INTERNAL_P (field) = 1;
8457 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8460 get_rep_part (tree record_type)
8462 tree field = TYPE_FIELDS (record_type);
8464 /* The REP part is the first field, internal, another record, and its name
8465 starts with an 'R'. */
8467 && DECL_INTERNAL_P (field)
8468 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8469 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
8475 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8478 get_variant_part (tree record_type)
8482 /* The variant part is the only internal field that is a qualified union. */
8483 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
8484 if (DECL_INTERNAL_P (field)
8485 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8491 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8492 the list of variants to be used and RECORD_TYPE is the type of the parent.
8493 POS_LIST is a position list describing the layout of fields present in
8494 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8498 create_variant_part_from (tree old_variant_part,
8499 vec<variant_desc> variant_list,
8500 tree record_type, tree pos_list,
8501 vec<subst_pair> subst_list)
8503 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8504 tree old_union_type = TREE_TYPE (old_variant_part);
8505 tree new_union_type, new_variant_part;
8506 tree union_field_list = NULL_TREE;
8510 /* First create the type of the variant part from that of the old one. */
8511 new_union_type = make_node (QUAL_UNION_TYPE);
8512 TYPE_NAME (new_union_type)
8513 = concat_name (TYPE_NAME (record_type),
8514 IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
8516 /* If the position of the variant part is constant, subtract it from the
8517 size of the type of the parent to get the new size. This manual CSE
8518 reduces the code size when not optimizing. */
8519 if (TREE_CODE (offset) == INTEGER_CST)
8521 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8522 tree first_bit = bit_from_pos (offset, bitpos);
8523 TYPE_SIZE (new_union_type)
8524 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8525 TYPE_SIZE_UNIT (new_union_type)
8526 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8527 byte_from_pos (offset, bitpos));
8528 SET_TYPE_ADA_SIZE (new_union_type,
8529 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8531 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8532 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8535 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8537 /* Now finish up the new variants and populate the union type. */
8538 FOR_EACH_VEC_ELT_REVERSE (variant_list, i, v)
8540 tree old_field = v->field, new_field;
8541 tree old_variant, old_variant_subpart, new_variant, field_list;
8543 /* Skip variants that don't belong to this nesting level. */
8544 if (DECL_CONTEXT (old_field) != old_union_type)
8547 /* Retrieve the list of fields already added to the new variant. */
8548 new_variant = v->new_type;
8549 field_list = TYPE_FIELDS (new_variant);
8551 /* If the old variant had a variant subpart, we need to create a new
8552 variant subpart and add it to the field list. */
8553 old_variant = v->type;
8554 old_variant_subpart = get_variant_part (old_variant);
8555 if (old_variant_subpart)
8557 tree new_variant_subpart
8558 = create_variant_part_from (old_variant_subpart, variant_list,
8559 new_variant, pos_list, subst_list);
8560 DECL_CHAIN (new_variant_subpart) = field_list;
8561 field_list = new_variant_subpart;
8564 /* Finish up the new variant and create the field. No need for debug
8565 info thanks to the XVS type. */
8566 finish_record_type (new_variant, nreverse (field_list), 2, false);
8567 compute_record_mode (new_variant);
8568 create_type_decl (TYPE_NAME (new_variant), new_variant, true, false,
8572 = create_field_decl_from (old_field, new_variant, new_union_type,
8573 TYPE_SIZE (new_variant),
8574 pos_list, subst_list);
8575 DECL_QUALIFIER (new_field) = v->qual;
8576 DECL_INTERNAL_P (new_field) = 1;
8577 DECL_CHAIN (new_field) = union_field_list;
8578 union_field_list = new_field;
8581 /* Finish up the union type and create the variant part. No need for debug
8582 info thanks to the XVS type. Note that we don't reverse the field list
8583 because VARIANT_LIST has been traversed in reverse order. */
8584 finish_record_type (new_union_type, union_field_list, 2, false);
8585 compute_record_mode (new_union_type);
8586 create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, false,
8590 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8591 TYPE_SIZE (new_union_type),
8592 pos_list, subst_list);
8593 DECL_INTERNAL_P (new_variant_part) = 1;
8595 /* With multiple discriminants it is possible for an inner variant to be
8596 statically selected while outer ones are not; in this case, the list
8597 of fields of the inner variant is not flattened and we end up with a
8598 qualified union with a single member. Drop the useless container. */
8599 if (!DECL_CHAIN (union_field_list))
8601 DECL_CONTEXT (union_field_list) = record_type;
8602 DECL_FIELD_OFFSET (union_field_list)
8603 = DECL_FIELD_OFFSET (new_variant_part);
8604 DECL_FIELD_BIT_OFFSET (union_field_list)
8605 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8606 SET_DECL_OFFSET_ALIGN (union_field_list,
8607 DECL_OFFSET_ALIGN (new_variant_part));
8608 new_variant_part = union_field_list;
8611 return new_variant_part;
8614 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8615 which are both RECORD_TYPE, after applying the substitutions described
8619 copy_and_substitute_in_size (tree new_type, tree old_type,
8620 vec<subst_pair> subst_list)
8625 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8626 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8627 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8628 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8629 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8631 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8632 FOR_EACH_VEC_ELT (subst_list, i, s)
8633 TYPE_SIZE (new_type)
8634 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8635 s->discriminant, s->replacement);
8637 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8638 FOR_EACH_VEC_ELT (subst_list, i, s)
8639 TYPE_SIZE_UNIT (new_type)
8640 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8641 s->discriminant, s->replacement);
8643 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8644 FOR_EACH_VEC_ELT (subst_list, i, s)
8646 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8647 s->discriminant, s->replacement));
8649 /* Finalize the size. */
8650 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8651 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8654 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8655 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8656 updated by replacing F with R.
8658 The function doesn't update the layout of the type, i.e. it assumes
8659 that the substitution is purely formal. That's why the replacement
8660 value R must itself contain a PLACEHOLDER_EXPR. */
8663 substitute_in_type (tree t, tree f, tree r)
8667 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8669 switch (TREE_CODE (t))
8676 /* First the domain types of arrays. */
8677 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8678 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8680 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8681 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8683 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8687 TYPE_GCC_MIN_VALUE (nt) = low;
8688 TYPE_GCC_MAX_VALUE (nt) = high;
8690 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8692 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8697 /* Then the subtypes. */
8698 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8699 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8701 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8702 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8704 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8708 SET_TYPE_RM_MIN_VALUE (nt, low);
8709 SET_TYPE_RM_MAX_VALUE (nt, high);
8717 nt = substitute_in_type (TREE_TYPE (t), f, r);
8718 if (nt == TREE_TYPE (t))
8721 return build_complex_type (nt);
8724 /* These should never show up here. */
8729 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8730 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8732 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8735 nt = build_nonshared_array_type (component, domain);
8736 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8737 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8738 SET_TYPE_MODE (nt, TYPE_MODE (t));
8739 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8740 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8741 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8742 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8743 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8749 case QUAL_UNION_TYPE:
8751 bool changed_field = false;
8754 /* Start out with no fields, make new fields, and chain them
8755 in. If we haven't actually changed the type of any field,
8756 discard everything we've done and return the old type. */
8758 TYPE_FIELDS (nt) = NULL_TREE;
8760 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
8762 tree new_field = copy_node (field), new_n;
8764 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8765 if (new_n != TREE_TYPE (field))
8767 TREE_TYPE (new_field) = new_n;
8768 changed_field = true;
8771 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8772 if (new_n != DECL_FIELD_OFFSET (field))
8774 DECL_FIELD_OFFSET (new_field) = new_n;
8775 changed_field = true;
8778 /* Do the substitution inside the qualifier, if any. */
8779 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8781 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8782 if (new_n != DECL_QUALIFIER (field))
8784 DECL_QUALIFIER (new_field) = new_n;
8785 changed_field = true;
8789 DECL_CONTEXT (new_field) = nt;
8790 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
8792 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
8793 TYPE_FIELDS (nt) = new_field;
8799 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8800 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8801 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8802 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8811 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8812 needed to represent the object. */
8815 rm_size (tree gnu_type)
8817 /* For integral types, we store the RM size explicitly. */
8818 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8819 return TYPE_RM_SIZE (gnu_type);
8821 /* Return the RM size of the actual data plus the size of the template. */
8822 if (TREE_CODE (gnu_type) == RECORD_TYPE
8823 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8825 size_binop (PLUS_EXPR,
8826 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
8827 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8829 /* For record or union types, we store the size explicitly. */
8830 if (RECORD_OR_UNION_TYPE_P (gnu_type)
8831 && !TYPE_FAT_POINTER_P (gnu_type)
8832 && TYPE_ADA_SIZE (gnu_type))
8833 return TYPE_ADA_SIZE (gnu_type);
8835 /* For other types, this is just the size. */
8836 return TYPE_SIZE (gnu_type);
8839 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8840 fully-qualified name, possibly with type information encoding.
8841 Otherwise, return the name. */
8844 get_entity_name (Entity_Id gnat_entity)
8846 Get_Encoded_Name (gnat_entity);
8847 return get_identifier_with_length (Name_Buffer, Name_Len);
8850 /* Return an identifier representing the external name to be used for
8851 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8852 and the specified suffix. */
8855 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8857 const Entity_Kind kind = Ekind (gnat_entity);
8858 const bool has_suffix = (suffix != NULL);
8859 String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
8860 String_Pointer sp = {suffix, &temp};
8862 Get_External_Name (gnat_entity, has_suffix, sp);
8864 /* A variable using the Stdcall convention lives in a DLL. We adjust
8865 its name to use the jump table, the _imp__NAME contains the address
8866 for the NAME variable. */
8867 if ((kind == E_Variable || kind == E_Constant)
8868 && Has_Stdcall_Convention (gnat_entity))
8870 const int len = strlen (STDCALL_PREFIX) + Name_Len;
8871 char *new_name = (char *) alloca (len + 1);
8872 strcpy (new_name, STDCALL_PREFIX);
8873 strcat (new_name, Name_Buffer);
8874 return get_identifier_with_length (new_name, len);
8877 return get_identifier_with_length (Name_Buffer, Name_Len);
8880 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8881 string, return a new IDENTIFIER_NODE that is the concatenation of
8882 the name followed by "___" and the specified suffix. */
8885 concat_name (tree gnu_name, const char *suffix)
8887 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8888 char *new_name = (char *) alloca (len + 1);
8889 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8890 strcat (new_name, "___");
8891 strcat (new_name, suffix);
8892 return get_identifier_with_length (new_name, len);
8895 /* Initialize data structures of the decl.c module. */
8898 init_gnat_decl (void)
8900 /* Initialize the cache of annotated values. */
8901 annotate_value_cache
8902 = htab_create_ggc (512, tree_int_map_hash, tree_int_map_eq, 0);
8905 /* Destroy data structures of the decl.c module. */
8908 destroy_gnat_decl (void)
8910 /* Destroy the cache of annotated values. */
8911 htab_delete (annotate_value_cache);
8912 annotate_value_cache = NULL;
8915 #include "gt-ada-decl.h"