gcc: docs: Fix documentation of two hooks
[official-gcc.git] / gcc / ada / gcc-interface / decl.cc
blob5b3a3b4961b422682d87c59bd7df2b18981f6997
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2024, Free Software Foundation, Inc. *
10 * *
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/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "target.h"
30 #include "function.h"
31 #include "tree.h"
32 #include "gimple-expr.h"
33 #include "stringpool.h"
34 #include "diagnostic-core.h"
35 #include "alias.h"
36 #include "fold-const.h"
37 #include "stor-layout.h"
38 #include "tree-inline.h"
39 #include "demangle.h"
41 #include "ada.h"
42 #include "types.h"
43 #include "atree.h"
44 #include "elists.h"
45 #include "namet.h"
46 #include "nlists.h"
47 #include "repinfo.h"
48 #include "snames.h"
49 #include "uintp.h"
50 #include "urealp.h"
51 #include "fe.h"
52 #include "sinfo.h"
53 #include "einfo.h"
54 #include "ada-tree.h"
55 #include "gigi.h"
57 /* The "stdcall" convention is really supported on 32-bit x86/Windows only.
58 The following macro is a helper to avoid having to check for a Windows
59 specific attribute throughout this unit. */
61 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
62 #ifdef TARGET_64BIT
63 #define Has_Stdcall_Convention(E) \
64 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
65 #else
66 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
67 #endif
68 #else
69 #define Has_Stdcall_Convention(E) 0
70 #endif
72 #define STDCALL_PREFIX "_imp__"
74 /* Stack realignment is necessary for functions with foreign conventions when
75 the ABI doesn't mandate as much as what the compiler assumes - that is, up
76 to PREFERRED_STACK_BOUNDARY.
78 Such realignment can be requested with a dedicated function type attribute
79 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
80 characterize the situations where the attribute should be set. We rely on
81 compiler configuration settings for 'main' to decide. */
83 #ifdef MAIN_STACK_BOUNDARY
84 #define FOREIGN_FORCE_REALIGN_STACK \
85 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
86 #else
87 #define FOREIGN_FORCE_REALIGN_STACK 0
88 #endif
90 /* The largest TYPE_ARRAY_MAX_SIZE value we set on an array type.
91 It's an artibrary limit (256 MB) above which we consider that
92 the allocation is essentially unbounded. */
94 #define TYPE_ARRAY_SIZE_LIMIT (1 << 28)
96 struct incomplete
98 struct incomplete *next;
99 tree old_type;
100 Entity_Id full_type;
103 /* These variables are used to defer recursively expanding incomplete types
104 while we are processing a record, an array or a subprogram type. */
105 static int defer_incomplete_level = 0;
106 static struct incomplete *defer_incomplete_list;
108 /* This variable is used to delay expanding types coming from a limited with
109 clause and completed Taft Amendment types until the end of the spec. */
110 static struct incomplete *defer_limited_with_list;
112 typedef struct subst_pair_d {
113 tree discriminant;
114 tree replacement;
115 } subst_pair;
118 typedef struct variant_desc_d {
119 /* The type of the variant. */
120 tree type;
122 /* The associated field. */
123 tree field;
125 /* The value of the qualifier. */
126 tree qual;
128 /* The type of the variant after transformation. */
129 tree new_type;
131 /* The auxiliary data. */
132 tree aux;
133 } variant_desc;
136 /* A map used to cache the result of annotate_value. */
137 struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
139 static inline hashval_t
140 hash (tree_int_map *m)
142 return htab_hash_pointer (m->base.from);
145 static inline bool
146 equal (tree_int_map *a, tree_int_map *b)
148 return a->base.from == b->base.from;
151 static int
152 keep_cache_entry (tree_int_map *&m)
154 return ggc_marked_p (m->base.from);
158 static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
160 /* A map used to associate a dummy type with a list of subprogram entities. */
161 struct GTY((for_user)) tree_entity_vec_map
163 struct tree_map_base base;
164 vec<Entity_Id, va_gc_atomic> *to;
167 struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
169 static inline hashval_t
170 hash (tree_entity_vec_map *m)
172 return htab_hash_pointer (m->base.from);
175 static inline bool
176 equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
178 return a->base.from == b->base.from;
181 static int
182 keep_cache_entry (tree_entity_vec_map *&m)
184 return ggc_marked_p (m->base.from);
188 static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
190 static void prepend_one_attribute (struct attrib **,
191 enum attrib_type, tree, tree, Node_Id);
192 static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
193 static void prepend_attributes (struct attrib **, Entity_Id);
194 static tree elaborate_expression (Node_Id, Entity_Id, const char *, bool, bool,
195 bool);
196 static tree elaborate_expression_1 (tree, Entity_Id, const char *, bool, bool);
197 static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
198 unsigned int);
199 static tree elaborate_reference (tree, Entity_Id, bool, tree *);
200 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
201 static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
202 static int adjust_packed (tree, tree, int);
203 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
204 static enum inline_status_t inline_status_for_subprog (Entity_Id);
205 static Entity_Id Gigi_Cloned_Subtype (Entity_Id);
206 static tree gnu_ext_name_for_subprog (Entity_Id, tree);
207 static void set_nonaliased_component_on_array_type (tree);
208 static void set_reverse_storage_order_on_array_type (tree);
209 static void set_typeless_storage_on_aggregate_type (tree);
210 static void set_universal_aliasing_on_type (tree);
211 static bool same_discriminant_p (Entity_Id, Entity_Id);
212 static bool array_type_has_nonaliased_component (tree, Entity_Id);
213 static bool compile_time_known_address_p (Node_Id);
214 static bool flb_cannot_be_superflat (Node_Id);
215 static bool range_cannot_be_superflat (Node_Id);
216 static bool constructor_address_p (tree);
217 static bool allocatable_size_p (tree, bool);
218 static bool initial_value_needs_conversion (tree, tree);
219 static tree update_n_elem (tree, tree, tree);
220 static int compare_field_bitpos (const void *, const void *);
221 static bool components_to_record (Node_Id, Entity_Id, tree, tree, int, bool,
222 bool, bool, bool, bool, bool, bool, tree,
223 tree *);
224 static Uint annotate_value (tree);
225 static void annotate_rep (Entity_Id, tree);
226 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
227 static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
228 static vec<variant_desc> build_variant_list (tree, Node_Id, vec<subst_pair>,
229 vec<variant_desc>);
230 static tree maybe_saturate_size (tree, unsigned int align);
231 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool,
232 const char *, const char *);
233 static void set_rm_size (Uint, tree, Entity_Id);
234 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
235 static unsigned int promote_object_alignment (tree, tree, Entity_Id);
236 static void check_ok_for_atomic_type (tree, Entity_Id, bool);
237 static bool type_for_atomic_builtin_p (tree);
238 static tree resolve_atomic_builtin (enum built_in_function, tree);
239 static tree create_field_decl_from (tree, tree, tree, tree, tree,
240 vec<subst_pair>);
241 static tree create_rep_part (tree, tree, tree);
242 static tree get_rep_part (tree);
243 static tree create_variant_part_from (tree, vec<variant_desc>, tree,
244 tree, vec<subst_pair>, bool);
245 static void copy_and_substitute_in_size (tree, tree, vec<subst_pair>);
246 static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree,
247 vec<subst_pair>, bool);
248 static tree associate_original_type_to_packed_array (tree, Entity_Id);
249 static const char *get_entity_char (Entity_Id);
251 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
252 to pass around calls performing profile compatibility checks. */
254 typedef struct {
255 Entity_Id gnat_entity; /* The Ada subprogram entity. */
256 tree ada_fntype; /* The corresponding GCC type node. */
257 tree btin_fntype; /* The GCC builtin function type node. */
258 } intrin_binding_t;
260 static bool intrin_profiles_compatible_p (const intrin_binding_t *);
262 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
263 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
264 and associate the ..._DECL node with the input GNAT defining identifier.
266 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
267 initial value (in GCC tree form). This is optional for a variable. For
268 a renamed entity, GNU_EXPR gives the object being renamed.
270 DEFINITION is true if this call is intended for a definition. This is used
271 for separate compilation where it is necessary to know whether an external
272 declaration or a definition must be created if the GCC equivalent was not
273 created previously. */
275 tree
276 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
278 /* The construct that declared the entity. */
279 const Node_Id gnat_decl = Declaration_Node (gnat_entity);
280 /* The object that the entity renames, if any. */
281 const Entity_Id gnat_renamed_obj = Renamed_Object (gnat_entity);
282 /* The kind of the entity. */
283 const Entity_Kind kind = Ekind (gnat_entity);
284 /* True if this is a type. */
285 const bool is_type = IN (kind, Type_Kind);
286 /* True if this is an artificial entity. */
287 const bool artificial_p = !Comes_From_Source (gnat_entity);
288 /* True if debug info is requested for this entity. */
289 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
290 /* True if this entity is to be considered as imported. */
291 const bool imported_p
292 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
293 /* True if this entity has a foreign convention. */
294 const bool foreign = Has_Foreign_Convention (gnat_entity);
295 /* For a type, contains the equivalent GNAT node to be used in gigi. */
296 Entity_Id gnat_equiv_type = Empty;
297 /* For a subtype, contains the GNAT node to be used as cloned subtype. */
298 Entity_Id gnat_cloned_subtype = Empty;
299 /* Temporary used to walk the GNAT tree. */
300 Entity_Id gnat_temp;
301 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
302 This node will be associated with the GNAT node by calling at the end
303 of the `switch' statement. */
304 tree gnu_decl = NULL_TREE;
305 /* Contains the GCC type to be used for the GCC node. */
306 tree gnu_type = NULL_TREE;
307 /* Contains the GCC size tree to be used for the GCC node. */
308 tree gnu_size = NULL_TREE;
309 /* Contains the GCC name to be used for the GCC node. */
310 tree gnu_entity_name;
311 /* True if we have already saved gnu_decl as a GNAT association. This can
312 also be used to purposely avoid making such an association but this use
313 case ought not to be applied to types because it can break the deferral
314 mechanism implemented for access types. */
315 bool saved = false;
316 /* True if we incremented defer_incomplete_level. */
317 bool this_deferred = false;
318 /* True if we incremented force_global. */
319 bool this_global = false;
320 /* True if we should check to see if elaborated during processing. */
321 bool maybe_present = false;
322 /* True if we made GNU_DECL and its type here. */
323 bool this_made_decl = false;
324 /* Size and alignment of the GCC node, if meaningful. */
325 unsigned int esize = 0, align = 0;
326 /* Contains the list of attributes directly attached to the entity. */
327 struct attrib *attr_list = NULL;
329 /* Since a use of an itype is a definition, process it as such if it is in
330 the main unit, except for E_Access_Subtype because it's actually a use
331 of its base type, and for E_Class_Wide_Subtype with an Equivalent_Type
332 because it's actually a use of the latter type. */
333 if (!definition
334 && is_type
335 && Is_Itype (gnat_entity)
336 && Ekind (gnat_entity) != E_Access_Subtype
337 && !(Ekind (gnat_entity) == E_Class_Wide_Subtype
338 && Present (Equivalent_Type (gnat_entity)))
339 && !present_gnu_tree (gnat_entity)
340 && In_Extended_Main_Code_Unit (gnat_entity))
342 /* Unless it's for an anonymous access type, whose scope is irrelevant,
343 ensure that we are in a subprogram mentioned in the Scope chain of
344 this entity, our current scope is global, or we encountered a task
345 or entry (where we can't currently accurately check scoping). */
346 if (Ekind (gnat_entity) == E_Anonymous_Access_Type
347 || !current_function_decl
348 || DECL_ELABORATION_PROC_P (current_function_decl))
350 process_type (gnat_entity);
351 return get_gnu_tree (gnat_entity);
354 for (gnat_temp = Scope (gnat_entity);
355 Present (gnat_temp);
356 gnat_temp = Scope (gnat_temp))
358 if (Is_Type (gnat_temp))
359 gnat_temp = Underlying_Type (gnat_temp);
361 if (Is_Subprogram (gnat_temp)
362 && Present (Protected_Body_Subprogram (gnat_temp)))
363 gnat_temp = Protected_Body_Subprogram (gnat_temp);
365 if (Ekind (gnat_temp) == E_Entry
366 || Ekind (gnat_temp) == E_Entry_Family
367 || Ekind (gnat_temp) == E_Task_Type
368 || (Is_Subprogram (gnat_temp)
369 && present_gnu_tree (gnat_temp)
370 && (current_function_decl
371 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))))
373 process_type (gnat_entity);
374 return get_gnu_tree (gnat_entity);
378 /* This abort means the itype has an incorrect scope, i.e. that its
379 scope does not correspond to the subprogram it is first used in. */
380 gcc_unreachable ();
383 /* If we've already processed this entity, return what we got last time.
384 If we are defining the node, we should not have already processed it.
385 In that case, we will abort below when we try to save a new GCC tree
386 for this object. We also need to handle the case of getting a dummy
387 type when a Full_View exists but be careful so as not to trigger its
388 premature elaboration. Likewise for a cloned subtype without its own
389 freeze node, which typically happens when a generic gets instantiated
390 on an incomplete or private type. */
391 if ((!definition || (is_type && imported_p))
392 && present_gnu_tree (gnat_entity))
394 gnu_decl = get_gnu_tree (gnat_entity);
396 if (TREE_CODE (gnu_decl) == TYPE_DECL
397 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
398 && IN (kind, Incomplete_Or_Private_Kind)
399 && Present (Full_View (gnat_entity))
400 && (present_gnu_tree (Full_View (gnat_entity))
401 || No (Freeze_Node (Full_View (gnat_entity)))))
403 gnu_decl
404 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE,
405 false);
406 save_gnu_tree (gnat_entity, NULL_TREE, false);
407 save_gnu_tree (gnat_entity, gnu_decl, false);
410 if (TREE_CODE (gnu_decl) == TYPE_DECL
411 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
412 && Ekind (gnat_entity) == E_Record_Subtype
413 && No (Freeze_Node (gnat_entity))
414 && Present (Cloned_Subtype (gnat_entity))
415 && (present_gnu_tree (Cloned_Subtype (gnat_entity))
416 || No (Freeze_Node (Cloned_Subtype (gnat_entity)))))
418 gnu_decl
419 = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), NULL_TREE,
420 false);
421 save_gnu_tree (gnat_entity, NULL_TREE, false);
422 save_gnu_tree (gnat_entity, gnu_decl, false);
425 return gnu_decl;
428 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
429 must be specified unless it was specified by the programmer. Exceptions
430 are for access-to-protected-subprogram types and all access subtypes, as
431 another GNAT type is used to lay out the GCC type for them, as well as
432 access-to-subprogram types if front-end unnesting is enabled. */
433 gcc_assert (!is_type
434 || Known_Esize (gnat_entity)
435 || Has_Size_Clause (gnat_entity)
436 || (!Is_In_Numeric_Kind (kind)
437 && !IN (kind, Enumeration_Kind)
438 && (!IN (kind, Access_Kind)
439 || kind == E_Access_Protected_Subprogram_Type
440 || kind == E_Anonymous_Access_Protected_Subprogram_Type
441 || ((kind == E_Access_Subprogram_Type
442 || kind == E_Anonymous_Access_Subprogram_Type)
443 && Unnest_Subprogram_Mode)
444 || kind == E_Access_Subtype
445 || type_annotate_only)));
447 /* The RM size must be specified for all discrete and fixed-point types. */
448 gcc_assert (!(Is_In_Discrete_Or_Fixed_Point_Kind (kind)
449 && !Known_RM_Size (gnat_entity)));
451 /* If we get here, it means we have not yet done anything with this entity.
452 If we are not defining it, it must be a type or an entity that is defined
453 elsewhere or externally, otherwise we should have defined it already.
455 In other words, the failure of this assertion typically arises when a
456 reference to an entity (type or object) is made before its declaration,
457 either directly or by means of a freeze node which is incorrectly placed.
458 This can also happen for an entity referenced out of context, for example
459 a parameter outside of the subprogram where it is declared. GNAT_ENTITY
460 is the N_Defining_Identifier of the entity, the problematic N_Identifier
461 being the argument passed to Identifier_to_gnu in the parent frame.
463 One exception is for an entity, typically an inherited operation, which is
464 a local alias for the parent's operation. It is neither defined, since it
465 is an inherited operation, nor public, since it is declared in the current
466 compilation unit, so we test Is_Public on the Alias entity instead. */
467 gcc_assert (definition
468 || is_type
469 || kind == E_Discriminant
470 || kind == E_Component
471 || kind == E_Label
472 || (kind == E_Constant && Present (Full_View (gnat_entity)))
473 || Is_Public (gnat_entity)
474 || (Present (Alias (gnat_entity))
475 && Is_Public (Alias (gnat_entity)))
476 || type_annotate_only);
478 /* Get the name of the entity and set up the line number and filename of
479 the original definition for use in any decl we make. Make sure we do
480 not inherit another source location. */
481 gnu_entity_name = get_entity_name (gnat_entity);
482 if (!renaming_from_instantiation_p (gnat_entity))
483 Sloc_to_locus (Sloc (gnat_entity), &input_location);
485 /* For cases when we are not defining (i.e., we are referencing from
486 another compilation unit) public entities, show we are at global level
487 for the purpose of computing scopes. Don't do this for components or
488 discriminants since the relevant test is whether or not the record is
489 being defined. */
490 if (!definition
491 && kind != E_Component
492 && kind != E_Discriminant
493 && Is_Public (gnat_entity)
494 && !Is_Statically_Allocated (gnat_entity))
495 force_global++, this_global = true;
497 /* Handle any attributes directly attached to the entity. */
498 if (Has_Gigi_Rep_Item (gnat_entity))
499 prepend_attributes (&attr_list, gnat_entity);
501 /* Do some common processing for types. */
502 if (is_type)
504 /* Compute the equivalent type to be used in gigi. */
505 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
507 /* Machine_Attributes on types are expected to be propagated to
508 subtypes. The corresponding Gigi_Rep_Items are only attached
509 to the first subtype though, so we handle the propagation here. */
510 if (!Is_Base_Type (gnat_entity)
511 && !Is_First_Subtype (gnat_entity)
512 && Has_Gigi_Rep_Item (First_Subtype (gnat_entity)))
513 prepend_attributes (&attr_list, First_Subtype (gnat_entity));
515 /* Compute a default value for the size of an elementary type. */
516 if (Known_Esize (gnat_entity) && Is_Elementary_Type (gnat_entity))
518 unsigned int max_esize;
520 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity)));
521 esize = UI_To_Int (Esize (gnat_entity));
523 if (IN (kind, Float_Kind))
524 max_esize
525 = fp_prec_to_size (TYPE_PRECISION (long_double_type_node));
526 else if (IN (kind, Access_Kind))
527 max_esize = POINTER_SIZE * 2;
528 else
529 max_esize = Enable_128bit_Types ? 128 : LONG_LONG_TYPE_SIZE;
531 if (esize > max_esize)
532 esize = max_esize;
536 switch (kind)
538 case E_Component:
539 case E_Discriminant:
541 /* The GNAT record where the component was defined. */
542 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
544 /* If the entity is a discriminant of an extended tagged type used to
545 rename a discriminant of the parent type, return the latter. */
546 if (kind == E_Discriminant
547 && Present (Corresponding_Discriminant (gnat_entity))
548 && Is_Tagged_Type (gnat_record))
550 gnu_decl
551 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
552 gnu_expr, definition);
553 saved = true;
554 break;
557 /* If the entity is an inherited component (in the case of extended
558 tagged record types), just return the original entity, which must
559 be a FIELD_DECL. Likewise for discriminants. If the entity is a
560 non-stored discriminant (in the case of derived untagged record
561 types), return the stored discriminant it renames. */
562 if (Present (Original_Record_Component (gnat_entity))
563 && Original_Record_Component (gnat_entity) != gnat_entity)
565 gnu_decl
566 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
567 gnu_expr, definition);
568 /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */
569 if (kind == E_Discriminant)
570 saved = true;
571 break;
574 /* Otherwise, if we are not defining this and we have no GCC type
575 for the containing record, make one for it. Then we should
576 have made our own equivalent. */
577 if (!definition && !present_gnu_tree (gnat_record))
579 /* ??? If this is in a record whose scope is a protected
580 type and we have an Original_Record_Component, use it.
581 This is a workaround for major problems in protected type
582 handling. */
583 Entity_Id Scop = Scope (Scope (gnat_entity));
584 if (Is_Protected_Type (Underlying_Type (Scop))
585 && Present (Original_Record_Component (gnat_entity)))
587 gnu_decl
588 = gnat_to_gnu_entity (Original_Record_Component
589 (gnat_entity),
590 gnu_expr, false);
592 else
594 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, false);
595 gnu_decl = get_gnu_tree (gnat_entity);
598 saved = true;
599 break;
602 /* Here we have no GCC type and this is a reference rather than a
603 definition. This should never happen. Most likely the cause is
604 reference before declaration in the GNAT tree for gnat_entity. */
605 gcc_unreachable ();
608 case E_Named_Integer:
609 case E_Named_Real:
611 tree gnu_ext_name = NULL_TREE;
613 if (Is_Public (gnat_entity))
614 gnu_ext_name = create_concat_name (gnat_entity, NULL);
616 /* All references are supposed to be folded in the front-end. */
617 gcc_assert (definition && gnu_expr);
619 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
620 gnu_expr = convert (gnu_type, gnu_expr);
622 /* Build a CONST_DECL for debugging purposes exclusively. */
623 gnu_decl
624 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
625 gnu_expr, true, Is_Public (gnat_entity),
626 false, false, false, artificial_p,
627 debug_info_p, NULL, gnat_entity);
629 break;
631 case E_Constant:
632 /* Ignore constant definitions already marked with the error node. See
633 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
634 if (definition
635 && present_gnu_tree (gnat_entity)
636 && get_gnu_tree (gnat_entity) == error_mark_node)
638 maybe_present = true;
639 break;
642 /* Ignore deferred constant definitions without address clause since
643 they are processed fully in the front-end. If No_Initialization
644 is set, this is not a deferred constant but a constant whose value
645 is built manually. And constants that are renamings are handled
646 like variables. */
647 if (definition
648 && !gnu_expr
649 && !No_Initialization (gnat_decl)
650 && No (Address_Clause (gnat_entity))
651 && No (gnat_renamed_obj))
653 gnu_decl = error_mark_node;
654 saved = true;
655 break;
658 /* If this is a use of a deferred constant without address clause,
659 get its full definition. */
660 if (!definition
661 && No (Address_Clause (gnat_entity))
662 && Present (Full_View (gnat_entity)))
664 gnu_decl
665 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, false);
666 saved = true;
667 break;
670 /* If we have a constant that we are not defining, get the expression it
671 was defined to represent. This is necessary to avoid generating dumb
672 elaboration code in simple cases, and we may throw it away later if it
673 is not a constant. But do not do it for dispatch tables because they
674 are only referenced indirectly and we need to have a consistent view
675 of the exported and of the imported declarations of the tables from
676 external units for them to be properly merged in LTO mode. Moreover
677 simply do not retrieve the expression if it is an allocator because
678 the designated type might still be dummy at this point. Note that we
679 invoke gnat_to_gnu_external and not gnat_to_gnu because the expression
680 may contain N_Expression_With_Actions nodes and thus declarations of
681 objects from other units that we need to discard. Note also that we
682 need to do it even if we are only annotating types, so as to be able
683 to validate representation clauses using constants. */
684 if (!definition
685 && !No_Initialization (gnat_decl)
686 && !Is_Dispatch_Table_Entity (gnat_entity)
687 && Present (gnat_temp = Expression (gnat_decl))
688 && Nkind (gnat_temp) != N_Allocator
689 && (Is_Elementary_Type (Etype (gnat_entity)) || !type_annotate_only))
690 gnu_expr = gnat_to_gnu_external (gnat_temp);
692 /* ... fall through ... */
694 case E_Exception:
695 case E_Loop_Parameter:
696 case E_Out_Parameter:
697 case E_Variable:
699 const Entity_Id gnat_type = Etype (gnat_entity);
700 const Entity_Id gnat_und_type = Underlying_Type (gnat_type);
701 /* Always create a variable for volatile objects and variables seen
702 constant but with a Linker_Section pragma. */
703 bool const_flag
704 = ((kind == E_Constant || kind == E_Variable)
705 && Is_True_Constant (gnat_entity)
706 && !(kind == E_Variable
707 && Present (Linker_Section_Pragma (gnat_entity)))
708 && !Treat_As_Volatile (gnat_entity)
709 && (((Nkind (gnat_decl) == N_Object_Declaration)
710 && Present (Expression (gnat_decl)))
711 || Present (gnat_renamed_obj)
712 || imported_p));
713 bool inner_const_flag = const_flag;
714 bool static_flag = Is_Statically_Allocated (gnat_entity);
715 /* We implement RM 13.3(19) for exported and imported (non-constant)
716 objects by making them volatile. */
717 bool volatile_flag
718 = (Treat_As_Volatile (gnat_entity)
719 || (!const_flag && (Is_Exported (gnat_entity) || imported_p)));
720 bool mutable_p = false;
721 bool used_by_ref = false;
722 tree gnu_ext_name = NULL_TREE;
723 tree gnu_ada_size = NULL_TREE;
725 /* We need to translate the renamed object even though we are only
726 referencing the renaming. But it may contain a call for which
727 we'll generate a temporary to hold the return value and which
728 is part of the definition of the renaming, so discard it. */
729 if (Present (gnat_renamed_obj) && !definition)
731 if (kind == E_Exception)
732 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
733 NULL_TREE, false);
734 else
735 gnu_expr = gnat_to_gnu_external (gnat_renamed_obj);
738 /* Get the type after elaborating the renamed object. */
739 if (foreign && Is_Descendant_Of_Address (gnat_und_type))
740 gnu_type = ptr_type_node;
741 else
742 gnu_type = gnat_to_gnu_type (gnat_type);
744 /* For a debug renaming declaration, build a debug-only entity. */
745 if (Present (Debug_Renaming_Link (gnat_entity)))
747 /* Force a non-null value to make sure the symbol is retained. */
748 tree value = build1 (INDIRECT_REF, gnu_type,
749 build1 (NOP_EXPR,
750 build_pointer_type (gnu_type),
751 integer_minus_one_node));
752 gnu_decl = build_decl (input_location,
753 VAR_DECL, gnu_entity_name, gnu_type);
754 SET_DECL_VALUE_EXPR (gnu_decl, value);
755 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
756 TREE_STATIC (gnu_decl) = global_bindings_p ();
757 gnat_pushdecl (gnu_decl, gnat_entity);
758 break;
761 /* If this is a loop variable, its type should be the base type.
762 This is because the code for processing a loop determines whether
763 a normal loop end test can be done by comparing the bounds of the
764 loop against those of the base type, which is presumed to be the
765 size used for computation. But this is not correct when the size
766 of the subtype is smaller than the type. */
767 if (kind == E_Loop_Parameter)
768 gnu_type = get_base_type (gnu_type);
770 /* If this is a simple constant, strip the qualifiers from its type,
771 since the constant represents only its value. */
772 else if (simple_constant_p (gnat_entity))
773 gnu_type = TYPE_MAIN_VARIANT (gnu_type);
775 /* Reject non-renamed objects whose type is an unconstrained array or
776 any object whose type is a dummy type or void. */
777 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
778 && No (gnat_renamed_obj))
779 || TYPE_IS_DUMMY_P (gnu_type)
780 || VOID_TYPE_P (gnu_type))
782 gcc_assert (type_annotate_only);
783 if (this_global)
784 force_global--;
785 return error_mark_node;
788 /* If an alignment is specified, use it if valid. Note that exceptions
789 are objects but don't have an alignment and there is also no point in
790 setting it for an address clause, since the final type of the object
791 will be a reference type. */
792 if (Known_Alignment (gnat_entity)
793 && kind != E_Exception
794 && No (Address_Clause (gnat_entity)))
795 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
796 TYPE_ALIGN (gnu_type));
798 /* Likewise, if a size is specified, use it if valid. */
799 if (Known_Esize (gnat_entity))
800 gnu_size
801 = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
802 VAR_DECL, false, Has_Size_Clause (gnat_entity),
803 NULL, NULL);
804 if (gnu_size)
806 gnu_type
807 = make_type_from_size (gnu_type, gnu_size,
808 Has_Biased_Representation (gnat_entity));
810 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
811 gnu_size = NULL_TREE;
814 /* If this object has self-referential size, it must be a record with
815 a default discriminant. We are supposed to allocate an object of
816 the maximum size in this case, unless it is a constant with an
817 initializing expression, in which case we can get the size from
818 that. Note that the resulting size may still be a variable, so
819 this may end up with an indirect allocation. */
820 if (No (gnat_renamed_obj)
821 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
823 if (gnu_expr && kind == E_Constant)
825 gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
826 gnu_ada_size = TYPE_ADA_SIZE (TREE_TYPE (gnu_expr));
827 if (CONTAINS_PLACEHOLDER_P (gnu_size))
829 /* If the initializing expression is itself a constant,
830 despite having a nominal type with self-referential
831 size, we can get the size directly from it. */
832 if (TREE_CODE (gnu_expr) == COMPONENT_REF
833 && TYPE_IS_PADDING_P
834 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
835 && VAR_P (TREE_OPERAND (gnu_expr, 0))
836 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
837 || DECL_READONLY_ONCE_ELAB
838 (TREE_OPERAND (gnu_expr, 0))))
840 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
841 gnu_ada_size = gnu_size;
843 else
845 gnu_size
846 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size,
847 gnu_expr);
848 gnu_ada_size
849 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_ada_size,
850 gnu_expr);
854 /* We may have no GNU_EXPR because No_Initialization is
855 set even though there's an Expression. */
856 else if (kind == E_Constant
857 && Nkind (gnat_decl) == N_Object_Declaration
858 && Present (Expression (gnat_decl)))
860 tree gnu_expr_type
861 = gnat_to_gnu_type (Etype (Expression (gnat_decl)));
862 gnu_size = TYPE_SIZE (gnu_expr_type);
863 gnu_ada_size = TYPE_ADA_SIZE (gnu_expr_type);
865 else
867 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
868 /* We can be called on unconstrained arrays in this mode. */
869 if (!type_annotate_only)
870 gnu_ada_size = max_size (TYPE_ADA_SIZE (gnu_type), true);
871 mutable_p = true;
874 /* If the size isn't constant and we are at global level, call
875 elaborate_expression_1 to make a variable for it rather than
876 calculating it each time. */
877 if (!TREE_CONSTANT (gnu_size) && global_bindings_p ())
878 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
879 "SIZE", definition, false);
882 /* If the size is zero byte, make it one byte since some linkers have
883 troubles with zero-sized objects. If the object will have a
884 template, that will make it nonzero so don't bother. Also avoid
885 doing that for an object renaming or an object with an address
886 clause, as we would lose useful information on the view size
887 (e.g. for null array slices) and we are not allocating the object
888 here anyway. */
889 if (((gnu_size
890 && integer_zerop (gnu_size)
891 && !TREE_OVERFLOW (gnu_size))
892 || (TYPE_SIZE (gnu_type)
893 && integer_zerop (TYPE_SIZE (gnu_type))
894 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
895 && !Is_Constr_Array_Subt_With_Bounds (gnat_type)
896 && No (gnat_renamed_obj)
897 && No (Address_Clause (gnat_entity)))
898 gnu_size = bitsize_unit_node;
900 /* If this is an object with no specified size and alignment, and
901 if either it is full access or we are not optimizing alignment for
902 space and it is composite and not an exception, an Out parameter
903 or a reference to another object, and the size of its type is a
904 constant, set the alignment to the smallest one which is not
905 smaller than the size, with an appropriate cap. */
906 if (!Known_Esize (gnat_entity)
907 && !Known_Alignment (gnat_entity)
908 && (Is_Full_Access (gnat_entity)
909 || (!Optimize_Alignment_Space (gnat_entity)
910 && kind != E_Exception
911 && kind != E_Out_Parameter
912 && Is_Composite_Type (gnat_type)
913 && !Is_Constr_Array_Subt_With_Bounds (gnat_type)
914 && !Is_Exported (gnat_entity)
915 && !imported_p
916 && No (gnat_renamed_obj)
917 && No (Address_Clause (gnat_entity))))
918 && (TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST || gnu_size))
919 align = promote_object_alignment (gnu_type, gnu_size, gnat_entity);
921 /* If the object is set to have atomic components, find the component
922 type and validate it.
924 ??? Note that we ignore Has_Volatile_Components on objects; it's
925 not at all clear what to do in that case. */
926 if (Has_Atomic_Components (gnat_entity))
928 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
929 ? TREE_TYPE (gnu_type) : gnu_type);
931 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
932 && TYPE_MULTI_ARRAY_P (gnu_inner))
933 gnu_inner = TREE_TYPE (gnu_inner);
935 check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
938 /* If this is an array allocated with its bounds, make a type that
939 includes the template. We will either allocate it or create a
940 variable of that type, see below. */
941 if (Is_Constr_Array_Subt_With_Bounds (gnat_type)
942 && !type_annotate_only)
944 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
945 /* Make sure to have an array type for the template. */
946 if (TYPE_IS_PADDING_P (gnu_type))
947 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
948 gnu_type
949 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
950 gnu_type,
951 concat_name (gnu_entity_name,
952 "UNC"),
953 debug_info_p);
956 /* ??? If this is an object of CW type initialized to a value, try to
957 ensure that the object is sufficient aligned for this value, but
958 without pessimizing the allocation. This is a kludge necessary
959 because we don't support dynamic alignment. */
960 if (align == 0
961 && Ekind (gnat_type) == E_Class_Wide_Subtype
962 && No (gnat_renamed_obj)
963 && No (Address_Clause (gnat_entity)))
964 align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
966 #ifdef MINIMUM_ATOMIC_ALIGNMENT
967 /* If the size is a constant and no alignment is specified, force
968 the alignment to be the minimum valid atomic alignment. The
969 restriction on constant size avoids problems with variable-size
970 temporaries; if the size is variable, there's no issue with
971 atomic access. Also don't do this for a constant, since it isn't
972 necessary and can interfere with constant replacement. Finally,
973 do not do it for Out parameters since that creates an
974 size inconsistency with In parameters. */
975 if (align == 0
976 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
977 && !FLOAT_TYPE_P (gnu_type)
978 && !const_flag && No (gnat_renamed_obj)
979 && !imported_p && No (Address_Clause (gnat_entity))
980 && kind != E_Out_Parameter
981 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
982 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
983 align = MINIMUM_ATOMIC_ALIGNMENT;
984 #endif
986 /* Do not take into account aliased adjustments or alignment promotions
987 to compute the size of the object. */
988 tree gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
990 /* If the object is aliased, of a constrained nominal subtype and its
991 size might be zero at run time, we force at least the unit size. */
992 if (Is_Aliased (gnat_entity)
993 && Is_Constrained (gnat_type)
994 && !Is_Constr_Array_Subt_With_Bounds (gnat_type)
995 && Is_Array_Type (gnat_und_type)
996 && !TREE_CONSTANT (gnu_object_size))
997 gnu_size = size_binop (MAX_EXPR, gnu_object_size, bitsize_unit_node);
999 /* Make a new type with the desired size and alignment, if needed. */
1000 if (gnu_size || align > 0)
1002 tree orig_type = gnu_type;
1004 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
1005 false, definition, true);
1007 /* If the nominal subtype of the object is unconstrained and its
1008 size is not fixed, compute the Ada size from the Ada size of
1009 the subtype and/or the expression; this will make it possible
1010 for gnat_type_max_size to easily compute a maximum size. */
1011 if (gnu_ada_size && gnu_size && !TREE_CONSTANT (gnu_size))
1012 SET_TYPE_ADA_SIZE (gnu_type, gnu_ada_size);
1014 /* If a padding record was made, declare it now since it will
1015 never be declared otherwise. This is necessary to ensure
1016 that its subtrees are properly marked. */
1017 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
1018 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
1019 debug_info_p, gnat_entity);
1022 /* Now check if the type of the object allows atomic access. */
1023 if (Is_Full_Access (gnat_entity))
1024 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
1026 /* If this is a renaming, avoid as much as possible to create a new
1027 object. However, in some cases, creating it is required because
1028 renaming can be applied to objects that are not names in Ada.
1029 This processing needs to be applied to the raw expression so as
1030 to make it more likely to rename the underlying object. */
1031 if (Present (gnat_renamed_obj))
1033 /* If the renamed object had padding, strip off the reference to
1034 the inner object and reset our type. */
1035 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
1036 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
1037 /* Strip useless conversions around the object. */
1038 || gnat_useless_type_conversion (gnu_expr))
1040 gnu_expr = TREE_OPERAND (gnu_expr, 0);
1041 gnu_type = TREE_TYPE (gnu_expr);
1044 /* Or else, if the renamed object has an unconstrained type with
1045 default discriminant, use the padded type. */
1046 else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
1047 gnu_type = TREE_TYPE (gnu_expr);
1049 /* If this is a constant renaming stemming from a function call,
1050 treat it as a normal object whose initial value is what is being
1051 renamed. RM 3.3 says that the result of evaluating a function
1052 call is a constant object. Therefore, it can be the inner
1053 object of a constant renaming and the renaming must be fully
1054 instantiated, i.e. it cannot be a reference to (part of) an
1055 existing object. And treat other rvalues the same way. */
1056 tree inner = gnu_expr;
1057 while (handled_component_p (inner) || CONVERT_EXPR_P (inner))
1058 inner = TREE_OPERAND (inner, 0);
1059 /* Expand_Dispatching_Call can prepend a comparison of the tags
1060 before the call to "=". */
1061 if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
1062 || TREE_CODE (inner) == COMPOUND_EXPR)
1063 inner = TREE_OPERAND (inner, 1);
1064 if ((TREE_CODE (inner) == CALL_EXPR
1065 && !call_is_atomic_load (inner))
1066 || TREE_CODE (inner) == CONSTRUCTOR
1067 || CONSTANT_CLASS_P (inner)
1068 || COMPARISON_CLASS_P (inner)
1069 || BINARY_CLASS_P (inner)
1070 || EXPRESSION_CLASS_P (inner)
1071 /* We need to detect the case where a temporary is created to
1072 hold the return value, since we cannot safely rename it at
1073 top level because it lives only in the elaboration routine.
1074 But, at a lower level, an object initialized by a function
1075 call may be (implicitly) renamed as this temporary by the
1076 front-end and, in this case, we cannot make a copy. */
1077 || (VAR_P (inner)
1078 && DECL_RETURN_VALUE_P (inner)
1079 && global_bindings_p ())
1080 /* We also need to detect the case where the front-end creates
1081 a dangling 'reference to a function call at top level and
1082 substitutes it in the renaming, for example:
1084 q__b : boolean renames r__f.e (1);
1086 can be rewritten into:
1088 q__R1s : constant q__A2s := r__f'reference;
1089 [...]
1090 q__b : boolean renames q__R1s.all.e (1);
1092 We cannot safely rename the rewritten expression since the
1093 underlying object lives only in the elaboration routine but,
1094 as above, this cannot be done at a lower level. */
1095 || (INDIRECT_REF_P (inner)
1096 && (inner
1097 = remove_conversions (TREE_OPERAND (inner, 0), true))
1098 && VAR_P (inner)
1099 && DECL_RETURN_VALUE_P (inner)
1100 && global_bindings_p ()))
1103 /* Otherwise, this is an lvalue being renamed, so it needs to be
1104 elaborated as a reference and substituted for the entity. But
1105 this means that we must evaluate the address of the renaming
1106 in the definition case to instantiate the SAVE_EXPRs. */
1107 else
1109 tree gnu_init = NULL_TREE;
1111 if (type_annotate_only && TREE_CODE (gnu_expr) == ERROR_MARK)
1112 break;
1114 gnu_expr
1115 = elaborate_reference (gnu_expr, gnat_entity, definition,
1116 &gnu_init);
1118 /* No DECL_EXPR might be created so the expression needs to be
1119 marked manually because it will likely be shared. */
1120 if (global_bindings_p ())
1121 MARK_VISITED (gnu_expr);
1123 /* This assertion will fail if the renamed object isn't aligned
1124 enough as to make it possible to honor the alignment set on
1125 the renaming. */
1126 if (align)
1128 const unsigned int ralign
1129 = DECL_P (gnu_expr)
1130 ? DECL_ALIGN (gnu_expr)
1131 : TYPE_ALIGN (TREE_TYPE (gnu_expr));
1132 gcc_assert (ralign >= align);
1135 /* The expression might not be a DECL so save it manually. */
1136 gnu_decl = gnu_expr;
1137 save_gnu_tree (gnat_entity, gnu_decl, true);
1138 saved = true;
1139 annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
1141 /* If this is only a reference to the entity, we are done. */
1142 if (!definition)
1143 break;
1145 /* Otherwise, emit the initialization statement, if any. */
1146 if (gnu_init)
1147 add_stmt (gnu_init);
1149 /* If it needs to be materialized for debugging purposes, build
1150 the entity as indirect reference to the renamed object. */
1151 if (Materialize_Entity (gnat_entity))
1153 /* If this is an array allocated with its bounds, we make
1154 its type a thin reference, the reference counterpart of
1155 a thin pointer, exactly as we would have done in the
1156 non-renaming case below. */
1157 if (Is_Constr_Array_Subt_With_Bounds (gnat_type)
1158 && !type_annotate_only)
1160 tree gnu_array
1161 = gnat_to_gnu_type (Base_Type (gnat_type));
1162 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_array);
1164 gnu_type = build_reference_type (gnu_type);
1165 const_flag = true;
1166 volatile_flag = false;
1168 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
1170 create_var_decl (gnu_entity_name, NULL_TREE,
1171 TREE_TYPE (gnu_expr), gnu_expr,
1172 const_flag, Is_Public (gnat_entity),
1173 imported_p, static_flag, volatile_flag,
1174 artificial_p, debug_info_p, attr_list,
1175 gnat_entity, false);
1178 /* Otherwise, instantiate the SAVE_EXPRs if needed. */
1179 else if (TREE_SIDE_EFFECTS (gnu_expr))
1180 add_stmt (build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr));
1182 break;
1186 /* If we are defining an aliased object whose nominal subtype is
1187 unconstrained, the object is a record that contains both the
1188 template and the object. If there is an initializer, it will
1189 have already been converted to the right type, but we need to
1190 create the template if there is no initializer. */
1191 if (definition
1192 && !gnu_expr
1193 && TREE_CODE (gnu_type) == RECORD_TYPE
1194 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1195 /* Beware that padding might have been introduced above. */
1196 || (TYPE_PADDING_P (gnu_type)
1197 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1198 == RECORD_TYPE
1199 && TYPE_CONTAINS_TEMPLATE_P
1200 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1202 tree template_field
1203 = TYPE_PADDING_P (gnu_type)
1204 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1205 : TYPE_FIELDS (gnu_type);
1206 vec<constructor_elt, va_gc> *v;
1207 vec_alloc (v, 1);
1208 tree t = build_template (TREE_TYPE (template_field),
1209 TREE_TYPE (DECL_CHAIN (template_field)),
1210 NULL_TREE);
1211 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1212 gnu_expr = gnat_build_constructor (gnu_type, v);
1215 /* Convert the expression to the type of the object if need be. */
1216 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1217 gnu_expr = convert (gnu_type, gnu_expr);
1219 /* If this is a pointer that doesn't have an initializing expression,
1220 initialize it to NULL, unless the object is declared imported as
1221 per RM B.1(24). */
1222 if (definition
1223 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1224 && !gnu_expr
1225 && !Is_Imported (gnat_entity))
1226 gnu_expr = null_pointer_node;
1228 /* If we are defining the object and it has an Address clause, we must
1229 either get the address expression from the saved GCC tree for the
1230 object if it has a Freeze node, or elaborate the address expression
1231 here since the front-end has guaranteed that the elaboration has no
1232 effects in this case. */
1233 if (definition && Present (Address_Clause (gnat_entity)))
1235 const Node_Id gnat_clause = Address_Clause (gnat_entity);
1236 const Node_Id gnat_address = Expression (gnat_clause);
1237 tree gnu_address = present_gnu_tree (gnat_entity)
1238 ? TREE_OPERAND (get_gnu_tree (gnat_entity), 0)
1239 : gnat_to_gnu (gnat_address);
1241 save_gnu_tree (gnat_entity, NULL_TREE, false);
1243 /* Convert the type of the object to a reference type that can
1244 alias everything as per RM 13.3(19). */
1245 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1246 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1247 gnu_type
1248 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1249 gnu_address = convert (gnu_type, gnu_address);
1250 used_by_ref = true;
1251 const_flag
1252 = (!Is_Public (gnat_entity)
1253 || compile_time_known_address_p (gnat_address));
1254 volatile_flag = false;
1255 gnu_size = NULL_TREE;
1257 /* If this is an aliased object with an unconstrained array nominal
1258 subtype, then it can overlay only another aliased object with an
1259 unconstrained array nominal subtype and compatible template. */
1260 if (Is_Constr_Array_Subt_With_Bounds (gnat_type)
1261 && !type_annotate_only)
1263 tree rec_type = TREE_TYPE (gnu_type);
1264 tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
1266 /* This is the pattern built for a regular object. */
1267 if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1268 && TREE_OPERAND (gnu_address, 1) == off)
1269 gnu_address = TREE_OPERAND (gnu_address, 0);
1271 /* This is the pattern built for an overaligned object. */
1272 else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1273 && TREE_CODE (TREE_OPERAND (gnu_address, 1))
1274 == PLUS_EXPR
1275 && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
1276 == off)
1277 gnu_address
1278 = build2 (POINTER_PLUS_EXPR, gnu_type,
1279 TREE_OPERAND (gnu_address, 0),
1280 TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
1282 /* We make an exception for an absolute address but we warn
1283 that there is a descriptor at the start of the object. */
1284 else if (TREE_CODE (gnu_address) == INTEGER_CST)
1286 post_error_ne ("??aliased object& with unconstrained "
1287 "array nominal subtype", gnat_clause,
1288 gnat_entity);
1289 post_error ("\\starts with a descriptor whose size is "
1290 "given by ''Descriptor_Size", gnat_clause);
1293 else
1295 post_error_ne ("aliased object& with unconstrained array "
1296 "nominal subtype", gnat_clause,
1297 gnat_entity);
1298 post_error ("\\can overlay only aliased object with "
1299 "compatible subtype", gnat_clause);
1303 /* If we don't have an initializing expression for the underlying
1304 variable, the initializing expression for the pointer is the
1305 specified address. Otherwise, we have to make a COMPOUND_EXPR
1306 to assign both the address and the initial value. */
1307 if (!gnu_expr)
1308 gnu_expr = gnu_address;
1309 else
1310 gnu_expr
1311 = build2 (COMPOUND_EXPR, gnu_type,
1312 build_binary_op (INIT_EXPR, NULL_TREE,
1313 build_unary_op (INDIRECT_REF,
1314 NULL_TREE,
1315 gnu_address),
1316 gnu_expr),
1317 gnu_address);
1320 /* If it has an address clause and we are not defining it, mark it
1321 as an indirect object. Likewise for Stdcall objects that are
1322 imported. */
1323 if ((!definition && Present (Address_Clause (gnat_entity)))
1324 || (imported_p && Has_Stdcall_Convention (gnat_entity)))
1326 /* Convert the type of the object to a reference type that can
1327 alias everything as per RM 13.3(19). */
1328 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1329 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1330 gnu_type
1331 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1332 used_by_ref = true;
1333 const_flag = false;
1334 volatile_flag = false;
1335 gnu_size = NULL_TREE;
1337 /* No point in taking the address of an initializing expression
1338 that isn't going to be used. */
1339 gnu_expr = NULL_TREE;
1341 /* If it has an address clause whose value is known at compile
1342 time, make the object a CONST_DECL. This will avoid a
1343 useless dereference. */
1344 if (Present (Address_Clause (gnat_entity)))
1346 Node_Id gnat_address
1347 = Expression (Address_Clause (gnat_entity));
1349 if (compile_time_known_address_p (gnat_address))
1351 gnu_expr = gnat_to_gnu (gnat_address);
1352 const_flag = true;
1357 /* If we are at top level and this object is of variable size,
1358 make the actual type a hidden pointer to the real type and
1359 make the initializer be a memory allocation and initialization.
1360 Likewise for objects we aren't defining (presumed to be
1361 external references from other packages), but there we do
1362 not set up an initialization.
1364 If the object's size overflows, make an allocator too, so that
1365 Storage_Error gets raised. Note that we will never free
1366 such memory, so we presume it never will get allocated. */
1367 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1368 global_bindings_p ()
1369 || !definition
1370 || static_flag)
1371 || (gnu_size
1372 && !allocatable_size_p (convert (sizetype,
1373 size_binop
1374 (EXACT_DIV_EXPR, gnu_size,
1375 bitsize_unit_node)),
1376 global_bindings_p ()
1377 || !definition
1378 || static_flag)))
1380 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1381 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1382 gnu_type = build_reference_type (gnu_type);
1383 used_by_ref = true;
1384 const_flag = true;
1385 volatile_flag = false;
1386 gnu_size = NULL_TREE;
1388 /* In case this was an aliased object whose nominal subtype is
1389 unconstrained, the pointer above will be a thin pointer and
1390 build_allocator will automatically make the template.
1392 If we have a template initializer only (that we made above),
1393 pretend there is none and rely on what build_allocator creates
1394 again anyway. Otherwise (if we have a full initializer), get
1395 the data part and feed that to build_allocator.
1397 If we are elaborating a mutable object, tell build_allocator to
1398 ignore a possibly simpler size from the initializer, if any, as
1399 we must allocate the maximum possible size in this case. */
1400 if (definition && !imported_p)
1402 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1404 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1405 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1407 gnu_alloc_type
1408 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1410 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1411 && CONSTRUCTOR_NELTS (gnu_expr) == 1)
1412 gnu_expr = NULL_TREE;
1413 else
1414 gnu_expr
1415 = build_component_ref
1416 (gnu_expr,
1417 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1418 false);
1421 /* Give a warning if the size is constant but too large. */
1422 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST)
1424 if (valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
1426 post_error
1427 ("??too large object cannot be allocated statically",
1428 gnat_entity);
1429 post_error ("\\?dynamic allocation will be used instead",
1430 gnat_entity);
1433 else
1434 post_error ("??Storage_Error will be raised at run time!",
1435 gnat_entity);
1438 gnu_expr
1439 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1440 Empty, Empty, gnat_entity, mutable_p);
1442 else
1443 gnu_expr = NULL_TREE;
1446 /* If this object would go into the stack and has an alignment larger
1447 than the largest stack alignment the back-end can honor, resort to
1448 a variable of "aligning type". */
1449 if (definition
1450 && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT
1451 && !imported_p
1452 && !static_flag
1453 && !global_bindings_p ())
1455 /* Create the new variable. No need for extra room before the
1456 aligned field as this is in automatic storage. */
1457 tree gnu_new_type
1458 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1459 TYPE_SIZE_UNIT (gnu_type),
1460 BIGGEST_ALIGNMENT, 0, gnat_entity);
1461 tree gnu_new_var
1462 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1463 NULL_TREE, gnu_new_type, NULL_TREE,
1464 false, false, false, false, false,
1465 true, debug_info_p && definition, NULL,
1466 gnat_entity);
1468 /* Initialize the aligned field if we have an initializer. */
1469 if (gnu_expr)
1470 add_stmt_with_node
1471 (build_binary_op (INIT_EXPR, NULL_TREE,
1472 build_component_ref
1473 (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1474 false),
1475 gnu_expr),
1476 gnat_entity);
1478 /* And setup this entity as a reference to the aligned field. */
1479 gnu_type = build_reference_type (gnu_type);
1480 gnu_expr
1481 = build_unary_op
1482 (ADDR_EXPR, NULL_TREE,
1483 build_component_ref (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1484 false));
1485 TREE_CONSTANT (gnu_expr) = 1;
1487 used_by_ref = true;
1488 const_flag = true;
1489 volatile_flag = false;
1490 gnu_size = NULL_TREE;
1493 /* If this is an aggregate constant initialized to a constant, force it
1494 to be statically allocated. This saves an initialization copy. */
1495 if (!static_flag
1496 && const_flag
1497 && gnu_expr
1498 && TREE_CONSTANT (gnu_expr)
1499 && AGGREGATE_TYPE_P (gnu_type)
1500 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
1501 && !(TYPE_IS_PADDING_P (gnu_type)
1502 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1503 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1504 static_flag = true;
1506 /* If this is an array allocated with its bounds, we make its type a
1507 thin reference, i.e. the reference counterpart of a thin pointer,
1508 so that it points to the array part. This is aimed at making it
1509 easier for the debugger to decode the object. Note that we have
1510 to do it this late because of the couple of allocation adjustments
1511 that might be made above. */
1512 if (Is_Constr_Array_Subt_With_Bounds (gnat_type)
1513 && !type_annotate_only)
1515 /* In case the object with the template has already been allocated
1516 just above, we have nothing to do here. */
1517 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1519 /* This variable is a GNAT encoding used by Workbench: let it
1520 go through the debugging information but mark it as
1521 artificial: users are not interested in it. */
1522 tree gnu_unc_var
1523 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1524 NULL_TREE, gnu_type, gnu_expr,
1525 const_flag, Is_Public (gnat_entity),
1526 imported_p || !definition, static_flag,
1527 volatile_flag, true,
1528 debug_info_p && definition,
1529 NULL, gnat_entity);
1530 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1531 TREE_CONSTANT (gnu_expr) = 1;
1533 used_by_ref = true;
1534 const_flag = true;
1535 volatile_flag = false;
1536 inner_const_flag = TREE_READONLY (gnu_unc_var);
1537 gnu_size = NULL_TREE;
1540 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
1541 gnu_type
1542 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1545 /* Convert the expression to the type of the object if need be. */
1546 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1547 gnu_expr = convert (gnu_type, gnu_expr);
1549 /* If this name is external or a name was specified, use it, but don't
1550 use the Interface_Name with an address clause (see cd30005). */
1551 if ((Is_Public (gnat_entity) && !imported_p)
1552 || (Present (Interface_Name (gnat_entity))
1553 && No (Address_Clause (gnat_entity))))
1554 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1556 /* Deal with a pragma Linker_Section on a constant or variable. */
1557 if ((kind == E_Constant || kind == E_Variable)
1558 && Present (Linker_Section_Pragma (gnat_entity)))
1559 prepend_one_attribute_pragma (&attr_list,
1560 Linker_Section_Pragma (gnat_entity));
1562 /* Now create the variable or the constant and set various flags. */
1563 gnu_decl
1564 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1565 gnu_expr, const_flag, Is_Public (gnat_entity),
1566 imported_p || !definition, static_flag,
1567 volatile_flag, artificial_p,
1568 debug_info_p && definition, attr_list,
1569 gnat_entity);
1570 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1571 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1572 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1574 /* If we are defining an Out parameter and optimization isn't enabled,
1575 create a fake PARM_DECL for debugging purposes and make it point to
1576 the VAR_DECL. Suppress debug info for the latter but make sure it
1577 will live in memory so that it can be accessed from within the
1578 debugger through the PARM_DECL. */
1579 if (kind == E_Out_Parameter
1580 && definition
1581 && debug_info_p
1582 && !optimize
1583 && !flag_generate_lto)
1585 tree param = create_param_decl (gnu_entity_name, gnu_type);
1586 gnat_pushdecl (param, gnat_entity);
1587 SET_DECL_VALUE_EXPR (param, gnu_decl);
1588 DECL_HAS_VALUE_EXPR_P (param) = 1;
1589 DECL_IGNORED_P (gnu_decl) = 1;
1590 TREE_ADDRESSABLE (gnu_decl) = 1;
1593 /* If this is a loop parameter, set the corresponding flag. */
1594 else if (kind == E_Loop_Parameter)
1595 DECL_LOOP_PARM_P (gnu_decl) = 1;
1597 /* If this is a constant and we are defining it or it generates a real
1598 symbol at the object level and we are referencing it, we may want
1599 or need to have a true variable to represent it:
1600 - if the constant is public and not overlaid on something else,
1601 - if its address is taken,
1602 - if it is aliased,
1603 - if optimization isn't enabled, for debugging purposes. */
1604 if (TREE_CODE (gnu_decl) == CONST_DECL
1605 && (definition || Sloc (gnat_entity) > Standard_Location)
1606 && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
1607 || Address_Taken (gnat_entity)
1608 || Is_Aliased (gnat_entity)
1609 || (!optimize && debug_info_p)))
1611 tree gnu_corr_var
1612 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1613 gnu_expr, true, Is_Public (gnat_entity),
1614 !definition, static_flag, volatile_flag,
1615 artificial_p, debug_info_p && definition,
1616 attr_list, gnat_entity, false);
1618 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1619 DECL_IGNORED_P (gnu_decl) = 1;
1622 /* If this is a constant, even if we don't need a true variable, we
1623 may need to avoid returning the initializer in every case. That
1624 can happen for the address of a (constant) constructor because,
1625 upon dereferencing it, the constructor will be reinjected in the
1626 tree, which may not be valid in every case; see lvalue_required_p
1627 for more details. */
1628 if (TREE_CODE (gnu_decl) == CONST_DECL)
1629 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1631 /* If this is a local variable with non-BLKmode and aggregate type,
1632 and optimization isn't enabled, then force it in memory so that
1633 a register won't be allocated to it with possible subparts left
1634 uninitialized and reaching the register allocator. */
1635 else if (VAR_P (gnu_decl)
1636 && !DECL_EXTERNAL (gnu_decl)
1637 && !TREE_STATIC (gnu_decl)
1638 && DECL_MODE (gnu_decl) != BLKmode
1639 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl))
1640 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl))
1641 && !optimize)
1642 TREE_ADDRESSABLE (gnu_decl) = 1;
1644 /* Back-annotate Esize and Alignment of the object if not already
1645 known. Note that we pick the values of the type, not those of
1646 the object, to shield ourselves from low-level platform-dependent
1647 adjustments like alignment promotion. This is both consistent with
1648 all the treatment above, where alignment and size are set on the
1649 type of the object and not on the object directly, and makes it
1650 possible to support all confirming representation clauses. */
1651 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1652 used_by_ref);
1654 break;
1656 case E_Void:
1657 /* Return a TYPE_DECL for "void" that we previously made. */
1658 gnu_decl = TYPE_NAME (void_type_node);
1659 break;
1661 case E_Enumeration_Type:
1662 /* A special case: for the types Character and Wide_Character in
1663 Standard, we do not list all the literals. So if the literals
1664 are not specified, make this an integer type. */
1665 if (No (First_Literal (gnat_entity)))
1667 if (esize == CHAR_TYPE_SIZE && flag_signed_char)
1668 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1669 else
1670 gnu_type = make_unsigned_type (esize);
1671 TYPE_NAME (gnu_type) = gnu_entity_name;
1673 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1674 This is needed by the DWARF-2 back-end to distinguish between
1675 unsigned integer types and character types. */
1676 TYPE_STRING_FLAG (gnu_type) = 1;
1678 /* This flag is needed by the call just below. */
1679 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1681 finish_character_type (gnu_type);
1683 else
1685 /* We have a list of enumeral constants in First_Literal. We make a
1686 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1687 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1688 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1689 value of the literal. But when we have a regular boolean type, we
1690 simplify this a little by using a BOOLEAN_TYPE. */
1691 const bool is_boolean = Is_Boolean_Type (gnat_entity)
1692 && !Has_Non_Standard_Rep (gnat_entity);
1693 const bool is_unsigned = Is_Unsigned_Type (gnat_entity);
1694 tree gnu_list = NULL_TREE;
1695 Entity_Id gnat_literal;
1697 /* Boolean types with foreign convention have precision 1. */
1698 if (is_boolean && foreign)
1699 esize = 1;
1701 gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1702 TYPE_PRECISION (gnu_type) = esize;
1703 TYPE_UNSIGNED (gnu_type) = is_unsigned;
1704 set_min_and_max_values_for_integral_type (gnu_type, esize,
1705 TYPE_SIGN (gnu_type));
1706 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
1707 layout_type (gnu_type);
1709 for (gnat_literal = First_Literal (gnat_entity);
1710 Present (gnat_literal);
1711 gnat_literal = Next_Literal (gnat_literal))
1713 tree gnu_value
1714 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1715 /* Do not generate debug info for individual enumerators. */
1716 tree gnu_literal
1717 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1718 gnu_type, gnu_value, true, false, false,
1719 false, false, artificial_p, false,
1720 NULL, gnat_literal);
1721 save_gnu_tree (gnat_literal, gnu_literal, false);
1722 gnu_list
1723 = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list);
1726 if (!is_boolean)
1727 TYPE_VALUES (gnu_type) = nreverse (gnu_list);
1729 /* Note that the bounds are updated at the end of this function
1730 to avoid an infinite recursion since they refer to the type. */
1731 goto discrete_type;
1733 break;
1735 case E_Signed_Integer_Type:
1736 /* For integer types, just make a signed type the appropriate number
1737 of bits. */
1738 gnu_type = make_signed_type (esize);
1739 goto discrete_type;
1741 case E_Ordinary_Fixed_Point_Type:
1742 case E_Decimal_Fixed_Point_Type:
1744 /* Small_Value is the scale factor. */
1745 const Ureal gnat_small_value = Small_Value (gnat_entity);
1746 tree scale_factor = NULL_TREE;
1748 gnu_type = make_signed_type (esize);
1750 /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
1751 binary or decimal scale: it is easier to read for humans. */
1752 if (UI_Eq (Numerator (gnat_small_value), Uint_1)
1753 && (Rbase (gnat_small_value) == 2
1754 || Rbase (gnat_small_value) == 10))
1756 tree base
1757 = build_int_cst (integer_type_node, Rbase (gnat_small_value));
1758 tree exponent
1759 = build_int_cst (integer_type_node,
1760 UI_To_Int (Denominator (gnat_small_value)));
1761 scale_factor
1762 = build2 (RDIV_EXPR, integer_type_node,
1763 integer_one_node,
1764 build2 (POWER_EXPR, integer_type_node,
1765 base, exponent));
1768 /* Use the arbitrary scale factor description. Note that we support
1769 a Small_Value whose magnitude is larger than 64-bit even on 32-bit
1770 platforms, so we unconditionally use a (dummy) 128-bit type. */
1771 else
1773 const Uint gnat_num = Norm_Num (gnat_small_value);
1774 const Uint gnat_den = Norm_Den (gnat_small_value);
1775 tree gnu_small_type = make_unsigned_type (128);
1776 tree gnu_num = UI_To_gnu (gnat_num, gnu_small_type);
1777 tree gnu_den = UI_To_gnu (gnat_den, gnu_small_type);
1779 scale_factor
1780 = build2 (RDIV_EXPR, gnu_small_type, gnu_num, gnu_den);
1783 TYPE_FIXED_POINT_P (gnu_type) = 1;
1784 SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor);
1786 goto discrete_type;
1788 case E_Modular_Integer_Type:
1790 /* Packed Array Impl. Types are supposed to be subtypes only. */
1791 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity));
1793 /* For modular types, make the unsigned type of the proper number
1794 of bits and then set up the modulus, if required. */
1795 gnu_type = make_unsigned_type (esize);
1797 /* Get the modulus in this type. If the modulus overflows, assume
1798 that this is because it was equal to 2**Esize. Note that there
1799 is no overflow checking done on unsigned types, so we detect the
1800 overflow by looking for a modulus of zero, which is invalid. */
1801 tree gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1803 /* If the modulus is not 2**Esize, then this also means that the upper
1804 bound of the type, i.e. modulus - 1, is not maximal, so we create an
1805 extra subtype to carry it and set the modulus on the base type. */
1806 if (!integer_zerop (gnu_modulus))
1808 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1809 TYPE_MODULAR_P (gnu_type) = 1;
1810 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1811 tree gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1812 build_int_cst (gnu_type, 1));
1813 gnu_type
1814 = create_extra_subtype (gnu_type, TYPE_MIN_VALUE (gnu_type),
1815 gnu_high);
1818 goto discrete_type;
1820 case E_Signed_Integer_Subtype:
1821 case E_Enumeration_Subtype:
1822 case E_Modular_Integer_Subtype:
1823 case E_Ordinary_Fixed_Point_Subtype:
1824 case E_Decimal_Fixed_Point_Subtype:
1825 gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity);
1826 if (Present (gnat_cloned_subtype))
1827 break;
1829 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1830 not want to call create_range_type since we would like each subtype
1831 node to be distinct. ??? Historically this was in preparation for
1832 when memory aliasing is implemented, but that's obsolete now given
1833 the call to relate_alias_sets below.
1835 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1836 this fact is used by the arithmetic conversion functions.
1838 We elaborate the Ancestor_Subtype if it is not in the current unit
1839 and one of our bounds is non-static. We do this to ensure consistent
1840 naming in the case where several subtypes share the same bounds, by
1841 elaborating the first such subtype first, thus using its name. */
1843 if (!definition
1844 && Present (Ancestor_Subtype (gnat_entity))
1845 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1846 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1847 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1848 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
1850 /* Set the precision to the Esize except for bit-packed arrays. */
1851 if (Is_Packed_Array_Impl_Type (gnat_entity))
1852 esize = UI_To_Int (RM_Size (gnat_entity));
1854 /* Boolean types with foreign convention have precision 1. */
1855 if (Is_Boolean_Type (gnat_entity) && foreign)
1857 gnu_type = make_node (BOOLEAN_TYPE);
1858 TYPE_PRECISION (gnu_type) = 1;
1859 TYPE_UNSIGNED (gnu_type) = 1;
1860 set_min_and_max_values_for_integral_type (gnu_type, 1, UNSIGNED);
1861 layout_type (gnu_type);
1863 /* First subtypes of Character are treated as Character; otherwise
1864 this should be an unsigned type if the base type is unsigned or
1865 if the lower bound is constant and non-negative or if the type
1866 is biased. However, even if the lower bound is constant and
1867 non-negative, we use a signed type for a subtype with the same
1868 size as its signed base type, because this eliminates useless
1869 conversions to it and gives more leeway to the optimizer; but
1870 this means that we will need to explicitly test for this case
1871 when we change the representation based on the RM size. */
1872 else if (kind == E_Enumeration_Subtype
1873 && No (First_Literal (Etype (gnat_entity)))
1874 && Esize (gnat_entity) == RM_Size (gnat_entity)
1875 && esize == CHAR_TYPE_SIZE
1876 && flag_signed_char)
1877 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1878 else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity)))
1879 || (Esize (Etype (gnat_entity)) != Esize (gnat_entity)
1880 && Is_Unsigned_Type (gnat_entity))
1881 || Has_Biased_Representation (gnat_entity))
1882 gnu_type = make_unsigned_type (esize);
1883 else
1884 gnu_type = make_signed_type (esize);
1885 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1887 SET_TYPE_RM_MIN_VALUE
1888 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
1889 gnat_entity, "L", definition, true,
1890 debug_info_p));
1892 SET_TYPE_RM_MAX_VALUE
1893 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
1894 gnat_entity, "U", definition, true,
1895 debug_info_p));
1897 if (TREE_CODE (gnu_type) == INTEGER_TYPE)
1898 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1899 = Has_Biased_Representation (gnat_entity);
1901 /* Do the same processing for Character subtypes as for types. */
1902 if (TREE_CODE (TREE_TYPE (gnu_type)) == INTEGER_TYPE
1903 && TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
1905 TYPE_NAME (gnu_type) = gnu_entity_name;
1906 TYPE_STRING_FLAG (gnu_type) = 1;
1907 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1908 finish_character_type (gnu_type);
1911 /* Inherit our alias set from what we're a subtype of. Subtypes
1912 are not different types and a pointer can designate any instance
1913 within a subtype hierarchy. */
1914 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1916 /* One of the above calls might have caused us to be elaborated,
1917 so don't blow up if so. */
1918 if (present_gnu_tree (gnat_entity))
1920 maybe_present = true;
1921 break;
1924 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1925 TYPE_STUB_DECL (gnu_type)
1926 = create_type_stub_decl (gnu_entity_name, gnu_type);
1928 discrete_type:
1930 /* We have to handle clauses that under-align the type specially. */
1931 if ((Present (Alignment_Clause (gnat_entity))
1932 || (Is_Packed_Array_Impl_Type (gnat_entity)
1933 && Present
1934 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1935 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1937 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1938 if (align >= TYPE_ALIGN (gnu_type))
1939 align = 0;
1942 /* If the type we are dealing with represents a bit-packed array,
1943 we need to have the bits left justified on big-endian targets
1944 and right justified on little-endian targets. We also need to
1945 ensure that when the value is read (e.g. for comparison of two
1946 such values), we only get the good bits, since the unused bits
1947 are uninitialized. Both goals are accomplished by wrapping up
1948 the modular type in an enclosing record type. */
1949 if (Is_Packed_Array_Impl_Type (gnat_entity))
1951 tree gnu_field_type, gnu_field, t;
1953 gcc_assert (Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
1954 TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1956 /* Make the original array type a parallel/debug type. */
1957 if (debug_info_p)
1959 tree gnu_name
1960 = associate_original_type_to_packed_array (gnu_type,
1961 gnat_entity);
1962 if (gnu_name)
1963 gnu_entity_name = gnu_name;
1966 /* Set the RM size before wrapping up the original type. */
1967 SET_TYPE_RM_SIZE (gnu_type,
1968 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1970 /* Create a stripped-down declaration, mainly for debugging. */
1971 t = create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1972 gnat_entity);
1974 /* Now save it and build the enclosing record type. */
1975 gnu_field_type = gnu_type;
1977 gnu_type = make_node (RECORD_TYPE);
1978 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1979 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1980 TYPE_PACKED (gnu_type) = 1;
1981 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1982 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1983 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1985 /* Propagate the alignment of the modular type to the record type,
1986 unless there is an alignment clause that under-aligns the type.
1987 This means that bit-packed arrays are given "ceil" alignment for
1988 their size by default, which may seem counter-intuitive but makes
1989 it possible to overlay them on modular types easily. */
1990 SET_TYPE_ALIGN (gnu_type,
1991 align > 0 ? align : TYPE_ALIGN (gnu_field_type));
1993 /* Propagate the reverse storage order flag to the record type so
1994 that the required byte swapping is performed when retrieving the
1995 enclosed modular value. */
1996 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
1997 = Reverse_Storage_Order (Original_Array_Type (gnat_entity));
1999 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
2001 /* Don't declare the field as addressable since we won't be taking
2002 its address and this would prevent create_field_decl from making
2003 a bitfield. */
2004 gnu_field
2005 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
2006 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
2008 /* We will output additional debug info manually below. */
2009 finish_record_type (gnu_type, gnu_field, 2, false);
2011 /* Make the original array type a parallel/debug type. Note that
2012 gnat_get_array_descr_info needs a TYPE_IMPL_PACKED_ARRAY_P type
2013 so we use an intermediate step for standard DWARF. */
2014 if (debug_info_p)
2016 if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
2017 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
2018 else if (DECL_PARALLEL_TYPE (t))
2019 add_parallel_type (gnu_type, DECL_PARALLEL_TYPE (t));
2023 /* If the type we are dealing with has got a smaller alignment than the
2024 natural one, we need to wrap it up in a record type and misalign the
2025 latter; we reuse the padding machinery for this purpose. */
2026 else if (align > 0)
2028 tree gnu_size = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2030 /* Set the RM size before wrapping the type. */
2031 SET_TYPE_RM_SIZE (gnu_type, gnu_size);
2033 /* Create a stripped-down declaration, mainly for debugging. */
2034 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
2035 gnat_entity);
2037 gnu_type
2038 = maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
2039 gnat_entity, false, definition, false);
2041 TYPE_PACKED (gnu_type) = 1;
2042 SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
2045 break;
2047 case E_Floating_Point_Type:
2048 /* The type of the Low and High bounds can be our type if this is
2049 a type from Standard, so set them at the end of the function. */
2050 gnu_type = make_node (REAL_TYPE);
2051 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
2052 layout_type (gnu_type);
2053 break;
2055 case E_Floating_Point_Subtype:
2056 gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity);
2057 if (Present (gnat_cloned_subtype))
2058 break;
2060 /* See the E_Signed_Integer_Subtype case for the rationale. */
2061 if (!definition
2062 && Present (Ancestor_Subtype (gnat_entity))
2063 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
2064 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
2065 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
2066 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
2068 gnu_type = make_node (REAL_TYPE);
2069 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
2070 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
2071 TYPE_GCC_MIN_VALUE (gnu_type)
2072 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
2073 TYPE_GCC_MAX_VALUE (gnu_type)
2074 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
2075 layout_type (gnu_type);
2077 SET_TYPE_RM_MIN_VALUE
2078 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
2079 gnat_entity, "L", definition, true,
2080 debug_info_p));
2082 SET_TYPE_RM_MAX_VALUE
2083 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
2084 gnat_entity, "U", definition, true,
2085 debug_info_p));
2087 /* Inherit our alias set from what we're a subtype of, as for
2088 integer subtypes. */
2089 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
2091 /* One of the above calls might have caused us to be elaborated,
2092 so don't blow up if so. */
2093 maybe_present = true;
2094 break;
2096 /* Array Types and Subtypes
2098 In GNAT unconstrained array types are represented by E_Array_Type and
2099 constrained array types are represented by E_Array_Subtype. They are
2100 translated into UNCONSTRAINED_ARRAY_TYPE and ARRAY_TYPE respectively.
2101 But there are no actual objects of an unconstrained array type; all we
2102 have are pointers to that type. In addition to the type node itself,
2103 4 other types associated with it are built in the process:
2105 1. the array type (suffix XUA) containing the actual data,
2107 2. the template type (suffix XUB) containing the bounds,
2109 3. the fat pointer type (suffix XUP) representing a pointer or a
2110 reference to the unconstrained array type:
2111 XUP = struct { XUA *, XUB * }
2113 4. the object record type (suffix XUT) containing bounds and data:
2114 XUT = struct { XUB, XUA }
2116 The bounds of the array type XUA (de)reference the XUB * field of a
2117 PLACEHOLDER_EXPR for the fat pointer type XUP, so the array type XUA
2118 is to be interpreted in the context of the fat pointer type XUB for
2119 debug info purposes. */
2121 case E_Array_Type:
2123 const Entity_Id OAT = Original_Array_Type (gnat_entity);
2124 const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
2125 const bool convention_fortran_p
2126 = (Convention (gnat_entity) == Convention_Fortran);
2127 const int ndim = Number_Dimensions (gnat_entity);
2128 tree gnu_fat_type, gnu_template_type, gnu_ptr_template;
2129 tree gnu_template_reference, gnu_template_fields;
2130 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2131 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2132 tree gnu_max_size = size_one_node;
2133 tree comp_type, fld, tem, obj;
2134 Entity_Id gnat_index;
2135 alias_set_type ptr_set = -1;
2136 int index;
2138 /* Create the type for the component now, as it simplifies breaking
2139 type reference loops. */
2140 comp_type
2141 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2142 if (present_gnu_tree (gnat_entity))
2144 /* As a side effect, the type may have been translated. */
2145 maybe_present = true;
2146 break;
2149 /* We complete an existing dummy fat pointer type in place. This both
2150 avoids further complex adjustments in update_pointer_to and yields
2151 better debugging information in DWARF by leveraging the support for
2152 incomplete declarations of "tagged" types in the DWARF back-end. */
2153 gnu_type = get_dummy_type (gnat_entity);
2154 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2156 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2157 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2158 gnu_ptr_template =
2159 TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2160 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2162 /* Save the contents of the dummy type for update_pointer_to. */
2163 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2164 TYPE_FIELDS (TYPE_POINTER_TO (gnu_type))
2165 = copy_node (TYPE_FIELDS (gnu_fat_type));
2166 DECL_CHAIN (TYPE_FIELDS (TYPE_POINTER_TO (gnu_type)))
2167 = copy_node (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2169 else
2171 gnu_fat_type = make_node (RECORD_TYPE);
2172 gnu_template_type = make_node (RECORD_TYPE);
2173 gnu_ptr_template = build_pointer_type (gnu_template_type);
2176 /* Make a node for the array. If we are not defining the array
2177 suppress expanding incomplete types. */
2178 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2180 /* The component may refer to this type, so defer completion of any
2181 incomplete types. */
2182 if (!definition)
2184 defer_incomplete_level++;
2185 this_deferred = true;
2188 /* Build the fat pointer type. Use a "void *" object instead of
2189 a pointer to the array type since we don't have the array type
2190 yet (it will reference the fat pointer via the bounds). Note
2191 that we reuse the existing fields of a dummy type because for:
2193 type Arr is array (Positive range <>) of Element_Type;
2194 type Array_Ref is access Arr;
2195 Var : Array_Ref := Null;
2197 in a declarative part, Arr will be frozen only after Var, which
2198 means that the fields used in the CONSTRUCTOR built for Null are
2199 those of the dummy type, which in turn means that COMPONENT_REFs
2200 of Var may be built with these fields. Now if COMPONENT_REFs of
2201 Var are also built later with the fields of the final type, the
2202 aliasing machinery may consider that the accesses are distinct
2203 if the FIELD_DECLs are distinct as objects. */
2204 if (COMPLETE_TYPE_P (gnu_fat_type))
2206 fld = TYPE_FIELDS (gnu_fat_type);
2207 if (TYPE_ALIAS_SET_KNOWN_P (TYPE_CANONICAL (TREE_TYPE (fld))))
2208 ptr_set = TYPE_ALIAS_SET (TYPE_CANONICAL (TREE_TYPE (fld)));
2209 TREE_TYPE (fld) = ptr_type_node;
2210 TREE_TYPE (DECL_CHAIN (fld)) = gnu_ptr_template;
2211 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
2212 for (tree t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2213 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2215 else
2217 /* We make the fields addressable for the sake of compatibility
2218 with languages for which the regular fields are addressable. */
2220 = create_field_decl (get_identifier ("P_ARRAY"),
2221 ptr_type_node, gnu_fat_type,
2222 NULL_TREE, NULL_TREE, 0, 1);
2223 DECL_CHAIN (fld)
2224 = create_field_decl (get_identifier ("P_BOUNDS"),
2225 gnu_ptr_template, gnu_fat_type,
2226 NULL_TREE, NULL_TREE, 0, 1);
2227 finish_fat_pointer_type (gnu_fat_type, fld);
2228 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2231 /* If the GNAT encodings are used, give the fat pointer type a name.
2232 If this is a packed type implemented specially, tell the debugger
2233 how to interpret the underlying bits by fetching the name of the
2234 implementation type. But, in any case, mark it as artificial so
2235 the debugger can skip it. */
2236 const Entity_Id gnat_name
2237 = Present (PAT) && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL
2238 ? PAT
2239 : gnat_entity;
2240 tree xup_name
2241 = gnat_encodings == DWARF_GNAT_ENCODINGS_ALL
2242 ? create_concat_name (gnat_name, "XUP")
2243 : gnu_entity_name;
2244 create_type_decl (xup_name, gnu_fat_type, true, debug_info_p,
2245 gnat_entity);
2247 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2248 is the fat pointer. This will be used to access the individual
2249 fields once we build them. */
2250 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2251 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2252 DECL_CHAIN (fld), NULL_TREE);
2253 gnu_template_reference
2254 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2255 TREE_READONLY (gnu_template_reference) = 1;
2256 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2258 /* Now create the GCC type for each index and add the fields for that
2259 index to the template. */
2260 for (index = (convention_fortran_p ? ndim - 1 : 0),
2261 gnat_index = First_Index (gnat_entity);
2262 IN_RANGE (index, 0, ndim - 1);
2263 index += (convention_fortran_p ? - 1 : 1),
2264 gnat_index = Next_Index (gnat_index))
2266 const Entity_Id gnat_index_type = Etype (gnat_index);
2267 const bool is_flb
2268 = Is_Fixed_Lower_Bound_Index_Subtype (gnat_index_type);
2269 tree gnu_index_type = get_unpadded_type (gnat_index_type);
2270 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2271 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2272 tree gnu_index_base_type = get_base_type (gnu_index_type);
2273 tree gnu_lb_field, gnu_hb_field;
2274 tree gnu_min, gnu_max, gnu_high;
2275 char field_name[16];
2277 /* Update the maximum size of the array in elements. */
2278 if (gnu_max_size)
2279 gnu_max_size
2280 = update_n_elem (gnu_max_size, gnu_orig_min, gnu_orig_max);
2282 /* Now build the self-referential bounds of the index type. */
2283 gnu_index_type = maybe_character_type (gnu_index_type);
2284 gnu_index_base_type = maybe_character_type (gnu_index_base_type);
2286 /* Make the FIELD_DECLs for the low and high bounds of this
2287 type and then make extractions of these fields from the
2288 template. */
2289 sprintf (field_name, "LB%d", index);
2290 gnu_lb_field = create_field_decl (get_identifier (field_name),
2291 gnu_index_type,
2292 gnu_template_type, NULL_TREE,
2293 NULL_TREE, 0, 0);
2294 /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
2295 DECL_DISCRIMINANT_NUMBER (gnu_lb_field) = integer_minus_one_node;
2296 Sloc_to_locus (Sloc (gnat_entity),
2297 &DECL_SOURCE_LOCATION (gnu_lb_field));
2299 field_name[0] = 'U';
2300 gnu_hb_field = create_field_decl (get_identifier (field_name),
2301 gnu_index_type,
2302 gnu_template_type, NULL_TREE,
2303 NULL_TREE, 0, 0);
2304 /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR. */
2305 DECL_DISCRIMINANT_NUMBER (gnu_hb_field) = integer_minus_one_node;
2306 Sloc_to_locus (Sloc (gnat_entity),
2307 &DECL_SOURCE_LOCATION (gnu_hb_field));
2309 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2311 /* We can't use build_component_ref here since the template type
2312 isn't complete yet. */
2313 if (!is_flb)
2315 gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field),
2316 gnu_template_reference, gnu_lb_field,
2317 NULL_TREE);
2318 TREE_READONLY (gnu_orig_min) = 1;
2321 gnu_orig_max = build3 (COMPONENT_REF, TREE_TYPE (gnu_hb_field),
2322 gnu_template_reference, gnu_hb_field,
2323 NULL_TREE);
2324 TREE_READONLY (gnu_orig_max) = 1;
2326 gnu_min = convert (sizetype, gnu_orig_min);
2327 gnu_max = convert (sizetype, gnu_orig_max);
2329 /* Compute the size of this dimension. See the E_Array_Subtype
2330 case below for the rationale. */
2331 if (is_flb
2332 && Nkind (gnat_index) == N_Subtype_Indication
2333 && flb_cannot_be_superflat (gnat_index))
2334 gnu_high = gnu_max;
2336 else
2337 gnu_high
2338 = build3 (COND_EXPR, sizetype,
2339 build2 (GE_EXPR, boolean_type_node,
2340 gnu_orig_max, gnu_orig_min),
2341 gnu_max,
2342 TREE_CODE (gnu_min) == INTEGER_CST
2343 ? int_const_binop (MINUS_EXPR, gnu_min, size_one_node)
2344 : size_binop (MINUS_EXPR, gnu_min, size_one_node));
2346 /* Make a range type with the new range in the Ada base type.
2347 Then make an index type with the size range in sizetype. */
2348 gnu_index_types[index]
2349 = create_index_type (gnu_min, gnu_high,
2350 create_range_type (gnu_index_base_type,
2351 gnu_orig_min,
2352 gnu_orig_max),
2353 gnat_entity);
2355 TYPE_NAME (gnu_index_types[index])
2356 = create_concat_name (gnat_entity, field_name);
2359 /* Install all the fields into the template. */
2360 TYPE_NAME (gnu_template_type)
2361 = create_concat_name (gnat_entity, "XUB");
2362 gnu_template_fields = NULL_TREE;
2363 for (index = 0; index < ndim; index++)
2364 gnu_template_fields
2365 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2366 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2367 debug_info_p);
2368 TYPE_CONTEXT (gnu_template_type) = current_function_decl;
2370 /* If Component_Size is not already specified, annotate it with the
2371 size of the component. */
2372 if (!Known_Component_Size (gnat_entity))
2373 Set_Component_Size (gnat_entity,
2374 annotate_value (TYPE_SIZE (comp_type)));
2376 /* Compute the maximum size of the array in units. */
2377 if (gnu_max_size)
2378 gnu_max_size
2379 = size_binop (MULT_EXPR, gnu_max_size, TYPE_SIZE_UNIT (comp_type));
2381 /* Now build the array type. */
2382 tem = comp_type;
2383 for (index = ndim - 1; index >= 0; index--)
2385 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2386 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2387 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2388 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2389 set_reverse_storage_order_on_array_type (tem);
2390 if (array_type_has_nonaliased_component (tem, gnat_entity))
2391 set_nonaliased_component_on_array_type (tem);
2392 if (Universal_Aliasing (gnat_entity)
2393 || Universal_Aliasing (Component_Type (gnat_entity)))
2394 set_typeless_storage_on_aggregate_type (tem);
2397 /* If an alignment is specified for an array that is not a packed type
2398 implemented specially, use the alignment if it is valid and, if it
2399 was requested with an explicit clause, preserve the information. */
2400 if (Known_Alignment (gnat_entity) && No (PAT))
2402 SET_TYPE_ALIGN (tem,
2403 validate_alignment (Alignment (gnat_entity),
2404 gnat_entity,
2405 TYPE_ALIGN (tem)));
2406 if (Present (Alignment_Clause (gnat_entity)))
2407 TYPE_USER_ALIGN (tem) = 1;
2410 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2411 implementation types as such so that the debug information back-end
2412 can output the appropriate description for them. */
2413 TYPE_PACKED (tem)
2414 = (Is_Packed (gnat_entity)
2415 || Is_Packed_Array_Impl_Type (gnat_entity));
2417 TYPE_BIT_PACKED_ARRAY_TYPE_P (tem)
2418 = (Is_Packed_Array_Impl_Type (gnat_entity)
2419 ? Is_Bit_Packed_Array (OAT)
2420 : Is_Bit_Packed_Array (gnat_entity));
2422 if (Treat_As_Volatile (gnat_entity))
2423 tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
2425 /* Adjust the type of the pointer-to-array field of the fat pointer
2426 and preserve its existing alias set, if any. Note that calling
2427 again record_component_aliases on the fat pointer is not enough
2428 because this may leave dangling references to the existing alias
2429 set from types containing a fat pointer component. If this is
2430 a packed type implemented specially, then use a ref-all pointer
2431 type since the implementation type may vary between constrained
2432 subtypes and unconstrained base type. */
2433 if (Present (PAT))
2434 TREE_TYPE (fld) = build_pointer_type_for_mode (tem, ptr_mode, true);
2435 else
2436 TREE_TYPE (fld) = build_pointer_type (tem);
2437 if (ptr_set != -1)
2438 TYPE_ALIAS_SET (TYPE_CANONICAL (TREE_TYPE (fld))) = ptr_set;
2440 /* If the maximum size doesn't overflow, use it. */
2441 if (gnu_max_size
2442 && TREE_CODE (gnu_max_size) == INTEGER_CST
2443 && !TREE_OVERFLOW (gnu_max_size)
2444 && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
2445 TYPE_ARRAY_MAX_SIZE (tem) = gnu_max_size;
2447 /* See the above description for the rationale. */
2448 tree gnu_tmp_decl
2449 = create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
2450 artificial_p, debug_info_p, gnat_entity);
2451 TYPE_CONTEXT (tem) = gnu_fat_type;
2452 TYPE_CONTEXT (TYPE_POINTER_TO (tem)) = gnu_fat_type;
2454 /* Create the type to be designated by thin pointers: a record type for
2455 the array and its template. We used to shift the fields to have the
2456 template at a negative offset, but this was somewhat of a kludge; we
2457 now shift thin pointer values explicitly but only those which have a
2458 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
2459 If the GNAT encodings are used, give it a name. */
2460 tree xut_name
2461 = (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
2462 ? create_concat_name (gnat_name, "XUT")
2463 : gnu_entity_name;
2464 obj = build_unc_object_type (gnu_template_type, tem, xut_name,
2465 debug_info_p);
2467 SET_TYPE_UNCONSTRAINED_ARRAY (obj, gnu_type);
2468 TYPE_OBJECT_RECORD_TYPE (gnu_type) = obj;
2470 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2471 corresponding fat pointer. */
2472 TREE_TYPE (gnu_type) = gnu_fat_type;
2473 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2474 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2475 SET_TYPE_MODE (gnu_type, BLKmode);
2476 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
2478 /* If this is a packed type implemented specially, then process the
2479 implementation type so it is elaborated in the proper scope. */
2480 if (Present (PAT))
2482 /* Save the XUA type as our equivalent temporarily for the call
2483 to gnat_to_gnu_type on the OAT below. */
2484 save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
2485 gnat_to_gnu_entity (PAT, NULL_TREE, false);
2486 save_gnu_tree (gnat_entity, NULL_TREE, false);
2489 /* If this is precisely the implementation type and it has the same
2490 component as the original type (which happens for peculiar index
2491 types), copy the alias set from the latter; this ensures that all
2492 implementation types built on the fly have the same alias set. */
2493 if (Is_Packed_Array_Impl_Type (gnat_entity)
2494 && Component_Type (gnat_entity) == Component_Type (OAT))
2495 relate_alias_sets (gnu_type, gnat_to_gnu_type (OAT), ALIAS_SET_COPY);
2497 break;
2499 case E_Array_Subtype:
2500 gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity);
2501 if (Present (gnat_cloned_subtype))
2502 break;
2504 /* This is the actual data type for array variables. Multidimensional
2505 arrays are implemented as arrays of arrays. Note that arrays which
2506 have sparse enumeration subtypes as index components create sparse
2507 arrays, which is obviously space inefficient but so much easier to
2508 code for now.
2510 Also note that the subtype never refers to the unconstrained array
2511 type, which is somewhat at variance with Ada semantics.
2513 First check to see if this is simply a renaming of the array type.
2514 If so, the result is the array type. */
2516 gnu_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity)));
2517 if (!Is_Constrained (gnat_entity))
2519 else
2521 const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity);
2522 Entity_Id gnat_index, gnat_base_index;
2523 const bool convention_fortran_p
2524 = (Convention (gnat_entity) == Convention_Fortran);
2525 const int ndim = Number_Dimensions (gnat_entity);
2526 tree gnu_base_type = gnu_type;
2527 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2528 bool *gnu_null_ranges = XALLOCAVEC (bool, ndim);
2529 tree gnu_max_size = size_one_node;
2530 bool need_index_type_struct = false;
2531 int index;
2533 /* First create the GCC type for each index and find out whether
2534 special types are needed for debugging information. */
2535 for (index = (convention_fortran_p ? ndim - 1 : 0),
2536 gnat_index = First_Index (gnat_entity),
2537 gnat_base_index
2538 = First_Index (Implementation_Base_Type (gnat_entity));
2539 IN_RANGE (index, 0, ndim - 1);
2540 index += (convention_fortran_p ? - 1 : 1),
2541 gnat_index = Next_Index (gnat_index),
2542 gnat_base_index = Next_Index (gnat_base_index))
2544 const Entity_Id gnat_index_type = Etype (gnat_index);
2545 tree gnu_index_type = get_unpadded_type (gnat_index_type);
2546 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2547 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2548 tree gnu_index_base_type = get_base_type (gnu_index_type);
2549 tree gnu_base_index_type
2550 = get_unpadded_type (Etype (gnat_base_index));
2551 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2552 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2553 tree gnu_min, gnu_max, gnu_high;
2555 /* We try to create subtypes for discriminants used as bounds
2556 that are more restrictive than those declared, by using the
2557 bounds of the index type of the base array type. This will
2558 make it possible to calculate the maximum size of the record
2559 type more conservatively. This may have already been done by
2560 the front-end (Exp_Ch3.Adjust_Discriminants), in which case
2561 there will be a conversion that needs to be removed first. */
2562 if (CONTAINS_PLACEHOLDER_P (gnu_orig_min)
2563 && TYPE_RM_SIZE (gnu_base_index_type)
2564 && tree_int_cst_lt (TYPE_RM_SIZE (gnu_base_index_type),
2565 TYPE_RM_SIZE (gnu_index_type)))
2567 gnu_orig_min = remove_conversions (gnu_orig_min, false);
2568 TREE_TYPE (gnu_orig_min)
2569 = create_extra_subtype (TREE_TYPE (gnu_orig_min),
2570 gnu_base_orig_min,
2571 gnu_base_orig_max);
2574 if (CONTAINS_PLACEHOLDER_P (gnu_orig_max)
2575 && TYPE_RM_SIZE (gnu_base_index_type)
2576 && tree_int_cst_lt (TYPE_RM_SIZE (gnu_base_index_type),
2577 TYPE_RM_SIZE (gnu_index_type)))
2579 gnu_orig_max = remove_conversions (gnu_orig_max, false);
2580 TREE_TYPE (gnu_orig_max)
2581 = create_extra_subtype (TREE_TYPE (gnu_orig_max),
2582 gnu_base_orig_min,
2583 gnu_base_orig_max);
2586 /* Update the maximum size of the array in elements. Here we
2587 see if any constraint on the index type of the base type
2588 can be used in the case of self-referential bounds on the
2589 index type of the array type. We look for a non-"infinite"
2590 and non-self-referential bound from any type involved and
2591 handle each bound separately. */
2592 if (gnu_max_size)
2594 if (CONTAINS_PLACEHOLDER_P (gnu_orig_min))
2595 gnu_min = gnu_base_orig_min;
2596 else
2597 gnu_min = gnu_orig_min;
2599 if (DECL_P (gnu_min)
2600 && DECL_INITIAL (gnu_min) != NULL_TREE
2601 && (TREE_CODE (gnu_min) != INTEGER_CST
2602 || TREE_OVERFLOW (gnu_min)))
2604 tree tmp = max_value (DECL_INITIAL(gnu_min), false);
2605 if (TREE_CODE (tmp) == INTEGER_CST
2606 && !TREE_OVERFLOW (tmp))
2607 gnu_min = tmp;
2610 if (TREE_CODE (gnu_min) != INTEGER_CST
2611 || TREE_OVERFLOW (gnu_min))
2612 gnu_min = TYPE_MIN_VALUE (TREE_TYPE (gnu_min));
2614 if (CONTAINS_PLACEHOLDER_P (gnu_orig_max))
2615 gnu_max = gnu_base_orig_max;
2616 else
2617 gnu_max = gnu_orig_max;
2619 if (DECL_P (gnu_max)
2620 && DECL_INITIAL (gnu_max) != NULL_TREE
2621 && (TREE_CODE (gnu_max) != INTEGER_CST
2622 || TREE_OVERFLOW (gnu_max)))
2624 tree tmp = max_value (DECL_INITIAL(gnu_max), true);
2625 if (TREE_CODE (tmp) == INTEGER_CST
2626 && !TREE_OVERFLOW (tmp))
2627 gnu_max = tmp;
2630 if (TREE_CODE (gnu_max) != INTEGER_CST
2631 || TREE_OVERFLOW (gnu_max))
2632 gnu_max = TYPE_MAX_VALUE (TREE_TYPE (gnu_max));
2634 gnu_max_size
2635 = update_n_elem (gnu_max_size, gnu_min, gnu_max);
2638 /* Convert the bounds to the base type for consistency below. */
2639 gnu_index_base_type = maybe_character_type (gnu_index_base_type);
2640 gnu_orig_min = convert (gnu_index_base_type, gnu_orig_min);
2641 gnu_orig_max = convert (gnu_index_base_type, gnu_orig_max);
2643 gnu_min = convert (sizetype, gnu_orig_min);
2644 gnu_max = convert (sizetype, gnu_orig_max);
2646 /* See if the base array type is already flat. If it is, we
2647 are probably compiling an ACATS test but it will cause the
2648 code below to malfunction if we don't handle it specially. */
2649 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2650 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2651 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2653 gnu_min = size_one_node;
2654 gnu_max = size_zero_node;
2655 gnu_high = gnu_max;
2658 /* Similarly, if one of the values overflows in sizetype and the
2659 range is null, use 1..0 for the sizetype bounds. */
2660 else if (TREE_CODE (gnu_min) == INTEGER_CST
2661 && TREE_CODE (gnu_max) == INTEGER_CST
2662 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2663 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2665 gnu_min = size_one_node;
2666 gnu_max = size_zero_node;
2667 gnu_high = gnu_max;
2670 /* If the minimum and maximum values both overflow in sizetype,
2671 but the difference in the original type does not overflow in
2672 sizetype, ignore the overflow indication. */
2673 else if (TREE_CODE (gnu_min) == INTEGER_CST
2674 && TREE_CODE (gnu_max) == INTEGER_CST
2675 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2676 && !TREE_OVERFLOW
2677 (convert (sizetype,
2678 fold_build2 (MINUS_EXPR,
2679 gnu_index_base_type,
2680 gnu_orig_max,
2681 gnu_orig_min))))
2683 TREE_OVERFLOW (gnu_min) = 0;
2684 TREE_OVERFLOW (gnu_max) = 0;
2685 gnu_high = gnu_max;
2688 /* Compute the size of this dimension in the general case. We
2689 need to provide GCC with an upper bound to use but have to
2690 deal with the "superflat" case. There are three ways to do
2691 this. If we can prove that the array can never be superflat,
2692 we can just use the high bound of the index type. */
2693 else if ((Nkind (gnat_index) == N_Range
2694 && range_cannot_be_superflat (gnat_index))
2695 /* Bit-Packed Array Impl. Types are never superflat. */
2696 || (Is_Packed_Array_Impl_Type (gnat_entity)
2697 && Is_Bit_Packed_Array
2698 (Original_Array_Type (gnat_entity))))
2699 gnu_high = gnu_max;
2701 /* Otherwise, if the high bound is constant but the low bound is
2702 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2703 lower bound. Note that the comparison must be done in the
2704 original type to avoid any overflow during the conversion. */
2705 else if (TREE_CODE (gnu_max) == INTEGER_CST
2706 && TREE_CODE (gnu_min) != INTEGER_CST)
2708 gnu_high = gnu_max;
2709 gnu_min
2710 = build_cond_expr (sizetype,
2711 build_binary_op (GE_EXPR,
2712 boolean_type_node,
2713 gnu_orig_max,
2714 gnu_orig_min),
2715 gnu_min,
2716 int_const_binop (PLUS_EXPR, gnu_max,
2717 size_one_node));
2720 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2721 in all the other cases. Note that we use int_const_binop for
2722 the shift by 1 if the bound is constant to avoid any unwanted
2723 overflow. */
2724 else
2725 gnu_high
2726 = build_cond_expr (sizetype,
2727 build_binary_op (GE_EXPR,
2728 boolean_type_node,
2729 gnu_orig_max,
2730 gnu_orig_min),
2731 gnu_max,
2732 TREE_CODE (gnu_min) == INTEGER_CST
2733 ? int_const_binop (MINUS_EXPR, gnu_min,
2734 size_one_node)
2735 : size_binop (MINUS_EXPR, gnu_min,
2736 size_one_node));
2738 /* Reuse the index type for the range type. Then make an index
2739 type with the size range in sizetype. */
2740 gnu_index_types[index]
2741 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2742 gnat_entity);
2744 /* Record whether the range is known to be null at compile time
2745 to disambiguate it from too large ranges. */
2746 const Entity_Id gnat_ui_type = Underlying_Type (gnat_index_type);
2747 gnu_null_ranges[index]
2748 = Is_Null_Range (Type_Low_Bound (gnat_ui_type),
2749 Type_High_Bound (gnat_ui_type));
2751 /* We need special types for debugging information to point to
2752 the index types if they have variable bounds, are not integer
2753 types, are biased or are wider than sizetype. These are GNAT
2754 encodings, so we have to include them only when all encodings
2755 are requested. */
2756 if ((TREE_CODE (gnu_orig_min) != INTEGER_CST
2757 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2758 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2759 || (TREE_TYPE (gnu_index_type)
2760 && TREE_CODE (TREE_TYPE (gnu_index_type))
2761 != INTEGER_TYPE)
2762 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
2763 && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
2764 need_index_type_struct = true;
2767 /* Then flatten: create the array of arrays. For an array type
2768 used to implement a packed array, get the component type from
2769 the original array type since the representation clauses that
2770 can affect it are on the latter. */
2771 if (Is_Packed_Array_Impl_Type (gnat_entity)
2772 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2774 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2775 for (index = ndim - 1; index >= 0; index--)
2776 gnu_type = TREE_TYPE (gnu_type);
2778 /* One of the above calls might have caused us to be elaborated,
2779 so don't blow up if so. */
2780 if (present_gnu_tree (gnat_entity))
2782 maybe_present = true;
2783 break;
2786 else
2788 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2789 debug_info_p);
2791 /* One of the above calls might have caused us to be elaborated,
2792 so don't blow up if so. */
2793 if (present_gnu_tree (gnat_entity))
2795 maybe_present = true;
2796 break;
2800 /* Compute the maximum size of the array in units. */
2801 if (gnu_max_size)
2802 gnu_max_size
2803 = size_binop (MULT_EXPR, gnu_max_size, TYPE_SIZE_UNIT (gnu_type));
2805 /* Now build the array type. */
2806 for (index = ndim - 1; index >= 0; index --)
2808 gnu_type = build_nonshared_array_type (gnu_type,
2809 gnu_index_types[index]);
2810 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2811 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2812 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2813 set_reverse_storage_order_on_array_type (gnu_type);
2814 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2815 set_nonaliased_component_on_array_type (gnu_type);
2816 if (Universal_Aliasing (gnat_entity)
2817 || Universal_Aliasing (Component_Type (gnat_entity)))
2818 set_typeless_storage_on_aggregate_type (gnu_type);
2820 /* Clear the TREE_OVERFLOW flag, if any, for null arrays. */
2821 if (gnu_null_ranges[index])
2823 TYPE_SIZE (gnu_type) = bitsize_zero_node;
2824 TYPE_SIZE_UNIT (gnu_type) = size_zero_node;
2827 /* Kludge to clear the TREE_OVERFLOW flag for the sake of LTO
2828 on maximally-sized array types designed by access types. */
2829 if (integer_zerop (TYPE_SIZE (gnu_type))
2830 && TREE_OVERFLOW (TYPE_SIZE (gnu_type))
2831 && Is_Itype (gnat_entity)
2832 && (gnat_temp = Associated_Node_For_Itype (gnat_entity))
2833 && IN (Nkind (gnat_temp), N_Declaration)
2834 && Is_Access_Type (Defining_Entity (gnat_temp))
2835 && Is_Entity_Name (First_Index (gnat_entity))
2836 && UI_To_Int (RM_Size (Entity (First_Index (gnat_entity))))
2837 == BITS_PER_WORD)
2839 TYPE_SIZE (gnu_type) = bitsize_zero_node;
2840 TYPE_SIZE_UNIT (gnu_type) = size_zero_node;
2844 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2845 TYPE_STUB_DECL (gnu_type)
2846 = create_type_stub_decl (gnu_entity_name, gnu_type);
2848 /* If this is a multi-dimensional array and we are at global level,
2849 we need to make a variable corresponding to the stride of the
2850 inner dimensions. */
2851 if (ndim > 1 && global_bindings_p ())
2853 tree gnu_arr_type;
2855 for (gnu_arr_type = TREE_TYPE (gnu_type), index = 1;
2856 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2857 gnu_arr_type = TREE_TYPE (gnu_arr_type), index++)
2859 tree eltype = TREE_TYPE (gnu_arr_type);
2860 char stride_name[32];
2862 sprintf (stride_name, "ST%d", index);
2863 TYPE_SIZE (gnu_arr_type)
2864 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2865 gnat_entity, stride_name,
2866 definition, false);
2868 /* ??? For now, store the size as a multiple of the
2869 alignment of the element type in bytes so that we
2870 can see the alignment from the tree. */
2871 sprintf (stride_name, "ST%d_A_UNIT", index);
2872 TYPE_SIZE_UNIT (gnu_arr_type)
2873 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2874 gnat_entity, stride_name,
2875 definition, false,
2876 TYPE_ALIGN (eltype));
2878 /* ??? create_type_decl is not invoked on the inner types so
2879 the MULT_EXPR node built above will never be marked. */
2880 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2884 /* Set the TYPE_PACKED flag on packed array types and also on their
2885 implementation types, so that the DWARF back-end can output the
2886 appropriate description for them. */
2887 TYPE_PACKED (gnu_type)
2888 = (Is_Packed (gnat_entity)
2889 || Is_Packed_Array_Impl_Type (gnat_entity));
2891 TYPE_BIT_PACKED_ARRAY_TYPE_P (gnu_type)
2892 = (Is_Packed_Array_Impl_Type (gnat_entity)
2893 ? Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))
2894 : Is_Bit_Packed_Array (gnat_entity));
2896 /* If the maximum size doesn't overflow, use it. */
2897 if (gnu_max_size
2898 && TREE_CODE (gnu_max_size) == INTEGER_CST
2899 && !TREE_OVERFLOW (gnu_max_size)
2900 && compare_tree_int (gnu_max_size, TYPE_ARRAY_SIZE_LIMIT) <= 0)
2901 TYPE_ARRAY_MAX_SIZE (gnu_type) = gnu_max_size;
2903 /* If we need to write out a record type giving the names of the
2904 bounds for debugging purposes, do it now and make the record
2905 type a parallel type. This is not needed for a packed array
2906 since the bounds are conveyed by the original array type. */
2907 if (need_index_type_struct
2908 && debug_info_p
2909 && !Is_Packed_Array_Impl_Type (gnat_entity))
2911 tree gnu_bound_rec = make_node (RECORD_TYPE);
2912 tree gnu_field_list = NULL_TREE;
2913 tree gnu_field;
2915 TYPE_NAME (gnu_bound_rec)
2916 = create_concat_name (gnat_entity, "XA");
2918 for (index = ndim - 1; index >= 0; index--)
2920 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2921 tree gnu_index_name = TYPE_IDENTIFIER (gnu_index);
2923 /* Make sure to reference the types themselves, and not just
2924 their names, as the debugger may fall back on them. */
2925 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2926 gnu_bound_rec, NULL_TREE,
2927 NULL_TREE, 0, 0);
2928 DECL_CHAIN (gnu_field) = gnu_field_list;
2929 gnu_field_list = gnu_field;
2932 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2933 add_parallel_type (gnu_type, gnu_bound_rec);
2936 /* If this is a packed array type, make the original array type a
2937 parallel/debug type. Otherwise, if GNAT encodings are used, do
2938 it for the base array type if it is not artificial to make sure
2939 that it is kept in the debug info. */
2940 if (debug_info_p)
2942 if (Is_Packed_Array_Impl_Type (gnat_entity))
2944 tree gnu_name
2945 = associate_original_type_to_packed_array (gnu_type,
2946 gnat_entity);
2947 if (gnu_name)
2948 gnu_entity_name = gnu_name;
2951 else if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
2953 tree gnu_base_decl
2954 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
2955 false);
2957 if (!DECL_ARTIFICIAL (gnu_base_decl))
2958 add_parallel_type (gnu_type,
2959 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2963 /* Set our alias set to that of our base type. This gives all
2964 array subtypes the same alias set. */
2965 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2967 /* If this is a packed type implemented specially, then replace our
2968 type with the implementation type. */
2969 if (Present (PAT))
2971 /* First finish the type we had been making so that we output
2972 debugging information for it. */
2973 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
2974 if (Treat_As_Volatile (gnat_entity))
2976 const int quals
2977 = TYPE_QUAL_VOLATILE
2978 | (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
2979 gnu_type = change_qualified_type (gnu_type, quals);
2981 /* Make it artificial only if the base type was artificial too.
2982 That's sort of "morally" true and will make it possible for
2983 the debugger to look it up by name in DWARF, which is needed
2984 in order to decode the packed array type. */
2985 tree gnu_tmp_decl
2986 = create_type_decl (gnu_entity_name, gnu_type,
2987 !Comes_From_Source (Etype (gnat_entity))
2988 && artificial_p, debug_info_p,
2989 gnat_entity);
2990 /* Save it as our equivalent in case the call below elaborates
2991 this type again. */
2992 save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
2994 gnu_type = gnat_to_gnu_type (PAT);
2995 save_gnu_tree (gnat_entity, NULL_TREE, false);
2997 /* Set the ___XP suffix for GNAT encodings. */
2998 if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
2999 gnu_entity_name = DECL_NAME (TYPE_NAME (gnu_type));
3001 tree gnu_inner = gnu_type;
3002 while (TREE_CODE (gnu_inner) == RECORD_TYPE
3003 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
3004 || TYPE_PADDING_P (gnu_inner)))
3005 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
3007 /* We need to attach the index type to the type we just made so
3008 that the actual bounds can later be put into a template. */
3009 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
3010 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
3011 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
3012 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
3014 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
3016 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
3017 TYPE_MODULUS for modular types so we make an extra
3018 subtype if necessary. */
3019 if (TYPE_MODULAR_P (gnu_inner))
3020 gnu_inner
3021 = create_extra_subtype (gnu_inner,
3022 TYPE_MIN_VALUE (gnu_inner),
3023 TYPE_MAX_VALUE (gnu_inner));
3025 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
3027 /* Check for other cases of overloading. */
3028 gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
3031 for (Entity_Id gnat_index = First_Index (gnat_entity);
3032 Present (gnat_index);
3033 gnat_index = Next_Index (gnat_index))
3034 SET_TYPE_ACTUAL_BOUNDS
3035 (gnu_inner,
3036 tree_cons (NULL_TREE,
3037 get_unpadded_type (Etype (gnat_index)),
3038 TYPE_ACTUAL_BOUNDS (gnu_inner)));
3040 if (Convention (gnat_entity) != Convention_Fortran)
3041 SET_TYPE_ACTUAL_BOUNDS
3042 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
3044 if (TREE_CODE (gnu_type) == RECORD_TYPE
3045 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3046 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
3050 /* Otherwise, if an alignment is specified, use it if valid and, if
3051 the alignment was requested with an explicit clause, state so. */
3052 else if (Known_Alignment (gnat_entity))
3054 SET_TYPE_ALIGN (gnu_type,
3055 validate_alignment (Alignment (gnat_entity),
3056 gnat_entity,
3057 TYPE_ALIGN (gnu_type)));
3058 if (Present (Alignment_Clause (gnat_entity)))
3059 TYPE_USER_ALIGN (gnu_type) = 1;
3062 break;
3064 case E_String_Literal_Subtype:
3065 /* Create the type for a string literal. */
3067 Entity_Id gnat_full_type
3068 = (Is_Private_Type (Etype (gnat_entity))
3069 && Present (Full_View (Etype (gnat_entity)))
3070 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
3071 tree gnu_string_type = get_unpadded_type (gnat_full_type);
3072 tree gnu_string_array_type
3073 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
3074 tree gnu_string_index_type
3075 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
3076 (TYPE_DOMAIN (gnu_string_array_type))));
3077 tree gnu_lower_bound
3078 = convert (gnu_string_index_type,
3079 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
3080 tree gnu_length
3081 = UI_To_gnu (String_Literal_Length (gnat_entity),
3082 gnu_string_index_type);
3083 tree gnu_upper_bound
3084 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
3085 gnu_lower_bound,
3086 int_const_binop (MINUS_EXPR, gnu_length,
3087 convert (gnu_string_index_type,
3088 integer_one_node)));
3089 tree gnu_index_type
3090 = create_index_type (convert (sizetype, gnu_lower_bound),
3091 convert (sizetype, gnu_upper_bound),
3092 create_range_type (gnu_string_index_type,
3093 gnu_lower_bound,
3094 gnu_upper_bound),
3095 gnat_entity);
3097 gnu_type
3098 = build_nonshared_array_type (gnat_to_gnu_type
3099 (Component_Type (gnat_entity)),
3100 gnu_index_type);
3101 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
3102 set_nonaliased_component_on_array_type (gnu_type);
3103 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
3105 break;
3107 /* Record Types and Subtypes
3109 A record type definition is transformed into the equivalent of a C
3110 struct definition. The fields that are the discriminants which are
3111 found in the Full_Type_Declaration node and the elements of the
3112 Component_List found in the Record_Type_Definition node. The
3113 Component_List can be a recursive structure since each Variant of
3114 the Variant_Part of the Component_List has a Component_List.
3116 Processing of a record type definition comprises starting the list of
3117 field declarations here from the discriminants and the calling the
3118 function components_to_record to add the rest of the fields from the
3119 component list and return the gnu type node. The function
3120 components_to_record will call itself recursively as it traverses
3121 the tree. */
3123 case E_Record_Type:
3125 Node_Id record_definition = Type_Definition (gnat_decl);
3127 if (Has_Complex_Representation (gnat_entity))
3129 const Node_Id first_component
3130 = First (Component_Items (Component_List (record_definition)));
3131 tree gnu_component_type
3132 = get_unpadded_type (Etype (Defining_Entity (first_component)));
3133 gnu_type = build_complex_type (gnu_component_type);
3134 break;
3137 Node_Id gnat_constr;
3138 Entity_Id gnat_field, gnat_parent_type;
3139 tree gnu_field, gnu_field_list = NULL_TREE;
3140 tree gnu_get_parent;
3141 /* Set PACKED in keeping with gnat_to_gnu_field. */
3142 const int packed
3143 = Is_Packed (gnat_entity)
3145 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
3146 ? -1
3147 : 0;
3148 const bool has_align = Known_Alignment (gnat_entity);
3149 const bool has_discr = Has_Discriminants (gnat_entity);
3150 const bool is_extension
3151 = (Is_Tagged_Type (gnat_entity)
3152 && Nkind (record_definition) == N_Derived_Type_Definition);
3153 const bool has_rep
3154 = is_extension
3155 ? Has_Record_Rep_Clause (gnat_entity)
3156 : Has_Specified_Layout (gnat_entity);
3157 const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
3158 bool all_rep = has_rep;
3160 /* See if all fields have a rep clause. Stop when we find one
3161 that doesn't. */
3162 if (all_rep)
3163 for (gnat_field = First_Entity (gnat_entity);
3164 Present (gnat_field);
3165 gnat_field = Next_Entity (gnat_field))
3166 if ((Ekind (gnat_field) == E_Component
3167 || (Ekind (gnat_field) == E_Discriminant
3168 && !is_unchecked_union))
3169 && No (Component_Clause (gnat_field)))
3171 all_rep = false;
3172 break;
3175 /* If this is a record extension, go a level further to find the
3176 record definition. Also, verify we have a Parent_Subtype. */
3177 if (is_extension)
3179 if (!type_annotate_only
3180 || Present (Record_Extension_Part (record_definition)))
3181 record_definition = Record_Extension_Part (record_definition);
3183 gcc_assert (Present (Parent_Subtype (gnat_entity))
3184 || type_annotate_only);
3187 /* Make a node for the record type. */
3188 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
3189 TYPE_NAME (gnu_type) = gnu_entity_name;
3190 TYPE_PACKED (gnu_type) = (packed != 0) || has_align || has_rep;
3191 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3192 = Reverse_Storage_Order (gnat_entity);
3194 /* If the record type has discriminants, pointers to it may also point
3195 to constrained subtypes of it, so mark it as may_alias for LTO. */
3196 if (has_discr)
3197 prepend_one_attribute
3198 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3199 get_identifier ("may_alias"), NULL_TREE,
3200 gnat_entity);
3202 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3204 /* Some component may refer to this type, so defer completion of any
3205 incomplete types. */
3206 if (!definition)
3208 defer_incomplete_level++;
3209 this_deferred = true;
3212 /* If both a size and rep clause were specified, put the size on
3213 the record type now so that it can get the proper layout. */
3214 if (has_rep && Known_RM_Size (gnat_entity))
3215 TYPE_SIZE (gnu_type)
3216 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
3218 /* Always set the alignment on the record type here so that it can
3219 get the proper layout. */
3220 if (has_align)
3221 SET_TYPE_ALIGN (gnu_type,
3222 validate_alignment (Alignment (gnat_entity),
3223 gnat_entity, 0));
3224 else
3226 SET_TYPE_ALIGN (gnu_type, 0);
3228 /* If a type needs strict alignment, then its type size will also
3229 be the RM size (see below). Cap the alignment if needed, lest
3230 it may cause this type size to become too large. */
3231 if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity))
3233 unsigned int max_size = UI_To_Int (RM_Size (gnat_entity));
3234 unsigned int max_align = max_size & -max_size;
3235 if (max_align < BIGGEST_ALIGNMENT)
3236 TYPE_MAX_ALIGN (gnu_type) = max_align;
3239 /* Similarly if an Object_Size clause has been specified. */
3240 else if (Known_Esize (gnat_entity))
3242 unsigned int max_size = UI_To_Int (Esize (gnat_entity));
3243 unsigned int max_align = max_size & -max_size;
3244 if (max_align < BIGGEST_ALIGNMENT)
3245 TYPE_MAX_ALIGN (gnu_type) = max_align;
3249 /* If we have a Parent_Subtype, make a field for the parent. If
3250 this record has rep clauses, force the position to zero. */
3251 if (Present (Parent_Subtype (gnat_entity)))
3253 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
3254 tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
3255 tree gnu_parent;
3256 int parent_packed = 0;
3258 /* A major complexity here is that the parent subtype will
3259 reference our discriminants in its Stored_Constraint list.
3260 But those must reference the parent component of this record
3261 which is precisely of the parent subtype we have not built yet!
3262 To break the circle we first build a dummy COMPONENT_REF which
3263 represents the "get to the parent" operation and initialize
3264 each of those discriminants to a COMPONENT_REF of the above
3265 dummy parent referencing the corresponding discriminant of the
3266 base type of the parent subtype. */
3267 gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type,
3268 build0 (PLACEHOLDER_EXPR, gnu_type),
3269 build_decl (input_location,
3270 FIELD_DECL, NULL_TREE,
3271 gnu_dummy_parent_type),
3272 NULL_TREE);
3274 if (has_discr)
3275 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3276 Present (gnat_field);
3277 gnat_field = Next_Stored_Discriminant (gnat_field))
3278 if (Present (Corresponding_Discriminant (gnat_field)))
3280 tree gnu_field
3281 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3282 (gnat_field));
3283 save_gnu_tree
3284 (gnat_field,
3285 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3286 gnu_get_parent, gnu_field, NULL_TREE),
3287 true);
3290 /* Then we build the parent subtype. If it has discriminants but
3291 the type itself has unknown discriminants, this means that it
3292 doesn't contain information about how the discriminants are
3293 derived from those of the ancestor type, so it cannot be used
3294 directly. Instead it is built by cloning the parent subtype
3295 of the underlying record view of the type, for which the above
3296 derivation of discriminants has been made explicit. */
3297 if (Has_Discriminants (gnat_parent)
3298 && Has_Unknown_Discriminants (gnat_entity))
3300 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3302 /* If we are defining the type, the underlying record
3303 view must already have been elaborated at this point.
3304 Otherwise do it now as its parent subtype cannot be
3305 technically elaborated on its own. */
3306 if (definition)
3307 gcc_assert (present_gnu_tree (gnat_uview));
3308 else
3309 gnat_to_gnu_entity (gnat_uview, NULL_TREE, false);
3311 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3313 /* Substitute the "get to the parent" of the type for that
3314 of its underlying record view in the cloned type. */
3315 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3316 Present (gnat_field);
3317 gnat_field = Next_Stored_Discriminant (gnat_field))
3318 if (Present (Corresponding_Discriminant (gnat_field)))
3320 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3321 tree gnu_ref
3322 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3323 gnu_get_parent, gnu_field, NULL_TREE);
3324 gnu_parent
3325 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3328 else
3329 gnu_parent = gnat_to_gnu_type (gnat_parent);
3331 /* The parent field needs strict alignment so, if it is to
3332 be created with a component clause below, then we need
3333 to apply the same adjustment as in gnat_to_gnu_field. */
3334 if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
3336 /* ??? For historical reasons, we do it on strict-alignment
3337 platforms only, where it is really required. This means
3338 that a confirming representation clause will change the
3339 behavior of the compiler on the other platforms. */
3340 if (STRICT_ALIGNMENT)
3341 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
3342 else
3343 parent_packed
3344 = adjust_packed (gnu_parent, gnu_type, parent_packed);
3347 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3348 initially built. The discriminants must reference the fields
3349 of the parent subtype and not those of its base type for the
3350 placeholder machinery to properly work. */
3351 if (has_discr)
3353 /* The actual parent subtype is the full view. */
3354 if (Is_Private_Type (gnat_parent))
3356 if (Present (Full_View (gnat_parent)))
3357 gnat_parent = Full_View (gnat_parent);
3358 else
3359 gnat_parent = Underlying_Full_View (gnat_parent);
3362 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3363 Present (gnat_field);
3364 gnat_field = Next_Stored_Discriminant (gnat_field))
3365 if (Present (Corresponding_Discriminant (gnat_field)))
3367 Entity_Id field;
3368 for (field = First_Stored_Discriminant (gnat_parent);
3369 Present (field);
3370 field = Next_Stored_Discriminant (field))
3371 if (same_discriminant_p (gnat_field, field))
3372 break;
3373 gcc_assert (Present (field));
3374 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3375 = gnat_to_gnu_field_decl (field);
3379 /* The "get to the parent" COMPONENT_REF must be given its
3380 proper type... */
3381 TREE_TYPE (gnu_get_parent) = gnu_parent;
3383 /* ...and reference the _Parent field of this record. */
3384 gnu_field
3385 = create_field_decl (parent_name_id,
3386 gnu_parent, gnu_type,
3387 has_rep
3388 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3389 has_rep
3390 ? bitsize_zero_node : NULL_TREE,
3391 parent_packed, 1);
3392 DECL_INTERNAL_P (gnu_field) = 1;
3393 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3394 TYPE_FIELDS (gnu_type) = gnu_field;
3397 /* Make the fields for the discriminants and put them into the record
3398 unless it's an Unchecked_Union. */
3399 if (has_discr)
3400 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3401 Present (gnat_field);
3402 gnat_field = Next_Stored_Discriminant (gnat_field))
3404 /* If this is a record extension and this discriminant is the
3405 renaming of another discriminant, we've handled it above. */
3406 if (is_extension
3407 && Present (Corresponding_Discriminant (gnat_field)))
3408 continue;
3410 gnu_field
3411 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3412 debug_info_p);
3414 /* Make an expression using a PLACEHOLDER_EXPR from the
3415 FIELD_DECL node just created and link that with the
3416 corresponding GNAT defining identifier. */
3417 save_gnu_tree (gnat_field,
3418 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3419 build0 (PLACEHOLDER_EXPR, gnu_type),
3420 gnu_field, NULL_TREE),
3421 true);
3423 if (!is_unchecked_union)
3425 DECL_CHAIN (gnu_field) = gnu_field_list;
3426 gnu_field_list = gnu_field;
3430 /* If we have a derived untagged type that renames discriminants in
3431 the parent type, the (stored) discriminants are just a copy of the
3432 discriminants of the parent type. This means that any constraints
3433 added by the renaming in the derivation are disregarded as far as
3434 the layout of the derived type is concerned. To rescue them, we
3435 change the type of the (stored) discriminants to a subtype with
3436 the bounds of the type of the visible discriminants. */
3437 if (has_discr
3438 && !is_extension
3439 && Stored_Constraint (gnat_entity) != No_Elist)
3440 for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
3441 gnat_constr != No_Elmt;
3442 gnat_constr = Next_Elmt (gnat_constr))
3443 if (Nkind (Node (gnat_constr)) == N_Identifier
3444 /* Ignore access discriminants. */
3445 && !Is_Access_Type (Etype (Node (gnat_constr)))
3446 && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
3448 const Entity_Id gnat_discr = Entity (Node (gnat_constr));
3449 tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
3450 tree gnu_ref
3451 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
3452 NULL_TREE, false);
3454 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3455 just above for one of the stored discriminants. */
3456 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
3458 if (gnu_discr_type != TREE_TYPE (gnu_ref))
3459 TREE_TYPE (gnu_ref)
3460 = create_extra_subtype (TREE_TYPE (gnu_ref),
3461 TYPE_MIN_VALUE (gnu_discr_type),
3462 TYPE_MAX_VALUE (gnu_discr_type));
3465 /* If this is a derived type with discriminants and these discriminants
3466 affect the initial shape it has inherited, factor them in. */
3467 if (has_discr
3468 && !is_extension
3469 && !Has_Record_Rep_Clause (gnat_entity)
3470 && Stored_Constraint (gnat_entity) != No_Elist
3471 && (gnat_parent_type = Underlying_Type (Etype (gnat_entity)))
3472 && Is_Record_Type (gnat_parent_type)
3473 && Is_Unchecked_Union (gnat_entity)
3474 == Is_Unchecked_Union (gnat_parent_type)
3475 && No_Reordering (gnat_entity) == No_Reordering (gnat_parent_type))
3477 tree gnu_parent_type
3478 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type));
3480 if (TYPE_IS_PADDING_P (gnu_parent_type))
3481 gnu_parent_type = TREE_TYPE (TYPE_FIELDS (gnu_parent_type));
3483 vec<subst_pair> gnu_subst_list
3484 = build_subst_list (gnat_entity, gnat_parent_type, definition);
3486 /* Set the layout of the type to match that of the parent type,
3487 doing required substitutions. Note that, if we do not use the
3488 GNAT encodings, we don't need debug info for the inner record
3489 types, as they will be part of the embedding variant record's
3490 debug info. */
3491 copy_and_substitute_in_layout
3492 (gnat_entity, gnat_parent_type, gnu_type, gnu_parent_type,
3493 gnu_subst_list,
3494 debug_info_p && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL);
3496 else
3498 /* Add the fields into the record type and finish it up. */
3499 components_to_record (Component_List (record_definition),
3500 gnat_entity, gnu_field_list, gnu_type,
3501 packed, definition, false, all_rep,
3502 is_unchecked_union, artificial_p,
3503 debug_info_p, false,
3504 all_rep ? NULL_TREE : bitsize_zero_node,
3505 NULL);
3507 /* Empty classes have the size of a storage unit in C++. */
3508 if (TYPE_SIZE (gnu_type) == bitsize_zero_node
3509 && Convention (gnat_entity) == Convention_CPP)
3511 TYPE_SIZE (gnu_type) = bitsize_unit_node;
3512 TYPE_SIZE_UNIT (gnu_type) = size_one_node;
3513 compute_record_mode (gnu_type);
3516 /* If the type needs strict alignment, then no object of the type
3517 may have a size smaller than the natural size, which means that
3518 the RM size of the type is equal to the type size. */
3519 if (Strict_Alignment (gnat_entity))
3520 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
3522 /* If there are entities in the chain corresponding to components
3523 that we did not elaborate, ensure we elaborate their types if
3524 they are itypes. */
3525 for (gnat_temp = First_Entity (gnat_entity);
3526 Present (gnat_temp);
3527 gnat_temp = Next_Entity (gnat_temp))
3528 if ((Ekind (gnat_temp) == E_Component
3529 || Ekind (gnat_temp) == E_Discriminant)
3530 && Is_Itype (Etype (gnat_temp))
3531 && !present_gnu_tree (gnat_temp))
3532 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
3535 /* Fill in locations of fields. */
3536 annotate_rep (gnat_entity, gnu_type);
3538 break;
3540 case E_Class_Wide_Subtype:
3541 /* If an equivalent type is present, that is what we should use.
3542 Otherwise, fall through to handle this like a record subtype
3543 since it may have constraints. */
3544 if (gnat_equiv_type != gnat_entity)
3546 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
3547 maybe_present = true;
3548 break;
3551 /* ... fall through ... */
3553 case E_Record_Subtype:
3554 gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity);
3555 if (Present (gnat_cloned_subtype))
3556 break;
3558 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3559 changing the type, make a new type with each field having the type of
3560 the field in the new subtype but the position computed by transforming
3561 every discriminant reference according to the constraints. We don't
3562 see any difference between private and non-private type here since
3563 derivations from types should have been deferred until the completion
3564 of the private type. */
3565 else
3567 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3569 /* Some component may refer to this type, so defer completion of any
3570 incomplete types. We also need to do it for the special subtypes
3571 designated by access subtypes in case they are recursive, see the
3572 E_Access_Subtype case below. */
3573 if (!definition
3574 || (Is_Itype (gnat_entity)
3575 && Is_Frozen (gnat_entity)
3576 && No (Freeze_Node (gnat_entity))))
3578 defer_incomplete_level++;
3579 this_deferred = true;
3582 tree gnu_base_type
3583 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type));
3585 if (present_gnu_tree (gnat_entity))
3587 maybe_present = true;
3588 break;
3591 /* When the subtype has discriminants and these discriminants affect
3592 the initial shape it has inherited, factor them in. But for an
3593 Unchecked_Union (it must be an itype), just return the type. */
3594 if (Has_Discriminants (gnat_entity)
3595 && Stored_Constraint (gnat_entity) != No_Elist
3596 && Is_Record_Type (gnat_base_type)
3597 && !Is_Unchecked_Union (gnat_base_type))
3599 vec<subst_pair> gnu_subst_list
3600 = build_subst_list (gnat_entity, gnat_base_type, definition);
3601 tree gnu_unpad_base_type;
3603 gnu_type = make_node (RECORD_TYPE);
3604 TYPE_NAME (gnu_type) = gnu_entity_name;
3605 TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
3606 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3607 = Reverse_Storage_Order (gnat_entity);
3608 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3610 /* Set the size, alignment and alias set of the type to match
3611 those of the base type, doing required substitutions. */
3612 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3613 gnu_subst_list);
3615 if (TYPE_IS_PADDING_P (gnu_base_type))
3616 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3617 else
3618 gnu_unpad_base_type = gnu_base_type;
3620 /* Set the layout of the type to match that of the base type,
3621 doing required substitutions. We will output debug info
3622 manually below so pass false as last argument. */
3623 copy_and_substitute_in_layout (gnat_entity, gnat_base_type,
3624 gnu_type, gnu_unpad_base_type,
3625 gnu_subst_list, false);
3627 /* Fill in locations of fields. */
3628 annotate_rep (gnat_entity, gnu_type);
3630 /* If debugging information is being written for the type and if
3631 we are asked to output GNAT encodings, write a record that
3632 shows what we are a subtype of and also make a variable that
3633 indicates our size, if still variable. */
3634 if (debug_info_p
3635 && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
3637 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3638 tree gnu_unpad_base_name
3639 = TYPE_IDENTIFIER (gnu_unpad_base_type);
3640 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3642 TYPE_NAME (gnu_subtype_marker)
3643 = create_concat_name (gnat_entity, "XVS");
3644 finish_record_type (gnu_subtype_marker,
3645 create_field_decl (gnu_unpad_base_name,
3646 build_reference_type
3647 (gnu_unpad_base_type),
3648 gnu_subtype_marker,
3649 NULL_TREE, NULL_TREE,
3650 0, 0),
3651 0, true);
3653 add_parallel_type (gnu_type, gnu_subtype_marker);
3655 if (definition
3656 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3657 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3658 TYPE_SIZE_UNIT (gnu_subtype_marker)
3659 = create_var_decl (create_concat_name (gnat_entity,
3660 "XVZ"),
3661 NULL_TREE, sizetype, gnu_size_unit,
3662 true, false, false, false, false,
3663 true, true, NULL, gnat_entity, false);
3666 /* Or else, if the subtype is artificial and GNAT encodings are
3667 not used, use the base record type as the debug type. */
3668 else if (debug_info_p
3669 && artificial_p
3670 && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL)
3671 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_unpad_base_type);
3674 /* Otherwise, go down all the components in the new type and make
3675 them equivalent to those in the base type. */
3676 else
3678 gnu_type = gnu_base_type;
3680 for (gnat_temp = First_Entity (gnat_entity);
3681 Present (gnat_temp);
3682 gnat_temp = Next_Entity (gnat_temp))
3683 if ((Ekind (gnat_temp) == E_Discriminant
3684 && !Is_Unchecked_Union (gnat_base_type))
3685 || Ekind (gnat_temp) == E_Component)
3686 save_gnu_tree (gnat_temp,
3687 gnat_to_gnu_field_decl
3688 (Original_Record_Component (gnat_temp)),
3689 false);
3692 break;
3694 case E_Access_Subprogram_Type:
3695 case E_Anonymous_Access_Subprogram_Type:
3696 /* Use the special descriptor type for dispatch tables if needed,
3697 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3698 Note that we are only required to do so for static tables in
3699 order to be compatible with the C++ ABI, but Ada 2005 allows
3700 to extend library level tagged types at the local level so
3701 we do it in the non-static case as well. */
3702 if (TARGET_VTABLE_USES_DESCRIPTORS
3703 && Is_Dispatch_Table_Entity (gnat_entity))
3705 gnu_type = fdesc_type_node;
3706 gnu_size = TYPE_SIZE (gnu_type);
3707 break;
3710 /* ... fall through ... */
3712 case E_Allocator_Type:
3713 case E_Access_Type:
3714 case E_Access_Attribute_Type:
3715 case E_Anonymous_Access_Type:
3716 case E_General_Access_Type:
3718 /* The designated type and its equivalent type for gigi. */
3719 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3720 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3721 /* Whether it comes from a limited with. */
3722 const bool is_from_limited_with
3723 = (Is_Incomplete_Type (gnat_desig_equiv)
3724 && From_Limited_With (gnat_desig_equiv));
3725 /* Whether it is a completed Taft Amendment type. Such a type is to
3726 be treated as coming from a limited with clause if it is not in
3727 the main unit, i.e. we break potential circularities here in case
3728 the body of an external unit is loaded for inter-unit inlining. */
3729 const bool is_completed_taft_type
3730 = (Is_Incomplete_Type (gnat_desig_equiv)
3731 && Has_Completion_In_Body (gnat_desig_equiv)
3732 && Present (Full_View (gnat_desig_equiv)));
3733 /* The "full view" of the designated type. If this is an incomplete
3734 entity from a limited with, treat its non-limited view as the full
3735 view. Otherwise, if this is an incomplete or private type, use the
3736 full view. In the former case, we might point to a private type,
3737 in which case, we need its full view. Also, we want to look at the
3738 actual type used for the representation, so this takes a total of
3739 three steps. */
3740 Entity_Id gnat_desig_full_direct_first
3741 = (is_from_limited_with
3742 ? Non_Limited_View (gnat_desig_equiv)
3743 : (Is_Incomplete_Or_Private_Type (gnat_desig_equiv)
3744 ? Full_View (gnat_desig_equiv) : Empty));
3745 Entity_Id gnat_desig_full_direct
3746 = ((is_from_limited_with
3747 && Present (gnat_desig_full_direct_first)
3748 && Is_Private_Type (gnat_desig_full_direct_first))
3749 ? Full_View (gnat_desig_full_direct_first)
3750 : gnat_desig_full_direct_first);
3751 Entity_Id gnat_desig_full
3752 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3753 /* The type actually used to represent the designated type, either
3754 gnat_desig_full or gnat_desig_equiv. */
3755 Entity_Id gnat_desig_rep;
3756 /* We want to know if we'll be seeing the freeze node for any
3757 incomplete type we may be pointing to. */
3758 const bool in_main_unit
3759 = (Present (gnat_desig_full)
3760 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3761 : In_Extended_Main_Code_Unit (gnat_desig_type));
3762 /* True if we make a dummy type here. */
3763 bool made_dummy = false;
3764 /* The mode to be used for the pointer type. */
3765 scalar_int_mode p_mode;
3766 /* The GCC type used for the designated type. */
3767 tree gnu_desig_type = NULL_TREE;
3769 if (!int_mode_for_size (esize, 0).exists (&p_mode)
3770 || !targetm.valid_pointer_mode (p_mode))
3771 p_mode = ptr_mode;
3773 /* If either the designated type or its full view is an unconstrained
3774 array subtype, replace it with the type it's a subtype of. This
3775 avoids problems with multiple copies of unconstrained array types.
3776 Likewise, if the designated type is a subtype of an incomplete
3777 record type, use the parent type to avoid order of elaboration
3778 issues. This can lose some code efficiency, but there is no
3779 alternative. */
3780 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3781 && !Is_Constrained (gnat_desig_equiv))
3782 gnat_desig_equiv = Etype (gnat_desig_equiv);
3783 if (Present (gnat_desig_full)
3784 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3785 && !Is_Constrained (gnat_desig_full))
3786 || (Ekind (gnat_desig_full) == E_Record_Subtype
3787 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3788 gnat_desig_full = Etype (gnat_desig_full);
3790 /* Set the type that's the representation of the designated type. */
3791 gnat_desig_rep
3792 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3794 /* If we already know what the full type is, use it. */
3795 if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full))
3796 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3798 /* Get the type of the thing we are to point to and build a pointer to
3799 it. If it is a reference to an incomplete or private type with a
3800 full view that is a record, an array or an access, make a dummy type
3801 and get the actual type later when we have verified it is safe. */
3802 else if ((!in_main_unit
3803 && !present_gnu_tree (gnat_desig_equiv)
3804 && Present (gnat_desig_full)
3805 && (Is_Record_Type (gnat_desig_full)
3806 || Is_Array_Type (gnat_desig_full)
3807 || Is_Access_Type (gnat_desig_full)))
3808 /* Likewise if this is a reference to a record, an array or a
3809 subprogram type and we are to defer elaborating incomplete
3810 types. We do this because this access type may be the full
3811 view of a private type. */
3812 || ((!in_main_unit || imported_p)
3813 && defer_incomplete_level != 0
3814 && !present_gnu_tree (gnat_desig_equiv)
3815 && (Is_Record_Type (gnat_desig_rep)
3816 || Is_Array_Type (gnat_desig_rep)
3817 || Ekind (gnat_desig_rep) == E_Subprogram_Type))
3818 /* If this is a reference from a limited_with type back to our
3819 main unit and there's a freeze node for it, either we have
3820 already processed the declaration and made the dummy type,
3821 in which case we just reuse the latter, or we have not yet,
3822 in which case we make the dummy type and it will be reused
3823 when the declaration is finally processed. In both cases,
3824 the pointer eventually created below will be automatically
3825 adjusted when the freeze node is processed. */
3826 || (in_main_unit
3827 && is_from_limited_with
3828 && Present (Freeze_Node (gnat_desig_rep))))
3830 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3831 made_dummy = true;
3834 /* Otherwise handle the case of a pointer to itself. */
3835 else if (gnat_desig_equiv == gnat_entity)
3837 gnu_type
3838 = build_pointer_type_for_mode (void_type_node, p_mode,
3839 No_Strict_Aliasing (gnat_entity));
3840 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3843 /* If expansion is disabled, the equivalent type of a concurrent type
3844 is absent, so we use the void pointer type. */
3845 else if (type_annotate_only && No (gnat_desig_equiv))
3846 gnu_type = ptr_type_node;
3848 /* If the ultimately designated type is an incomplete type with no full
3849 view, we use the void pointer type in LTO mode to avoid emitting a
3850 dummy type in the GIMPLE IR. We cannot do that in regular mode as
3851 the name of the dummy type in used by GDB for a global lookup. */
3852 else if (Ekind (gnat_desig_rep) == E_Incomplete_Type
3853 && No (Full_View (gnat_desig_rep))
3854 && flag_generate_lto)
3855 gnu_type = ptr_type_node;
3857 /* Finally, handle the default case where we can just elaborate our
3858 designated type. */
3859 else
3860 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3862 /* It is possible that a call to gnat_to_gnu_type above resolved our
3863 type. If so, just return it. */
3864 if (present_gnu_tree (gnat_entity))
3866 maybe_present = true;
3867 break;
3870 /* Access-to-unconstrained-array types need a special treatment. */
3871 if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
3873 /* If the processing above got something that has a pointer, then
3874 we are done. This could have happened either because the type
3875 was elaborated or because somebody else executed the code. */
3876 if (!TYPE_POINTER_TO (gnu_desig_type))
3877 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3879 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3882 /* If we haven't done it yet, build the pointer type the usual way. */
3883 else if (!gnu_type)
3885 /* Modify the designated type if we are pointing only to constant
3886 objects, but don't do it for a dummy type. */
3887 if (Is_Access_Constant (gnat_entity)
3888 && !TYPE_IS_DUMMY_P (gnu_desig_type))
3889 gnu_desig_type
3890 = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
3892 gnu_type
3893 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3894 No_Strict_Aliasing (gnat_entity));
3897 /* If the designated type is not declared in the main unit and we made
3898 a dummy node for it, save our definition, elaborate the actual type
3899 and replace the dummy type we made with the actual one. But if we
3900 are to defer actually looking up the actual type, make an entry in
3901 the deferred list instead. If this is from a limited with, we may
3902 have to defer until the end of the current unit. */
3903 if (!in_main_unit && made_dummy)
3905 if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
3906 gnu_type
3907 = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
3909 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
3910 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3911 artificial_p, debug_info_p,
3912 gnat_entity);
3913 this_made_decl = true;
3914 gnu_type = TREE_TYPE (gnu_decl);
3915 save_gnu_tree (gnat_entity, gnu_decl, false);
3916 saved = true;
3918 if (defer_incomplete_level == 0
3919 && !is_from_limited_with
3920 && !is_completed_taft_type)
3922 update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
3923 gnat_to_gnu_type (gnat_desig_equiv));
3925 else
3927 struct incomplete *p = XNEW (struct incomplete);
3928 struct incomplete **head
3929 = (is_from_limited_with || is_completed_taft_type
3930 ? &defer_limited_with_list : &defer_incomplete_list);
3932 p->old_type = gnu_desig_type;
3933 p->full_type = gnat_desig_equiv;
3934 p->next = *head;
3935 *head = p;
3939 break;
3941 case E_Access_Protected_Subprogram_Type:
3942 case E_Anonymous_Access_Protected_Subprogram_Type:
3943 /* If we are just annotating types and have no equivalent record type,
3944 just use the void pointer type. */
3945 if (type_annotate_only && gnat_equiv_type == gnat_entity)
3946 gnu_type = ptr_type_node;
3948 /* The run-time representation is the equivalent type. */
3949 else
3951 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3952 maybe_present = true;
3955 /* The designated subtype must be elaborated as well, if it does
3956 not have its own freeze node. */
3957 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3958 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3959 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3960 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3961 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3962 NULL_TREE, false);
3964 break;
3966 case E_Access_Subtype:
3967 gnat_cloned_subtype = Gigi_Cloned_Subtype (gnat_entity);
3968 if (Present (gnat_cloned_subtype))
3969 break;
3971 /* We treat this as identical to its base type; any constraint is
3972 meaningful only to the front-end. */
3973 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3974 maybe_present = true;
3976 /* The designated subtype must be elaborated as well, if it does
3977 not have its own freeze node. */
3978 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3979 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3980 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3981 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3983 tree gnu_design_base_type
3984 = TYPE_IS_FAT_POINTER_P (gnu_type)
3985 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
3986 : TREE_TYPE (gnu_type);
3988 /* If we are to defer elaborating incomplete types, make a dummy
3989 type node and elaborate it later. */
3990 if (defer_incomplete_level != 0)
3992 struct incomplete *p = XNEW (struct incomplete);
3994 p->old_type
3995 = make_dummy_type (Directly_Designated_Type (gnat_entity));
3996 p->full_type = Directly_Designated_Type (gnat_entity);
3997 p->next = defer_incomplete_list;
3998 defer_incomplete_list = p;
4001 /* Otherwise elaborate the designated subtype only if its base type
4002 has already been elaborated. */
4003 else if (!TYPE_IS_DUMMY_P (gnu_design_base_type))
4004 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
4005 NULL_TREE, false);
4007 break;
4009 /* Subprogram Entities
4011 The following access functions are defined for subprograms:
4013 Etype Return type or Standard_Void_Type.
4014 First_Formal The first formal parameter.
4015 Is_Imported Indicates that the subprogram has appeared in
4016 an INTERFACE or IMPORT pragma. For now we
4017 assume that the external language is C.
4018 Is_Exported Likewise but for an EXPORT pragma.
4019 Is_Inlined True if the subprogram is to be inlined.
4021 Each parameter is first checked by calling must_pass_by_ref on its
4022 type to determine if it is passed by reference. For parameters which
4023 are copied in, if they are Ada In Out or Out parameters, their return
4024 value becomes part of a record which becomes the return type of the
4025 function (C function - note that this applies only to Ada procedures
4026 so there is no Ada return type). Additional code to store back the
4027 parameters will be generated on the caller side. This transformation
4028 is done here, not in the front-end.
4030 The intended result of the transformation can be seen from the
4031 equivalent source rewritings that follow:
4033 struct temp {int a,b};
4034 procedure P (A,B: In Out ...) is temp P (int A,B)
4035 begin {
4036 .. ..
4037 end P; return {A,B};
4040 temp t;
4041 P(X,Y); t = P(X,Y);
4042 X = t.a , Y = t.b;
4044 For subprogram types we need to perform mainly the same conversions to
4045 GCC form that are needed for procedures and function declarations. The
4046 only difference is that at the end, we make a type declaration instead
4047 of a function declaration. */
4049 case E_Subprogram_Type:
4050 case E_Function:
4051 case E_Procedure:
4053 tree gnu_ext_name
4054 = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name);
4055 const enum inline_status_t inline_status
4056 = inline_status_for_subprog (gnat_entity);
4057 /* Subprograms marked both Intrinsic and Always_Inline need not
4058 have a body of their own. */
4059 const bool extern_flag
4060 = ((Is_Public (gnat_entity) && !definition)
4061 || imported_p
4062 || (Is_Intrinsic_Subprogram (gnat_entity)
4063 && Has_Pragma_Inline_Always (gnat_entity)));
4064 tree gnu_param_list;
4066 /* A parameter may refer to this type, so defer completion of any
4067 incomplete types. */
4068 if (kind == E_Subprogram_Type && !definition)
4070 defer_incomplete_level++;
4071 this_deferred = true;
4074 /* If the subprogram has an alias, it is probably inherited, so
4075 we can use the original one. If the original "subprogram"
4076 is actually an enumeration literal, it may be the first use
4077 of its type, so we must elaborate that type now. */
4078 if (Present (Alias (gnat_entity)))
4080 const Entity_Id gnat_alias = Alias (gnat_entity);
4082 if (Ekind (gnat_alias) == E_Enumeration_Literal)
4083 gnat_to_gnu_entity (Etype (gnat_alias), NULL_TREE, false);
4085 gnu_decl = gnat_to_gnu_entity (gnat_alias, gnu_expr, false);
4087 /* Elaborate any itypes in the parameters of this entity. */
4088 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
4089 Present (gnat_temp);
4090 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4091 if (Is_Itype (Etype (gnat_temp)))
4092 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
4094 /* Materialize renamed subprograms in the debugging information
4095 when the renamed object is known at compile time; we consider
4096 such renamings as imported declarations.
4098 Because the parameters in generic instantiations are generally
4099 materialized as renamings, we often end up having both the
4100 renamed subprogram and the renaming in the same context and with
4101 the same name; in this case, renaming is both useless debug-wise
4102 and potentially harmful as name resolution in the debugger could
4103 return twice the same entity! So avoid this case. */
4104 if (debug_info_p
4105 && !artificial_p
4106 && (Ekind (gnat_alias) == E_Function
4107 || Ekind (gnat_alias) == E_Procedure)
4108 && !(get_debug_scope (gnat_entity, NULL)
4109 == get_debug_scope (gnat_alias, NULL)
4110 && Name_Equals (Chars (gnat_entity), Chars (gnat_alias)))
4111 && TREE_CODE (gnu_decl) == FUNCTION_DECL)
4113 tree decl = build_decl (input_location, IMPORTED_DECL,
4114 gnu_entity_name, void_type_node);
4115 IMPORTED_DECL_ASSOCIATED_DECL (decl) = gnu_decl;
4116 gnat_pushdecl (decl, gnat_entity);
4119 break;
4122 /* Get the GCC tree for the (underlying) subprogram type. If the
4123 entity is an actual subprogram, also get the parameter list. */
4124 gnu_type
4125 = gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
4126 &gnu_param_list);
4127 if (DECL_P (gnu_type))
4129 gnu_decl = gnu_type;
4130 gnu_type = TREE_TYPE (gnu_decl);
4131 process_attributes (&gnu_decl, &attr_list, true, gnat_entity);
4132 break;
4135 /* Deal with platform-specific calling conventions. */
4136 if (Has_Stdcall_Convention (gnat_entity))
4137 prepend_one_attribute
4138 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4139 get_identifier ("stdcall"), NULL_TREE,
4140 gnat_entity);
4142 /* If we should request stack realignment for a foreign convention
4143 subprogram, do so. Note that this applies to task entry points
4144 in particular. */
4145 if (FOREIGN_FORCE_REALIGN_STACK && foreign)
4146 prepend_one_attribute
4147 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4148 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4149 gnat_entity);
4151 /* Deal with a pragma Linker_Section on a subprogram. */
4152 if ((kind == E_Function || kind == E_Procedure)
4153 && Present (Linker_Section_Pragma (gnat_entity)))
4154 prepend_one_attribute_pragma (&attr_list,
4155 Linker_Section_Pragma (gnat_entity));
4157 /* If we are defining the subprogram and it has an Address clause
4158 we must get the address expression from the saved GCC tree for the
4159 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4160 the address expression here since the front-end has guaranteed
4161 in that case that the elaboration has no effects. If there is
4162 an Address clause and we are not defining the object, just
4163 make it a constant. */
4164 if (Present (Address_Clause (gnat_entity)))
4166 tree gnu_address = NULL_TREE;
4168 if (definition)
4169 gnu_address
4170 = (present_gnu_tree (gnat_entity)
4171 ? get_gnu_tree (gnat_entity)
4172 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4174 save_gnu_tree (gnat_entity, NULL_TREE, false);
4176 /* Convert the type of the object to a reference type that can
4177 alias everything as per RM 13.3(19). */
4178 gnu_type
4179 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4180 if (gnu_address)
4181 gnu_address = convert (gnu_type, gnu_address);
4183 gnu_decl
4184 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4185 gnu_address, false, Is_Public (gnat_entity),
4186 extern_flag, false, false, artificial_p,
4187 debug_info_p, NULL, gnat_entity);
4188 DECL_BY_REF_P (gnu_decl) = 1;
4191 /* If this is a mere subprogram type, just create the declaration. */
4192 else if (kind == E_Subprogram_Type)
4194 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4196 gnu_decl
4197 = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4198 debug_info_p, gnat_entity);
4201 /* Otherwise create the subprogram declaration with the external name,
4202 the type and the parameter list. However, if this a reference to
4203 the allocation routines, reuse the canonical declaration nodes as
4204 they come with special properties. */
4205 else
4207 if (extern_flag && gnu_ext_name == DECL_NAME (malloc_decl))
4208 gnu_decl = malloc_decl;
4209 else if (extern_flag && gnu_ext_name == DECL_NAME (realloc_decl))
4210 gnu_decl = realloc_decl;
4211 else
4212 gnu_decl
4213 = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4214 gnu_type, gnu_param_list, inline_status,
4215 Is_Public (gnat_entity) || imported_p,
4216 extern_flag, artificial_p, debug_info_p,
4217 definition && imported_p, attr_list,
4218 gnat_entity);
4221 break;
4223 case E_Incomplete_Type:
4224 case E_Incomplete_Subtype:
4225 case E_Private_Type:
4226 case E_Private_Subtype:
4227 case E_Limited_Private_Type:
4228 case E_Limited_Private_Subtype:
4229 case E_Record_Type_With_Private:
4230 case E_Record_Subtype_With_Private:
4232 const bool is_from_limited_with
4233 = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
4234 /* Get the "full view" of this entity. If this is an incomplete
4235 entity from a limited with, treat its non-limited view as the
4236 full view. Otherwise, use either the full view or the underlying
4237 full view, whichever is present. This is used in all the tests
4238 below. */
4239 const Entity_Id full_view
4240 = is_from_limited_with
4241 ? Non_Limited_View (gnat_entity)
4242 : Present (Full_View (gnat_entity))
4243 ? Full_View (gnat_entity)
4244 : IN (kind, Private_Kind)
4245 ? Underlying_Full_View (gnat_entity)
4246 : Empty;
4248 /* If this is an incomplete type with no full view, it must be a Taft
4249 Amendment type or an incomplete type coming from a limited context,
4250 in which cases we return a dummy type. Otherwise, we just get the
4251 type from its Etype. */
4252 if (No (full_view))
4254 if (kind == E_Incomplete_Type)
4256 gnu_type = make_dummy_type (gnat_entity);
4257 gnu_decl = TYPE_STUB_DECL (gnu_type);
4259 else
4261 gnu_decl
4262 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
4263 maybe_present = true;
4267 /* Or else, if we already made a type for the full view, reuse it. */
4268 else if (present_gnu_tree (full_view))
4269 gnu_decl = get_gnu_tree (full_view);
4271 /* Or else, if we are not defining the type or there is no freeze
4272 node on it, get the type for the full view. Likewise if this is
4273 a limited_with'ed type not declared in the main unit, which can
4274 happen for incomplete formal types instantiated on a type coming
4275 from a limited_with clause. */
4276 else if (!definition
4277 || No (Freeze_Node (full_view))
4278 || (is_from_limited_with
4279 && !In_Extended_Main_Code_Unit (full_view)))
4281 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
4282 maybe_present = true;
4285 /* Otherwise, make a dummy type entry which will be replaced later.
4286 Save it as the full declaration's type so we can do any needed
4287 updates when we see it. */
4288 else
4290 gnu_type = make_dummy_type (gnat_entity);
4291 gnu_decl = TYPE_STUB_DECL (gnu_type);
4292 if (Has_Completion_In_Body (gnat_entity))
4293 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4294 save_gnu_tree (full_view, gnu_decl, false);
4297 break;
4299 case E_Class_Wide_Type:
4300 /* Class-wide types are always transformed into their root type. */
4301 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4302 maybe_present = true;
4303 break;
4305 case E_Protected_Type:
4306 case E_Protected_Subtype:
4307 case E_Task_Type:
4308 case E_Task_Subtype:
4309 /* If we are just annotating types and have no equivalent record type,
4310 just return void_type, except for root types that have discriminants
4311 because the discriminants will very likely be used in the declarative
4312 part of the associated body so they need to be translated. */
4313 if (type_annotate_only && gnat_equiv_type == gnat_entity)
4315 if (definition
4316 && Has_Discriminants (gnat_entity)
4317 && Root_Type (gnat_entity) == gnat_entity)
4319 tree gnu_field_list = NULL_TREE;
4320 Entity_Id gnat_field;
4322 /* This is a minimal version of the E_Record_Type handling. */
4323 gnu_type = make_node (RECORD_TYPE);
4324 TYPE_NAME (gnu_type) = gnu_entity_name;
4326 for (gnat_field = First_Stored_Discriminant (gnat_entity);
4327 Present (gnat_field);
4328 gnat_field = Next_Stored_Discriminant (gnat_field))
4330 tree gnu_field
4331 = gnat_to_gnu_field (gnat_field, gnu_type, false,
4332 definition, debug_info_p);
4334 save_gnu_tree (gnat_field,
4335 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
4336 build0 (PLACEHOLDER_EXPR, gnu_type),
4337 gnu_field, NULL_TREE),
4338 true);
4340 DECL_CHAIN (gnu_field) = gnu_field_list;
4341 gnu_field_list = gnu_field;
4344 finish_record_type (gnu_type, nreverse (gnu_field_list), 0,
4345 false);
4347 else
4348 gnu_type = void_type_node;
4351 /* Concurrent types are always transformed into their record type. */
4352 else
4353 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4354 maybe_present = true;
4355 break;
4357 case E_Label:
4358 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4359 break;
4361 case E_Block:
4362 case E_Loop:
4363 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4364 we've already saved it, so we don't try to. */
4365 gnu_decl = error_mark_node;
4366 saved = true;
4367 break;
4369 case E_Abstract_State:
4370 /* This is a SPARK annotation that only reaches here when compiling in
4371 ASIS mode. */
4372 gcc_assert (type_annotate_only);
4373 gnu_decl = error_mark_node;
4374 saved = true;
4375 break;
4377 default:
4378 gcc_unreachable ();
4381 /* If this is the clone of a subtype, just reuse the cloned subtype; another
4382 approach would be to set the cloned subtype as the DECL_ORIGINAL_TYPE of
4383 the entity, which would generate a DW_TAG_typedef in the debug info, but
4384 at the cost of the duplication of the GCC type and, more annoyingly, of
4385 the need to update the copy if the cloned subtype is not complete yet. */
4386 if (Present (gnat_cloned_subtype))
4388 gnu_decl = gnat_to_gnu_entity (gnat_cloned_subtype, NULL_TREE, false);
4389 maybe_present = true;
4391 if (!TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4393 if (!Known_Alignment (gnat_entity))
4394 Copy_Alignment (gnat_entity, gnat_cloned_subtype);
4395 if (!Known_Esize (gnat_entity))
4396 Copy_Esize (gnat_entity, gnat_cloned_subtype);
4397 if (!Known_RM_Size (gnat_entity))
4398 Copy_RM_Size (gnat_entity, gnat_cloned_subtype);
4402 /* If we had a case where we evaluated another type and it might have
4403 defined this one, handle it here. */
4404 if (maybe_present && present_gnu_tree (gnat_entity))
4406 gnu_decl = get_gnu_tree (gnat_entity);
4407 saved = true;
4410 /* If we are processing a type and there is either no DECL for it or
4411 we just made one, do some common processing for the type, such as
4412 handling alignment and possible padding. */
4413 if (is_type && (!gnu_decl || this_made_decl))
4415 const bool is_by_ref = Is_By_Reference_Type (gnat_entity);
4417 gcc_assert (!TYPE_IS_DUMMY_P (gnu_type));
4419 /* Process the attributes, if not already done. Note that the type is
4420 already defined so we cannot pass true for IN_PLACE here. */
4421 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4423 /* See if a size was specified, by means of either an Object_Size or
4424 a regular Size clause, and validate it if so.
4426 ??? Don't set the size for a String_Literal since it is either
4427 confirming or we don't handle it properly (if the low bound is
4428 non-constant). */
4429 if (!gnu_size && kind != E_String_Literal_Subtype)
4431 const char *size_s = "size for %s too small{, minimum allowed is ^}";
4432 const char *type_s = is_by_ref ? "by-reference type &" : "&";
4434 if (Known_Esize (gnat_entity))
4435 gnu_size
4436 = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4437 VAR_DECL, false, false, size_s, type_s);
4439 /* ??? The test on Has_Size_Clause must be removed when "unknown" is
4440 no longer represented as Uint_0 (i.e. Use_New_Unknown_Rep). */
4441 else if (Known_RM_Size (gnat_entity)
4442 || Has_Size_Clause (gnat_entity))
4443 gnu_size
4444 = validate_size (RM_Size (gnat_entity), gnu_type, gnat_entity,
4445 TYPE_DECL, false, Has_Size_Clause (gnat_entity),
4446 size_s, type_s);
4449 /* If a size was specified, see if we can make a new type of that size
4450 by rearranging the type, for example from a fat to a thin pointer. */
4451 if (gnu_size)
4453 gnu_type
4454 = make_type_from_size (gnu_type, gnu_size,
4455 Has_Biased_Representation (gnat_entity));
4457 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4458 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4459 gnu_size = NULL_TREE;
4462 /* If the alignment has not already been processed and this is not
4463 an unconstrained array type, see if an alignment is specified.
4464 If not, we pick a default alignment for atomic objects. */
4465 if (align > 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4467 else if (Known_Alignment (gnat_entity))
4469 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4470 TYPE_ALIGN (gnu_type));
4472 /* Warn on suspiciously large alignments. This should catch
4473 errors about the (alignment,byte)/(size,bit) discrepancy. */
4474 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4476 tree size;
4478 /* If a size was specified, take it into account. Otherwise
4479 use the RM size for records or unions as the type size has
4480 already been adjusted to the alignment. */
4481 if (gnu_size)
4482 size = gnu_size;
4483 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
4484 && !TYPE_FAT_POINTER_P (gnu_type))
4485 size = rm_size (gnu_type);
4486 else
4487 size = TYPE_SIZE (gnu_type);
4489 /* Consider an alignment as suspicious if the alignment/size
4490 ratio is greater or equal to the byte/bit ratio. */
4491 if (tree_fits_uhwi_p (size)
4492 && align >= tree_to_uhwi (size) * BITS_PER_UNIT)
4493 post_error_ne ("??suspiciously large alignment specified for&",
4494 Expression (Alignment_Clause (gnat_entity)),
4495 gnat_entity);
4498 else if (Is_Full_Access (gnat_entity) && !gnu_size
4499 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
4500 && integer_pow2p (TYPE_SIZE (gnu_type)))
4501 align = MIN (BIGGEST_ALIGNMENT,
4502 tree_to_uhwi (TYPE_SIZE (gnu_type)));
4503 else if (Is_Full_Access (gnat_entity) && gnu_size
4504 && tree_fits_uhwi_p (gnu_size)
4505 && integer_pow2p (gnu_size))
4506 align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
4508 /* See if we need to pad the type. If we did and built a new type,
4509 then create a stripped-down declaration for the original type,
4510 mainly for debugging, unless there was already one. */
4511 if (gnu_size || align > 0)
4513 tree orig_type = gnu_type;
4515 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4516 false, definition, false);
4518 if (gnu_type != orig_type && !gnu_decl)
4519 create_type_decl (gnu_entity_name, orig_type, true, debug_info_p,
4520 gnat_entity);
4523 /* Now set the RM size of the type. We cannot do it before padding
4524 because we need to accept arbitrary RM sizes on integral types. */
4525 if (Known_RM_Size (gnat_entity))
4526 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4528 /* Back-annotate the alignment of the type if not already set. */
4529 if (!Known_Alignment (gnat_entity))
4531 unsigned int double_align, align;
4532 bool is_capped_double, align_clause;
4534 /* If the default alignment of "double" or larger scalar types is
4535 specifically capped and this is not an array with an alignment
4536 clause on the component type, return the cap. */
4537 if ((double_align = double_float_alignment) > 0)
4538 is_capped_double
4539 = is_double_float_or_array (gnat_entity, &align_clause);
4540 else if ((double_align = double_scalar_alignment) > 0)
4541 is_capped_double
4542 = is_double_scalar_or_array (gnat_entity, &align_clause);
4543 else
4544 is_capped_double = align_clause = false;
4546 if (is_capped_double && !align_clause)
4547 align = double_align;
4548 else
4549 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4551 Set_Alignment (gnat_entity, UI_From_Int (align));
4554 /* Likewise for the size, if any. */
4555 if (!Known_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4557 tree size = TYPE_SIZE (gnu_type);
4559 /* If the size is self-referential, annotate the maximum value
4560 after saturating it, if need be, to avoid a No_Uint value.
4561 But do not do it for cases where Analyze_Object_Declaration
4562 in Sem_Ch3 would build a default subtype for objects. */
4563 if (CONTAINS_PLACEHOLDER_P (size)
4564 && !Is_Limited_Record (gnat_entity)
4565 && !Is_Concurrent_Type (gnat_entity))
4567 const unsigned int align
4568 = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
4569 size = maybe_saturate_size (max_size (size, true), align);
4572 /* If we are just annotating types and the type is tagged, the tag
4573 and the parent components are not generated by the front-end so
4574 alignment and sizes must be adjusted. */
4575 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4577 const bool derived_p = Is_Derived_Type (gnat_entity);
4578 const Entity_Id gnat_parent
4579 = derived_p ? Etype (Base_Type (gnat_entity)) : Empty;
4580 /* The following test for Known_Alignment preserves the old behavior,
4581 but is probably wrong. */
4582 const unsigned int inherited_align
4583 = derived_p
4584 ? (Known_Alignment (gnat_parent)
4585 ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT
4586 : 0)
4587 : POINTER_SIZE;
4588 const unsigned int align
4589 = MAX (TYPE_ALIGN (gnu_type), inherited_align);
4591 Set_Alignment (gnat_entity, UI_From_Int (align / BITS_PER_UNIT));
4593 /* If there is neither size clause nor representation clause, the
4594 sizes need to be adjusted. */
4595 if (!Known_RM_Size (gnat_entity)
4596 && !VOID_TYPE_P (gnu_type)
4597 && (!TYPE_FIELDS (gnu_type)
4598 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
4600 tree offset
4601 = derived_p
4602 ? UI_To_gnu (Esize (gnat_parent), bitsizetype)
4603 : bitsize_int (POINTER_SIZE);
4604 if (TYPE_FIELDS (gnu_type))
4605 offset
4606 = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type)));
4607 size = size_binop (PLUS_EXPR, size, offset);
4610 size = maybe_saturate_size (round_up (size, align), align);
4611 Set_Esize (gnat_entity, annotate_value (size));
4613 /* Tagged types are Strict_Alignment so RM_Size = Esize. */
4614 if (!Known_RM_Size (gnat_entity))
4615 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4618 /* Otherwise no adjustment is needed. */
4619 else
4620 Set_Esize (gnat_entity, No_Uint_To_0 (annotate_value (size)));
4623 /* Likewise for the RM size, if any. */
4624 if (!Known_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
4625 Set_RM_Size (gnat_entity,
4626 annotate_value (rm_size (gnu_type)));
4628 /* If we are at global level, GCC applied variable_size to the size but
4629 this has done nothing. So, if it's not constant or self-referential,
4630 call elaborate_expression_1 to make a variable for it rather than
4631 calculating it each time. */
4632 if (TYPE_SIZE (gnu_type)
4633 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4634 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
4635 && global_bindings_p ())
4637 tree orig_size = TYPE_SIZE (gnu_type);
4639 TYPE_SIZE (gnu_type)
4640 = elaborate_expression_1 (TYPE_SIZE (gnu_type), gnat_entity,
4641 "SIZE", definition, false);
4643 /* ??? For now, store the size as a multiple of the alignment in
4644 bytes so that we can see the alignment from the tree. */
4645 TYPE_SIZE_UNIT (gnu_type)
4646 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4647 "SIZE_A_UNIT", definition, false,
4648 TYPE_ALIGN (gnu_type));
4650 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4651 may not be marked by the call to create_type_decl below. */
4652 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4654 /* For a record type, deal with the variant part, if any, and handle
4655 the Ada size as well. */
4656 if (RECORD_OR_UNION_TYPE_P (gnu_type))
4658 tree variant_part = get_variant_part (gnu_type);
4659 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4661 if (variant_part)
4663 tree union_type = TREE_TYPE (variant_part);
4664 tree offset = DECL_FIELD_OFFSET (variant_part);
4666 /* If the position of the variant part is constant, subtract
4667 it from the size of the type of the parent to get the new
4668 size. This manual CSE reduces the data size. */
4669 if (TREE_CODE (offset) == INTEGER_CST)
4671 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4672 TYPE_SIZE (union_type)
4673 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4674 bit_from_pos (offset, bitpos));
4675 TYPE_SIZE_UNIT (union_type)
4676 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4677 byte_from_pos (offset, bitpos));
4679 else
4681 TYPE_SIZE (union_type)
4682 = elaborate_expression_1 (TYPE_SIZE (union_type),
4683 gnat_entity, "VSIZE",
4684 definition, false);
4686 /* ??? For now, store the size as a multiple of the
4687 alignment in bytes so that we can see the alignment
4688 from the tree. */
4689 TYPE_SIZE_UNIT (union_type)
4690 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4691 gnat_entity, "VSIZE_A_UNIT",
4692 definition, false,
4693 TYPE_ALIGN (union_type));
4695 /* ??? For now, store the offset as a multiple of the
4696 alignment in bytes so that we can see the alignment
4697 from the tree. */
4698 DECL_FIELD_OFFSET (variant_part)
4699 = elaborate_expression_2 (offset, gnat_entity,
4700 "VOFFSET", definition, false,
4701 DECL_OFFSET_ALIGN
4702 (variant_part));
4705 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4706 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4709 if (operand_equal_p (ada_size, orig_size, 0))
4710 ada_size = TYPE_SIZE (gnu_type);
4711 else
4712 ada_size
4713 = elaborate_expression_1 (ada_size, gnat_entity, "RM_SIZE",
4714 definition, false);
4715 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4719 /* Similarly, if this is a record type or subtype at global level, call
4720 elaborate_expression_2 on any field position. Skip any fields that
4721 we haven't made trees for to avoid problems with class-wide types. */
4722 if (Is_In_Record_Kind (kind) && global_bindings_p ())
4723 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4724 gnat_temp = Next_Entity (gnat_temp))
4725 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4727 tree gnu_field = get_gnu_tree (gnat_temp);
4729 /* ??? For now, store the offset as a multiple of the alignment
4730 in bytes so that we can see the alignment from the tree. */
4731 if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field))
4732 && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4734 DECL_FIELD_OFFSET (gnu_field)
4735 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4736 gnat_temp, "OFFSET", definition,
4737 false,
4738 DECL_OFFSET_ALIGN (gnu_field));
4740 /* ??? The context of gnu_field is not necessarily gnu_type
4741 so the MULT_EXPR node built above may not be marked by
4742 the call to create_type_decl below. */
4743 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4747 /* Now check if the type allows atomic access. */
4748 if (Is_Full_Access (gnat_entity))
4749 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
4751 /* If this is not an unconstrained array type, set some flags. */
4752 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4754 bool align_clause;
4756 /* Record the property that objects of tagged types are guaranteed to
4757 be properly aligned. This is necessary because conversions to the
4758 class-wide type are translated into conversions to the root type,
4759 which can be less aligned than some of its derived types. */
4760 if (Is_Tagged_Type (gnat_entity)
4761 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4762 TYPE_ALIGN_OK (gnu_type) = 1;
4764 /* Record whether the type is passed by reference. */
4765 if (is_by_ref && !VOID_TYPE_P (gnu_type))
4766 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4768 /* Record whether an alignment clause was specified. At this point
4769 scalar types with a non-confirming clause have been wrapped into
4770 a record type, so only scalar types with a confirming clause are
4771 left untouched; we do not set the flag on them except if they are
4772 types whose default alignment is specifically capped in order not
4773 to lose the specified alignment. */
4774 if ((AGGREGATE_TYPE_P (gnu_type)
4775 && Present (Alignment_Clause (gnat_entity)))
4776 || (double_float_alignment > 0
4777 && is_double_float_or_array (gnat_entity, &align_clause)
4778 && align_clause)
4779 || (double_scalar_alignment > 0
4780 && is_double_scalar_or_array (gnat_entity, &align_clause)
4781 && align_clause))
4782 TYPE_USER_ALIGN (gnu_type) = 1;
4784 /* Record whether a pragma Universal_Aliasing was specified. Also
4785 consider that it is always present on interface types because,
4786 while they are abstract tagged types and thus no object of these
4787 types exists anywhere, they are used to access objects of types
4788 that implement them. */
4789 if ((Universal_Aliasing (gnat_entity) || Is_Interface (gnat_entity))
4790 && !TYPE_IS_DUMMY_P (gnu_type))
4792 /* Set TYPE_TYPELESS_STORAGE if this is an aggregate type and
4793 TYPE_UNIVERSAL_ALIASING_P otherwise, since the former is not
4794 available in the latter case Both will effectively put alias
4795 set 0 on the type, but the former is more robust because it
4796 will be streamed in LTO mode. */
4797 if (AGGREGATE_TYPE_P (gnu_type))
4798 set_typeless_storage_on_aggregate_type (gnu_type);
4799 else
4800 set_universal_aliasing_on_type (gnu_type);
4803 /* If it is passed by reference, force BLKmode to ensure that
4804 objects of this type will always be put in memory. */
4805 if (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
4806 SET_TYPE_MODE (gnu_type, BLKmode);
4809 /* If this is a derived type, relate its alias set to that of its parent
4810 to avoid troubles when a call to an inherited primitive is inlined in
4811 a context where a derived object is accessed. The inlined code works
4812 on the parent view so the resulting code may access the same object
4813 using both the parent and the derived alias sets, which thus have to
4814 conflict. As the same issue arises with component references, the
4815 parent alias set also has to conflict with composite types enclosing
4816 derived components. For instance, if we have:
4818 type D is new T;
4819 type R is record
4820 Component : D;
4821 end record;
4823 we want T to conflict with both D and R, in addition to R being a
4824 superset of D by record/component construction.
4826 One way to achieve this is to perform an alias set copy from the
4827 parent to the derived type. This is not quite appropriate, though,
4828 as we don't want separate derived types to conflict with each other:
4830 type I1 is new Integer;
4831 type I2 is new Integer;
4833 We want I1 and I2 to both conflict with Integer but we do not want
4834 I1 to conflict with I2, and an alias set copy on derivation would
4835 have that effect.
4837 The option chosen is to make the alias set of the derived type a
4838 superset of that of its parent type. It trivially fulfills the
4839 simple requirement for the Integer derivation example above, and
4840 the component case as well by superset transitivity:
4842 superset superset
4843 R ----------> D ----------> T
4845 However, for composite types, conversions between derived types are
4846 translated into VIEW_CONVERT_EXPRs so a sequence like:
4848 type Comp1 is new Comp;
4849 type Comp2 is new Comp;
4850 procedure Proc (C : Comp1);
4852 C : Comp2;
4853 Proc (Comp1 (C));
4855 is translated into:
4857 C : Comp2;
4858 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4860 and gimplified into:
4862 C : Comp2;
4863 Comp1 *C.0;
4864 C.0 = (Comp1 *) &C;
4865 Proc (C.0);
4867 i.e. generates code involving type punning. Therefore, Comp1 needs
4868 to conflict with Comp2 and an alias set copy is required.
4870 The language rules ensure the parent type is already frozen here. */
4871 if (kind != E_Subprogram_Type
4872 && Is_Derived_Type (gnat_entity)
4873 && !type_annotate_only)
4875 Entity_Id gnat_parent_type = Underlying_Type (Etype (gnat_entity));
4876 /* For constrained packed array subtypes, the implementation type is
4877 used instead of the nominal type. */
4878 if (kind == E_Array_Subtype
4879 && Is_Constrained (gnat_entity)
4880 && Present (Packed_Array_Impl_Type (gnat_parent_type)))
4881 gnat_parent_type = Packed_Array_Impl_Type (gnat_parent_type);
4882 relate_alias_sets (gnu_type, gnat_to_gnu_type (gnat_parent_type),
4883 Is_Composite_Type (gnat_entity)
4884 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4887 /* Finally get to the appropriate variant, except for the implementation
4888 type of a packed array because the GNU type might be further adjusted
4889 when the original array type is itself processed. */
4890 if (Treat_As_Volatile (gnat_entity)
4891 && !Is_Packed_Array_Impl_Type (gnat_entity))
4893 const int quals
4894 = TYPE_QUAL_VOLATILE
4895 | (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
4896 /* This is required by free_lang_data_in_type to disable the ODR. */
4897 if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
4898 TYPE_STUB_DECL (gnu_type)
4899 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
4900 gnu_type = change_qualified_type (gnu_type, quals);
4903 /* If we already made a decl, just set the type, otherwise create it. */
4904 if (gnu_decl)
4906 TREE_TYPE (gnu_decl) = gnu_type;
4907 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4909 else
4910 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4911 debug_info_p, gnat_entity);
4914 /* If we haven't already, associate the ..._DECL node that we just made with
4915 the input GNAT entity node. */
4916 if (!saved)
4917 save_gnu_tree (gnat_entity, gnu_decl, false);
4919 /* Now we are sure gnat_entity has a corresponding ..._DECL node,
4920 eliminate as many deferred computations as possible. */
4921 process_deferred_decl_context (false);
4923 /* If this is an enumeration or floating-point type, we were not able to set
4924 the bounds since they refer to the type. These are always static. */
4925 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4926 || (kind == E_Floating_Point_Type))
4928 tree gnu_scalar_type = gnu_type;
4929 tree gnu_low_bound, gnu_high_bound;
4931 /* If this is a padded type, we need to use the underlying type. */
4932 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4933 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4935 /* If this is a floating point type and we haven't set a floating
4936 point type yet, use this in the evaluation of the bounds. */
4937 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4938 longest_float_type_node = gnu_scalar_type;
4940 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4941 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4943 if (kind == E_Enumeration_Type)
4945 /* Enumeration types have specific RM bounds. */
4946 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4947 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4949 else
4951 /* Floating-point types don't have specific RM bounds. */
4952 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4953 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4957 /* If we deferred processing of incomplete types, re-enable it. If there
4958 were no other disables and we have deferred types to process, do so. */
4959 if (this_deferred
4960 && --defer_incomplete_level == 0
4961 && defer_incomplete_list)
4963 struct incomplete *p, *next;
4965 /* We are back to level 0 for the deferring of incomplete types.
4966 But processing these incomplete types below may itself require
4967 deferring, so preserve what we have and restart from scratch. */
4968 p = defer_incomplete_list;
4969 defer_incomplete_list = NULL;
4971 for (; p; p = next)
4973 next = p->next;
4975 if (p->old_type)
4976 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4977 gnat_to_gnu_type (p->full_type));
4978 free (p);
4982 /* If we are not defining this type, see if it's on one of the lists of
4983 incomplete types. If so, handle the list entry now. */
4984 if (is_type && !definition)
4986 struct incomplete *p;
4988 for (p = defer_incomplete_list; p; p = p->next)
4989 if (p->old_type && p->full_type == gnat_entity)
4991 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4992 TREE_TYPE (gnu_decl));
4993 p->old_type = NULL_TREE;
4996 for (p = defer_limited_with_list; p; p = p->next)
4997 if (p->old_type
4998 && (Non_Limited_View (p->full_type) == gnat_entity
4999 || Full_View (p->full_type) == gnat_entity))
5001 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5002 TREE_TYPE (gnu_decl));
5003 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
5004 update_profiles_with (p->old_type);
5005 p->old_type = NULL_TREE;
5009 if (this_global)
5010 force_global--;
5012 /* If this is a packed array type whose original array type is itself
5013 an itype without freeze node, make sure the latter is processed. */
5014 if (Is_Packed_Array_Impl_Type (gnat_entity)
5015 && Is_Itype (Original_Array_Type (gnat_entity))
5016 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
5017 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
5018 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, false);
5020 return gnu_decl;
5023 /* Similar, but if the returned value is a COMPONENT_REF, return the
5024 FIELD_DECL. */
5026 tree
5027 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
5029 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5031 if (TREE_CODE (gnu_field) == COMPONENT_REF)
5032 gnu_field = TREE_OPERAND (gnu_field, 1);
5034 return gnu_field;
5037 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5038 the GCC type corresponding to that entity. */
5040 tree
5041 gnat_to_gnu_type (Entity_Id gnat_entity)
5043 tree gnu_decl;
5045 /* The back end never attempts to annotate generic types. */
5046 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
5047 return void_type_node;
5049 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5050 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
5052 return TREE_TYPE (gnu_decl);
5055 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
5056 the unpadded version of the GCC type corresponding to that entity. */
5058 tree
5059 get_unpadded_type (Entity_Id gnat_entity)
5061 tree type = gnat_to_gnu_type (gnat_entity);
5063 if (TYPE_IS_PADDING_P (type))
5064 type = TREE_TYPE (TYPE_FIELDS (type));
5066 return type;
5069 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
5070 a C++ imported method or equivalent.
5072 We use the predicate to find out whether we need to use METHOD_TYPE instead
5073 of FUNCTION_TYPE for GNAT_ENTITY for the sake compatibility with C++. This
5074 in turn determines whether the "thiscall" calling convention is used by the
5075 back-end for GNAT_ENTITY on 32-bit x86/Windows. */
5077 static bool
5078 is_cplusplus_method (Entity_Id gnat_entity)
5080 /* A constructor is a method on the C++ side. We deal with it now because
5081 it is declared without the 'this' parameter in the sources and, although
5082 the front-end will create a version with the 'this' parameter for code
5083 generation purposes, we want to return true for both versions. */
5084 if (Is_Constructor (gnat_entity))
5085 return true;
5087 /* Check that the subprogram has C++ convention. */
5088 if (Convention (gnat_entity) != Convention_CPP)
5089 return false;
5091 /* And that the type of the first parameter (indirectly) has it too, but
5092 we make an exception for Interfaces because they need not be imported. */
5093 Entity_Id gnat_first = First_Formal (gnat_entity);
5094 if (No (gnat_first))
5095 return false;
5096 Entity_Id gnat_type = Etype (gnat_first);
5097 if (Is_Access_Type (gnat_type))
5098 gnat_type = Directly_Designated_Type (gnat_type);
5099 if (Convention (gnat_type) != Convention_CPP && !Is_Interface (gnat_type))
5100 return false;
5102 /* This is the main case: a C++ virtual method imported as a primitive
5103 operation of a tagged type. */
5104 if (Is_Dispatching_Operation (gnat_entity))
5105 return true;
5107 /* This is set on the E_Subprogram_Type built for a dispatching call. */
5108 if (Is_Dispatch_Table_Entity (gnat_entity))
5109 return true;
5111 /* A thunk needs to be handled like its associated primitive operation. */
5112 if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
5113 return true;
5115 /* Now on to the annoying case: a C++ non-virtual method, imported either
5116 as a non-primitive operation of a tagged type or as a primitive operation
5117 of an untagged type. We cannot reliably differentiate these cases from
5118 their static member or regular function equivalents in Ada, so we ask
5119 the C++ side through the mangled name of the function, as the implicit
5120 'this' parameter is not encoded in the mangled name of a method. */
5121 if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
5123 String_Template temp = { 0, 0 };
5124 String_Pointer sp = { "", &temp };
5125 Get_External_Name (gnat_entity, false, sp);
5127 void *mem;
5128 struct demangle_component *cmp
5129 = cplus_demangle_v3_components (Name_Buffer,
5130 DMGL_GNU_V3
5131 | DMGL_TYPES
5132 | DMGL_PARAMS
5133 | DMGL_RET_DROP,
5134 &mem);
5135 if (!cmp)
5136 return false;
5138 /* We need to release MEM once we have a successful demangling. */
5139 bool ret = false;
5141 if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
5142 && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
5143 && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
5144 && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
5146 /* Make sure there is at least one parameter in C++ too. */
5147 if (cmp->u.s_binary.left)
5149 unsigned int n_ada_args = 0;
5150 do {
5151 n_ada_args++;
5152 gnat_first = Next_Formal (gnat_first);
5153 } while (Present (gnat_first));
5155 unsigned int n_cpp_args = 0;
5156 do {
5157 n_cpp_args++;
5158 cmp = cmp->u.s_binary.right;
5159 } while (cmp);
5161 if (n_cpp_args < n_ada_args)
5162 ret = true;
5164 else
5165 ret = true;
5168 free (mem);
5170 return ret;
5173 return false;
5176 /* Return the inlining status of the GNAT subprogram SUBPROG. */
5178 static enum inline_status_t
5179 inline_status_for_subprog (Entity_Id subprog)
5181 if (Has_Pragma_No_Inline (subprog))
5182 return is_suppressed;
5184 if (Has_Pragma_Inline_Always (subprog))
5185 return is_required;
5187 if (Is_Inlined (subprog))
5189 tree gnu_type;
5191 /* This is a kludge to work around a pass ordering issue: for small
5192 record types with many components, i.e. typically bitfields, the
5193 initialization routine can contain many assignments that will be
5194 merged by the GIMPLE store merging pass. But this pass runs very
5195 late in the pipeline, in particular after the inlining decisions
5196 are made, so the inlining heuristics cannot take its outcome into
5197 account. Therefore, we optimistically override the heuristics for
5198 the initialization routine in this case. */
5199 if (Is_Init_Proc (subprog)
5200 && flag_store_merging
5201 && Is_Record_Type (Etype (First_Formal (subprog)))
5202 && (gnu_type = gnat_to_gnu_type (Etype (First_Formal (subprog))))
5203 && !TYPE_IS_BY_REFERENCE_P (gnu_type)
5204 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
5205 && compare_tree_int (TYPE_SIZE (gnu_type), MAX_FIXED_MODE_SIZE) <= 0)
5206 return is_prescribed;
5208 /* If this is an expression function and we're not optimizing for size,
5209 override the heuristics, unless -gnatd.8 is specified. */
5210 if (Is_Expression_Function (subprog)
5211 && !optimize_size
5212 && !Debug_Flag_Dot_8)
5213 return is_prescribed;
5215 return is_requested;
5218 return is_default;
5221 /* Finalize the processing of From_Limited_With incomplete types. */
5223 void
5224 finalize_from_limited_with (void)
5226 struct incomplete *p, *next;
5228 p = defer_limited_with_list;
5229 defer_limited_with_list = NULL;
5231 for (; p; p = next)
5233 next = p->next;
5235 if (p->old_type)
5237 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
5238 gnat_to_gnu_type (p->full_type));
5239 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
5240 update_profiles_with (p->old_type);
5243 free (p);
5247 /* Return the cloned subtype to be used for GNAT_ENTITY, if the latter is a
5248 kind of subtype that needs to be considered as a clone by Gigi, otherwise
5249 return Empty. */
5251 static Entity_Id
5252 Gigi_Cloned_Subtype (Entity_Id gnat_entity)
5254 Node_Id gnat_decl;
5256 switch (Ekind (gnat_entity))
5258 case E_Class_Wide_Subtype:
5259 if (Present (Equivalent_Type (gnat_entity)))
5260 return Empty;
5262 /* ... fall through ... */
5264 case E_Record_Subtype:
5265 /* If Cloned_Subtype is Present, this means that this record subtype has
5266 the same layout as that of the specified (sub)type, and also that the
5267 front-end guarantees that the component list is shared. */
5268 return Cloned_Subtype (gnat_entity);
5270 case E_Access_Subtype:
5271 case E_Array_Subtype:
5272 case E_Signed_Integer_Subtype:
5273 case E_Enumeration_Subtype:
5274 case E_Modular_Integer_Subtype:
5275 case E_Ordinary_Fixed_Point_Subtype:
5276 case E_Decimal_Fixed_Point_Subtype:
5277 case E_Floating_Point_Subtype:
5278 if (Sloc (gnat_entity) == Standard_Location)
5279 break;
5281 /* We return true for the subtypes generated for the actuals of formal
5282 private types in instantiations, so that these actuals are the types
5283 of the instantiated objects in the debug info. */
5284 gnat_decl = Declaration_Node (gnat_entity);
5285 if (Present (gnat_decl)
5286 && Nkind (gnat_decl) == N_Subtype_Declaration
5287 && Present (Generic_Parent_Type (gnat_decl))
5288 && Is_Entity_Name (Subtype_Indication (gnat_decl)))
5289 return Entity (Subtype_Indication (gnat_decl));
5291 /* Likewise for the full view of such subtypes when they are private. */
5292 if (Is_Itype (gnat_entity))
5294 gnat_decl = Associated_Node_For_Itype (gnat_entity);
5295 if (Present (gnat_decl)
5296 && Nkind (gnat_decl) == N_Subtype_Declaration
5297 && Is_Private_Type (Defining_Identifier (gnat_decl))
5298 && Full_View (Defining_Identifier (gnat_decl)) == gnat_entity
5299 && Present (Generic_Parent_Type (gnat_decl))
5300 && Is_Entity_Name (Subtype_Indication (gnat_decl)))
5301 return Entity (Subtype_Indication (gnat_decl));
5303 break;
5305 default:
5306 break;
5309 return Empty;
5312 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind
5313 of type (such E_Task_Type) that has a different type which Gigi uses
5314 for its representation. If the type does not have a special type for
5315 its representation, return GNAT_ENTITY. */
5317 Entity_Id
5318 Gigi_Equivalent_Type (Entity_Id gnat_entity)
5320 Entity_Id gnat_equiv = gnat_entity;
5322 if (No (gnat_entity))
5323 return gnat_entity;
5325 switch (Ekind (gnat_entity))
5327 case E_Class_Wide_Subtype:
5328 if (Present (Equivalent_Type (gnat_entity)))
5329 gnat_equiv = Equivalent_Type (gnat_entity);
5330 break;
5332 case E_Access_Protected_Subprogram_Type:
5333 case E_Anonymous_Access_Protected_Subprogram_Type:
5334 if (Present (Equivalent_Type (gnat_entity)))
5335 gnat_equiv = Equivalent_Type (gnat_entity);
5336 break;
5338 case E_Access_Subtype:
5339 gnat_equiv = Etype (gnat_entity);
5340 break;
5342 case E_Array_Subtype:
5343 if (!Is_Constrained (gnat_entity))
5344 gnat_equiv = Etype (gnat_entity);
5345 break;
5347 case E_Class_Wide_Type:
5348 gnat_equiv = Root_Type (gnat_entity);
5349 break;
5351 case E_Protected_Type:
5352 case E_Protected_Subtype:
5353 case E_Task_Type:
5354 case E_Task_Subtype:
5355 if (Present (Corresponding_Record_Type (gnat_entity)))
5356 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5357 break;
5359 default:
5360 break;
5363 return gnat_equiv;
5366 /* Return a GCC tree for a type corresponding to the component type of the
5367 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5368 is for an array being defined. DEBUG_INFO_P is true if we need to write
5369 debug information for other types that we may create in the process. */
5371 static tree
5372 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5373 bool debug_info_p)
5375 const Entity_Id gnat_type = Component_Type (gnat_array);
5376 const bool is_bit_packed = Is_Bit_Packed_Array (gnat_array);
5377 tree gnu_type = gnat_to_gnu_type (gnat_type);
5378 tree gnu_comp_size;
5379 bool has_packed_components;
5380 unsigned int max_align;
5382 /* If an alignment is specified, use it as a cap on the component type
5383 so that it can be honored for the whole type, but ignore it for the
5384 original type of packed array types. */
5385 if (No (Packed_Array_Impl_Type (gnat_array))
5386 && Known_Alignment (gnat_array))
5387 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5388 else
5389 max_align = 0;
5391 /* Try to get a packable form of the component if needed. */
5392 if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
5393 && !is_bit_packed
5394 && !Has_Aliased_Components (gnat_array)
5395 && !Strict_Alignment (gnat_type)
5396 && RECORD_OR_UNION_TYPE_P (gnu_type)
5397 && !TYPE_FAT_POINTER_P (gnu_type)
5398 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
5400 gnu_type = make_packable_type (gnu_type, false, max_align);
5401 has_packed_components = true;
5403 else
5404 has_packed_components = is_bit_packed;
5406 /* Get and validate any specified Component_Size. */
5407 gnu_comp_size
5408 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5409 has_packed_components ? TYPE_DECL : VAR_DECL, true,
5410 Has_Component_Size_Clause (gnat_array), NULL, NULL);
5412 /* If the component type is a RECORD_TYPE that has a self-referential size,
5413 then use the maximum size for the component size. */
5414 if (!gnu_comp_size
5415 && TREE_CODE (gnu_type) == RECORD_TYPE
5416 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5417 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5419 /* If the array has aliased components and the component size is zero, force
5420 the unit size to ensure that the components have distinct addresses. */
5421 if (!gnu_comp_size
5422 && Has_Aliased_Components (gnat_array)
5423 && integer_zerop (TYPE_SIZE (gnu_type)))
5424 gnu_comp_size = bitsize_unit_node;
5426 /* Honor the component size. This is not needed for bit-packed arrays. */
5427 if (gnu_comp_size && !is_bit_packed)
5429 tree orig_type = gnu_type;
5430 unsigned int gnu_comp_align;
5432 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5433 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5434 gnu_type = orig_type;
5435 else
5436 orig_type = gnu_type;
5438 /* We need to make sure that the size is a multiple of the alignment.
5439 But we do not misalign the component type because of the alignment
5440 of the array type here; this either must have been done earlier in
5441 the packed case or should be rejected in the non-packed case. */
5442 if (TREE_CODE (gnu_comp_size) == INTEGER_CST)
5444 const unsigned HOST_WIDE_INT int_size = tree_to_uhwi (gnu_comp_size);
5445 gnu_comp_align = int_size & -int_size;
5446 if (gnu_comp_align > TYPE_ALIGN (gnu_type))
5447 gnu_comp_align = 0;
5449 else
5450 gnu_comp_align = 0;
5452 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, gnu_comp_align,
5453 gnat_array, true, definition, true);
5455 /* If a padding record was made, declare it now since it will never be
5456 declared otherwise. This is necessary to ensure that its subtrees
5457 are properly marked. */
5458 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5459 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5460 gnat_array);
5463 /* This is a very special case where the array has aliased components and the
5464 component size might be zero at run time. As explained above, we force at
5465 least the unit size but we don't want to build a distinct padding type for
5466 each invocation (they are not canonicalized if they have variable size) so
5467 we cache this special padding type as TYPE_PADDING_FOR_COMPONENT. */
5468 else if (Has_Aliased_Components (gnat_array)
5469 && TREE_CODE (gnu_type) == ARRAY_TYPE
5470 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))
5472 if (TYPE_PADDING_FOR_COMPONENT (gnu_type))
5473 gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
5474 else
5476 gnu_comp_size
5477 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5478 TYPE_PADDING_FOR_COMPONENT (gnu_type)
5479 = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5480 true, definition, true);
5481 gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
5482 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5483 gnat_array);
5487 /* Now check if the type of the component allows atomic access. */
5488 if (Has_Atomic_Components (gnat_array) || Is_Full_Access (gnat_type))
5489 check_ok_for_atomic_type (gnu_type, gnat_array, true);
5491 /* If the component type is a padded type made for a non-bit-packed array
5492 of scalars with reverse storage order, we need to propagate the reverse
5493 storage order to the padding type since it is the innermost enclosing
5494 aggregate type around the scalar. */
5495 if (TYPE_IS_PADDING_P (gnu_type)
5496 && !is_bit_packed
5497 && Reverse_Storage_Order (gnat_array)
5498 && Is_Scalar_Type (gnat_type))
5499 gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
5501 if (Has_Volatile_Components (gnat_array))
5503 const int quals
5504 = TYPE_QUAL_VOLATILE
5505 | (Has_Atomic_Components (gnat_array) ? TYPE_QUAL_ATOMIC : 0);
5506 gnu_type = change_qualified_type (gnu_type, quals);
5509 return gnu_type;
5512 /* Return whether TYPE requires that formal parameters of TYPE be initialized
5513 when they are Out parameters passed by copy.
5515 This just implements the set of conditions listed in RM 6.4.1(12). */
5517 static bool
5518 type_requires_init_of_formal (Entity_Id type)
5520 type = Underlying_Type (type);
5522 if (Is_Access_Type (type))
5523 return true;
5525 if (Is_Scalar_Type (type))
5526 return Has_Default_Aspect (type);
5528 if (Is_Array_Type (type))
5529 return Has_Default_Aspect (type)
5530 || type_requires_init_of_formal (Component_Type (type));
5532 if (Is_Record_Type (type))
5533 for (Entity_Id field = First_Entity (type);
5534 Present (field);
5535 field = Next_Entity (field))
5537 if (Ekind (field) == E_Discriminant && !Is_Unchecked_Union (type))
5538 return true;
5540 if (Ekind (field) == E_Component
5541 && (Present (Expression (Parent (field)))
5542 || type_requires_init_of_formal (Etype (field))))
5543 return true;
5546 return false;
5549 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
5550 in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
5551 the type of the parameter. FIRST is true if this is the first parameter in
5552 the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
5553 the copy-in copy-out implementation mechanism.
5555 The returned tree is a PARM_DECL, except for the cases where no parameter
5556 needs to be actually passed to the subprogram; the type of this "shadow"
5557 parameter is then returned instead. */
5559 static tree
5560 gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
5561 Entity_Id gnat_subprog, bool *cico)
5563 Mechanism_Type mech = Mechanism (gnat_param);
5564 tree gnu_param_name = get_entity_name (gnat_param);
5565 bool foreign = Has_Foreign_Convention (gnat_subprog);
5566 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5567 /* The parameter can be indirectly modified if its address is taken. */
5568 bool ro_param = in_param && !Address_Taken (gnat_param);
5569 bool by_return = false, by_component_ptr = false;
5570 bool by_ref = false;
5571 bool forced_by_ref = false;
5572 bool restricted_aliasing_p = false;
5573 location_t saved_location = input_location;
5574 tree gnu_param;
5576 /* Make sure to use the proper SLOC for vector ABI warnings. */
5577 if (VECTOR_TYPE_P (gnu_param_type))
5578 Sloc_to_locus (Sloc (gnat_subprog), &input_location);
5580 /* Builtins are expanded inline and there is no real call sequence involved.
5581 So the type expected by the underlying expander is always the type of the
5582 argument "as is". */
5583 if (Is_Intrinsic_Subprogram (gnat_subprog)
5584 && Present (Interface_Name (gnat_subprog)))
5585 mech = By_Copy;
5587 /* Handle the first parameter of a valued procedure specially: it's a copy
5588 mechanism for which the parameter is never allocated. */
5589 else if (first && Is_Valued_Procedure (gnat_subprog))
5591 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5592 mech = By_Copy;
5593 by_return = true;
5596 /* Or else, see if a Mechanism was supplied that forced this parameter
5597 to be passed one way or another. */
5598 else if (mech == Default || mech == By_Copy || mech == By_Reference)
5599 forced_by_ref
5600 = (mech == By_Reference
5601 && !foreign
5602 && !TYPE_IS_BY_REFERENCE_P (gnu_param_type)
5603 && !Is_Aliased (gnat_param));
5605 /* Positive mechanism means by copy for sufficiently small parameters. */
5606 else if (mech > 0)
5608 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
5609 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
5610 || compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
5611 mech = By_Reference;
5612 else
5613 mech = By_Copy;
5616 /* Otherwise, it's an unsupported mechanism so error out. */
5617 else
5619 post_error ("unsupported mechanism for&", gnat_param);
5620 mech = Default;
5623 /* Either for foreign conventions, or if the underlying type is not passed
5624 by reference and is as large and aligned as the original type, strip off
5625 a possible padding type. */
5626 if (TYPE_IS_PADDING_P (gnu_param_type))
5628 tree inner_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5630 if (foreign
5631 || (mech != By_Reference
5632 && !must_pass_by_ref (inner_type)
5633 && (mech == By_Copy || !default_pass_by_ref (inner_type))
5634 && ((TYPE_SIZE (inner_type) == TYPE_SIZE (gnu_param_type)
5635 && TYPE_ALIGN (inner_type) >= TYPE_ALIGN (gnu_param_type))
5636 || Is_Init_Proc (gnat_subprog))))
5637 gnu_param_type = inner_type;
5640 /* For foreign conventions, pass arrays as pointers to the element type.
5641 First check for unconstrained array and get the underlying array. */
5642 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5643 gnu_param_type
5644 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5646 /* Arrays are passed as pointers to element type for foreign conventions. */
5647 if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5649 /* Strip off any multi-dimensional entries, then strip
5650 off the last array to get the component type. */
5651 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5652 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5653 gnu_param_type = TREE_TYPE (gnu_param_type);
5655 gnu_param_type = TREE_TYPE (gnu_param_type);
5656 gnu_param_type = build_pointer_type (gnu_param_type);
5657 by_component_ptr = true;
5660 /* Fat pointers are passed as thin pointers for foreign conventions. */
5661 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5662 gnu_param_type
5663 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5665 /* Use a pointer type for the "this" pointer of C++ constructors. */
5666 else if (Chars (gnat_param) == Name_uInit && Is_Constructor (gnat_subprog))
5668 gcc_assert (mech == By_Reference);
5669 gnu_param_type = build_pointer_type (gnu_param_type);
5670 by_ref = true;
5673 /* If we were requested or must pass by reference, do so.
5674 If we were requested to pass by copy, do so.
5675 Otherwise, for foreign conventions, pass In Out or Out parameters
5676 or aggregates by reference. For COBOL and Fortran, pass all
5677 integer and FP types that way too. For Convention Ada, use
5678 the standard Ada default. */
5679 else if (mech == By_Reference
5680 || must_pass_by_ref (gnu_param_type)
5681 || (mech != By_Copy
5682 && ((foreign
5683 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5684 || (foreign
5685 && (Convention (gnat_subprog) == Convention_Fortran
5686 || Convention (gnat_subprog) == Convention_COBOL)
5687 && (INTEGRAL_TYPE_P (gnu_param_type)
5688 || FLOAT_TYPE_P (gnu_param_type)))
5689 || (!foreign
5690 && default_pass_by_ref (gnu_param_type)))))
5692 /* We take advantage of 6.2(12) by considering that references built for
5693 parameters whose type isn't by-ref and for which the mechanism hasn't
5694 been forced to by-ref allow only a restricted form of aliasing. */
5695 restricted_aliasing_p
5696 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5697 gnu_param_type = build_reference_type (gnu_param_type);
5698 by_ref = true;
5701 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5702 else if (!in_param)
5703 *cico = true;
5705 input_location = saved_location;
5707 /* Warn if we are asked to pass by copy but cannot. */
5708 if (mech == By_Copy && (by_ref || by_component_ptr))
5709 post_error ("??cannot pass & by copy", gnat_param);
5711 /* If this is an Out parameter that isn't passed by reference and whose
5712 type doesn't require the initialization of formals, we don't make a
5713 PARM_DECL for it. Instead, it will be a VAR_DECL created when we
5714 process the procedure, so just return its type here. Likewise for
5715 the _Init parameter of an initialization procedure or the special
5716 parameter of a valued procedure, never pass them in. */
5717 if (Ekind (gnat_param) == E_Out_Parameter
5718 && !by_ref
5719 && !by_component_ptr
5720 && (!type_requires_init_of_formal (Etype (gnat_param))
5721 || Is_Init_Proc (gnat_subprog)
5722 || by_return))
5724 Set_Mechanism (gnat_param, By_Copy);
5725 return gnu_param_type;
5728 gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
5729 TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
5730 DECL_ARTIFICIAL (gnu_param) = !Comes_From_Source (gnat_param);
5731 DECL_BY_REF_P (gnu_param) = by_ref;
5732 DECL_FORCED_BY_REF_P (gnu_param) = forced_by_ref;
5733 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5734 DECL_POINTS_TO_READONLY_P (gnu_param)
5735 = (ro_param && (by_ref || by_component_ptr));
5736 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5737 DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
5738 Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
5740 /* If no Mechanism was specified, indicate what we will use. */
5741 if (mech == Default)
5742 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5744 /* Back-annotate the mechanism in all cases. */
5745 Set_Mechanism (gnat_param, mech);
5747 return gnu_param;
5750 /* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
5751 GNAT_SUBPROG is updated when GNU_TYPE is completed.
5753 Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
5754 the corresponding profile, which means that, by the time the freeze node
5755 of the subprogram is encountered, types involved in its profile may still
5756 be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
5757 the freeze node of types involved in its profile, either types of formal
5758 parameters or the return type. */
5760 static void
5761 associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
5763 gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
5765 struct tree_entity_vec_map in;
5766 in.base.from = gnu_type;
5767 struct tree_entity_vec_map **slot
5768 = dummy_to_subprog_map->find_slot (&in, INSERT);
5769 if (!*slot)
5771 tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
5772 e->base.from = gnu_type;
5773 e->to = NULL;
5774 *slot = e;
5777 /* Even if there is already a slot for GNU_TYPE, we need to set the flag
5778 because the vector might have been just emptied by update_profiles_with.
5779 This can happen when there are 2 freeze nodes associated with different
5780 views of the same type; the type will be really complete only after the
5781 second freeze node is encountered. */
5782 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
5784 vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
5786 /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
5787 since this would mean updating twice its profile. */
5788 if (v)
5790 const unsigned len = v->length ();
5791 unsigned int l = 0, u = len;
5793 /* Entity_Id is a simple integer so we can implement a stable order on
5794 the vector with an ordered insertion scheme and binary search. */
5795 while (l < u)
5797 unsigned int m = (l + u) / 2;
5798 int diff = (int) (*v)[m] - (int) gnat_subprog;
5799 if (diff > 0)
5800 u = m;
5801 else if (diff < 0)
5802 l = m + 1;
5803 else
5804 return;
5807 /* l == u and therefore is the insertion point. */
5808 vec_safe_insert (v, l, gnat_subprog);
5810 else
5811 vec_safe_push (v, gnat_subprog);
5813 (*slot)->to = v;
5816 /* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
5818 static void
5819 update_profile (Entity_Id gnat_subprog)
5821 tree gnu_param_list;
5822 tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
5823 Needs_Debug_Info (gnat_subprog),
5824 &gnu_param_list);
5825 if (DECL_P (gnu_type))
5827 /* Builtins cannot have their address taken so we can reset them. */
5828 gcc_assert (fndecl_built_in_p (gnu_type));
5829 save_gnu_tree (gnat_subprog, NULL_TREE, false);
5830 save_gnu_tree (gnat_subprog, gnu_type, false);
5831 return;
5834 tree gnu_subprog = get_gnu_tree (gnat_subprog);
5836 TREE_TYPE (gnu_subprog) = gnu_type;
5838 /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
5839 and needs to be adjusted too. */
5840 if (Ekind (gnat_subprog) != E_Subprogram_Type)
5842 tree gnu_entity_name = get_entity_name (gnat_subprog);
5843 tree gnu_ext_name
5844 = gnu_ext_name_for_subprog (gnat_subprog, gnu_entity_name);
5846 DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
5847 finish_subprog_decl (gnu_subprog, gnu_ext_name, gnu_type);
5851 /* Update the GCC trees previously built for the profiles involving GNU_TYPE,
5852 a dummy type which appears in profiles. */
5854 void
5855 update_profiles_with (tree gnu_type)
5857 struct tree_entity_vec_map in;
5858 in.base.from = gnu_type;
5859 struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
5860 gcc_assert (e);
5861 vec<Entity_Id, va_gc_atomic> *v = e->to;
5862 e->to = NULL;
5864 /* The flag needs to be reset before calling update_profile, in case
5865 associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
5866 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
5868 unsigned int i;
5869 Entity_Id *iter;
5870 FOR_EACH_VEC_ELT (*v, i, iter)
5871 update_profile (*iter);
5873 vec_free (v);
5876 /* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
5878 Ada 2012 (AI05-0151) says that incomplete types coming from a limited
5879 context may now appear as parameter and result types. As a consequence,
5880 we may need to defer their translation until after a freeze node is seen
5881 or to the end of the current unit. We also aim at handling temporarily
5882 incomplete types created by the usual delayed elaboration scheme. */
5884 static tree
5885 gnat_to_gnu_profile_type (Entity_Id gnat_type)
5887 /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
5888 so the rationale is exposed in that place. These processings probably
5889 ought to be merged at some point. */
5890 Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
5891 const bool is_from_limited_with
5892 = (Is_Incomplete_Type (gnat_equiv)
5893 && From_Limited_With (gnat_equiv));
5894 Entity_Id gnat_full_direct_first
5895 = (is_from_limited_with
5896 ? Non_Limited_View (gnat_equiv)
5897 : (Is_Incomplete_Or_Private_Type (gnat_equiv)
5898 ? Full_View (gnat_equiv) : Empty));
5899 Entity_Id gnat_full_direct
5900 = ((is_from_limited_with
5901 && Present (gnat_full_direct_first)
5902 && Is_Private_Type (gnat_full_direct_first))
5903 ? Full_View (gnat_full_direct_first)
5904 : gnat_full_direct_first);
5905 Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
5906 Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
5907 const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
5908 tree gnu_type;
5910 if (Present (gnat_full) && present_gnu_tree (gnat_full))
5911 gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
5913 else if (is_from_limited_with
5914 && ((!in_main_unit
5915 && !present_gnu_tree (gnat_equiv)
5916 && Present (gnat_full)
5917 && (Is_Record_Type (gnat_full)
5918 || Is_Array_Type (gnat_full)
5919 || Is_Access_Type (gnat_full)))
5920 || (in_main_unit && Present (Freeze_Node (gnat_rep)))))
5922 gnu_type = make_dummy_type (gnat_equiv);
5924 if (!in_main_unit)
5926 struct incomplete *p = XNEW (struct incomplete);
5928 p->old_type = gnu_type;
5929 p->full_type = gnat_equiv;
5930 p->next = defer_limited_with_list;
5931 defer_limited_with_list = p;
5935 else if (type_annotate_only && No (gnat_equiv))
5936 gnu_type = void_type_node;
5938 else
5939 gnu_type = gnat_to_gnu_type (gnat_equiv);
5941 /* Access-to-unconstrained-array types need a special treatment. */
5942 if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
5944 if (!TYPE_POINTER_TO (gnu_type))
5945 build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
5948 return gnu_type;
5951 /* Return true if TYPE contains only integral data, recursively if need be. */
5953 static bool
5954 type_contains_only_integral_data (tree type)
5956 switch (TREE_CODE (type))
5958 case RECORD_TYPE:
5959 case UNION_TYPE:
5960 case QUAL_UNION_TYPE:
5961 for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
5962 if (!type_contains_only_integral_data (TREE_TYPE (field)))
5963 return false;
5964 return true;
5966 case ARRAY_TYPE:
5967 case COMPLEX_TYPE:
5968 return type_contains_only_integral_data (TREE_TYPE (type));
5970 default:
5971 return INTEGRAL_TYPE_P (type);
5974 gcc_unreachable ();
5977 /* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
5978 DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
5979 is true if we need to write debug information for other types that we may
5980 create in the process. Also set PARAM_LIST to the list of parameters.
5981 If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
5982 directly instead of its type. */
5984 static tree
5985 gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
5986 bool debug_info_p, tree *param_list)
5988 const Entity_Kind kind = Ekind (gnat_subprog);
5989 const Entity_Id gnat_return_type = Etype (gnat_subprog);
5990 const bool method_p = is_cplusplus_method (gnat_subprog);
5991 const bool variadic = IN (Convention (gnat_subprog), Convention_C_Variadic);
5992 tree gnu_type = present_gnu_tree (gnat_subprog)
5993 ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
5994 tree gnu_return_type;
5995 tree gnu_param_type_list = NULL_TREE;
5996 tree gnu_param_list = NULL_TREE;
5997 /* Non-null for subprograms containing parameters passed by copy-in copy-out
5998 (In Out or Out parameters not passed by reference), in which case it is
5999 the list of nodes used to specify the values of the In Out/Out parameters
6000 that are returned as a record upon procedure return. The TREE_PURPOSE of
6001 an element of this list is a FIELD_DECL of the record and the TREE_VALUE
6002 is the PARM_DECL corresponding to that field. This list will be saved in
6003 the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
6004 tree gnu_cico_list = NULL_TREE;
6005 tree gnu_cico_return_type = NULL_TREE;
6006 tree gnu_cico_field_list = NULL_TREE;
6007 bool gnu_cico_only_integral_type = true;
6008 /* Although the semantics of "pure" units in Ada essentially match those of
6009 "const" in GNU C, the semantics of the Is_Pure flag in GNAT do not say
6010 anything about access to global memory, that's why it needs to be mapped
6011 to "pure" instead of "const" in GNU C. The property is orthogonal to the
6012 "nothrow" property only if the EH circuitry is explicit in the internal
6013 representation of the middle-end: if we are to completely hide the EH
6014 circuitry from it, we need to declare that calls to pure Ada subprograms
6015 that can throw have side effects, since they can trigger an "abnormal"
6016 transfer of control; therefore they cannot be "pure" in the GCC sense. */
6017 bool pure_flag = Is_Pure (gnat_subprog);
6018 bool return_by_direct_ref_p = false;
6019 bool return_by_invisi_ref_p = false;
6020 bool incomplete_profile_p = false;
6022 /* Look into the return type and get its associated GCC tree if it is not
6023 void, and then compute various flags for the subprogram type. But make
6024 sure not to do this processing multiple times. */
6025 if (Ekind (gnat_return_type) == E_Void)
6026 gnu_return_type = void_type_node;
6028 else if (gnu_type
6029 && FUNC_OR_METHOD_TYPE_P (gnu_type)
6030 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
6032 gnu_return_type = TREE_TYPE (gnu_type);
6033 return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
6034 return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
6037 else
6039 /* For foreign convention/intrinsic subprograms, return System.Address
6040 as void * or equivalent; this comprises GCC builtins. */
6041 if ((Has_Foreign_Convention (gnat_subprog)
6042 || Is_Intrinsic_Subprogram (gnat_subprog))
6043 && Is_Descendant_Of_Address (Underlying_Type (gnat_return_type)))
6044 gnu_return_type = ptr_type_node;
6045 else
6046 gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
6048 /* If this function returns by reference or on the secondary stack, make
6049 the actual return type the reference type and make a note of that. */
6050 if (Returns_By_Ref (gnat_subprog)
6051 || Needs_Secondary_Stack (gnat_return_type)
6052 || Is_Secondary_Stack_Thunk (gnat_subprog))
6054 gnu_return_type = build_reference_type (gnu_return_type);
6055 return_by_direct_ref_p = true;
6058 /* If the Mechanism is By_Reference, ensure this function uses the
6059 target's by-invisible-reference mechanism, which may not be the
6060 same as above (e.g. it might be passing an extra parameter). */
6061 else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
6062 return_by_invisi_ref_p = true;
6064 /* Likewise, if the return type is itself By_Reference. */
6065 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
6066 return_by_invisi_ref_p = true;
6068 /* If the type is a padded type and the underlying type would not be
6069 passed by reference or the function has a foreign convention, return
6070 the underlying type. */
6071 else if (TYPE_IS_PADDING_P (gnu_return_type)
6072 && (!default_pass_by_ref
6073 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
6074 || Has_Foreign_Convention (gnat_subprog)))
6075 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
6077 /* If the return type is unconstrained, it must have a maximum size.
6078 Use the padded type as the effective return type. And ensure the
6079 function uses the target's by-invisible-reference mechanism to
6080 avoid copying too much data when it returns. */
6081 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
6083 tree orig_type = gnu_return_type;
6084 tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
6086 /* If the size overflows to 0, set it to an arbitrary positive
6087 value so that assignments in the type are preserved. Their
6088 actual size is independent of this positive value. */
6089 if (TREE_CODE (max_return_size) == INTEGER_CST
6090 && TREE_OVERFLOW (max_return_size)
6091 && integer_zerop (max_return_size))
6093 max_return_size = copy_node (bitsize_unit_node);
6094 TREE_OVERFLOW (max_return_size) = 1;
6097 gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
6098 0, gnat_subprog, false, definition,
6099 true);
6101 /* Declare it now since it will never be declared otherwise. This
6102 is necessary to ensure that its subtrees are properly marked. */
6103 if (gnu_return_type != orig_type
6104 && !DECL_P (TYPE_NAME (gnu_return_type)))
6105 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
6106 true, debug_info_p, gnat_subprog);
6108 return_by_invisi_ref_p = true;
6111 /* If the return type has a size that overflows, we usually cannot have
6112 a function that returns that type. This usage doesn't really make
6113 sense anyway, so issue an error here. */
6114 if (!return_by_invisi_ref_p
6115 && TYPE_SIZE_UNIT (gnu_return_type)
6116 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
6117 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
6119 post_error ("cannot return type whose size overflows", gnat_subprog);
6120 gnu_return_type = copy_type (gnu_return_type);
6121 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
6122 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
6125 /* If the return type is incomplete, there are 2 cases: if the function
6126 returns by reference, then the return type is only linked indirectly
6127 in the profile, so the profile can be seen as complete since it need
6128 not be further modified, only the reference types need be adjusted;
6129 otherwise the profile is incomplete and need be adjusted too. */
6130 if (TYPE_IS_DUMMY_P (gnu_return_type))
6132 associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
6133 incomplete_profile_p = true;
6137 /* A procedure (something that doesn't return anything) shouldn't be
6138 considered pure since there would be no reason for calling such a
6139 subprogram. Note that procedures with Out (or In Out) parameters
6140 have already been converted into a function with a return type.
6141 Similarly, if the function returns an unconstrained type, then the
6142 function will allocate the return value on the secondary stack and
6143 thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
6144 if (VOID_TYPE_P (gnu_return_type) || return_by_direct_ref_p)
6145 pure_flag = false;
6147 /* Loop over the parameters and get their associated GCC tree. While doing
6148 this, build a copy-in copy-out structure if we need one. */
6149 Entity_Id gnat_param;
6150 int num;
6151 for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
6152 Present (gnat_param);
6153 gnat_param = Next_Formal_With_Extras (gnat_param), num++)
6155 const bool mech_is_by_ref
6156 = Mechanism (gnat_param) == By_Reference
6157 && !(num == 0 && Is_Valued_Procedure (gnat_subprog));
6158 tree gnu_param_name = get_entity_name (gnat_param);
6159 tree gnu_param, gnu_param_type;
6160 bool cico = false;
6162 /* For a variadic C function, do not build unnamed parameters. */
6163 if (variadic
6164 && num == (Convention (gnat_subprog) - Convention_C_Variadic_0))
6165 break;
6167 /* Fetch an existing parameter with complete type and reuse it. But we
6168 didn't save the CICO property so we can only do it for In parameters
6169 or parameters passed by reference. */
6170 if ((Ekind (gnat_param) == E_In_Parameter || mech_is_by_ref)
6171 && present_gnu_tree (gnat_param)
6172 && (gnu_param = get_gnu_tree (gnat_param))
6173 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param)))
6175 DECL_CHAIN (gnu_param) = NULL_TREE;
6176 gnu_param_type = TREE_TYPE (gnu_param);
6179 /* Otherwise translate the parameter type and act accordingly. */
6180 else
6182 Entity_Id gnat_param_type = Etype (gnat_param);
6184 /* For foreign convention/intrinsic subprograms, pass System.Address
6185 as void * or equivalent; this comprises GCC builtins. */
6186 if ((Has_Foreign_Convention (gnat_subprog)
6187 || Is_Intrinsic_Subprogram (gnat_subprog))
6188 && Is_Descendant_Of_Address (Underlying_Type (gnat_param_type)))
6189 gnu_param_type = ptr_type_node;
6190 else
6191 gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
6193 /* If the parameter type is incomplete, there are 2 cases: if it is
6194 passed by reference, then the type is only linked indirectly in
6195 the profile, so the profile can be seen as complete since it need
6196 not be further modified, only the reference type need be adjusted;
6197 otherwise the profile is incomplete and need be adjusted too. */
6198 if (TYPE_IS_DUMMY_P (gnu_param_type))
6200 Node_Id gnat_decl;
6202 if (mech_is_by_ref
6203 || (TYPE_REFERENCE_TO (gnu_param_type)
6204 && TYPE_IS_FAT_POINTER_P
6205 (TYPE_REFERENCE_TO (gnu_param_type)))
6206 || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
6208 gnu_param_type = build_reference_type (gnu_param_type);
6209 gnu_param
6210 = create_param_decl (gnu_param_name, gnu_param_type);
6211 TREE_READONLY (gnu_param) = 1;
6212 DECL_BY_REF_P (gnu_param) = 1;
6213 DECL_POINTS_TO_READONLY_P (gnu_param)
6214 = (Ekind (gnat_param) == E_In_Parameter
6215 && !Address_Taken (gnat_param));
6216 Set_Mechanism (gnat_param, By_Reference);
6217 Sloc_to_locus (Sloc (gnat_param),
6218 &DECL_SOURCE_LOCATION (gnu_param));
6221 /* ??? This is a kludge to support null procedures in spec taking
6222 a parameter with an untagged incomplete type coming from a
6223 limited context. The front-end creates a body without knowing
6224 anything about the non-limited view, which is illegal Ada and
6225 cannot be supported. Create a parameter with a fake type. */
6226 else if (kind == E_Procedure
6227 && (gnat_decl = Parent (gnat_subprog))
6228 && Nkind (gnat_decl) == N_Procedure_Specification
6229 && Null_Present (gnat_decl)
6230 && Is_Incomplete_Type (gnat_param_type))
6231 gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
6233 else
6235 /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
6236 Call_to_gnu will stop if it encounters the PARM_DECL. */
6237 gnu_param
6238 = build_decl (input_location, PARM_DECL, gnu_param_name,
6239 gnu_param_type);
6240 associate_subprog_with_dummy_type (gnat_subprog,
6241 gnu_param_type);
6242 incomplete_profile_p = true;
6246 /* Otherwise build the parameter declaration normally. */
6247 else
6249 gnu_param
6250 = gnat_to_gnu_param (gnat_param, gnu_param_type, num == 0,
6251 gnat_subprog, &cico);
6253 /* We are returned either a PARM_DECL or a type if no parameter
6254 needs to be passed; in either case, adjust the type. */
6255 if (DECL_P (gnu_param))
6256 gnu_param_type = TREE_TYPE (gnu_param);
6257 else
6259 gnu_param_type = gnu_param;
6260 gnu_param = NULL_TREE;
6265 /* If we have a GCC tree for the parameter, register it. */
6266 save_gnu_tree (gnat_param, NULL_TREE, false);
6267 if (gnu_param)
6269 gnu_param_type_list
6270 = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
6271 DECL_CHAIN (gnu_param) = gnu_param_list;
6272 gnu_param_list = gnu_param;
6273 save_gnu_tree (gnat_param, gnu_param, false);
6275 /* A pure function in the Ada sense which takes an access parameter
6276 may modify memory through it and thus cannot be considered pure
6277 in the GCC sense, unless it's access-to-function. Likewise it if
6278 takes a by-ref In Out or Out parameter. But if it takes a by-ref
6279 In parameter, then it may only read memory through it and can be
6280 considered pure in the GCC sense. */
6281 if (pure_flag
6282 && ((POINTER_TYPE_P (gnu_param_type)
6283 && TREE_CODE (TREE_TYPE (gnu_param_type)) != FUNCTION_TYPE)
6284 || TYPE_IS_FAT_POINTER_P (gnu_param_type)))
6285 pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param);
6288 /* If the parameter uses the copy-in copy-out mechanism, allocate a field
6289 for it in the return type and register the association. */
6290 if (cico && !incomplete_profile_p)
6292 if (!gnu_cico_list)
6294 gnu_cico_return_type = make_node (RECORD_TYPE);
6296 /* If this is a function, we also need a field for the
6297 return value to be placed. */
6298 if (!VOID_TYPE_P (gnu_return_type))
6300 tree gnu_field
6301 = create_field_decl (get_identifier ("RETVAL"),
6302 gnu_return_type,
6303 gnu_cico_return_type, NULL_TREE,
6304 NULL_TREE, 0, 0);
6305 Sloc_to_locus (Sloc (gnat_subprog),
6306 &DECL_SOURCE_LOCATION (gnu_field));
6307 gnu_cico_field_list = gnu_field;
6308 gnu_cico_list
6309 = tree_cons (gnu_field, void_type_node, NULL_TREE);
6310 if (!type_contains_only_integral_data (gnu_return_type))
6311 gnu_cico_only_integral_type = false;
6314 TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN");
6315 /* Set a default alignment to speed up accesses. But we should
6316 not increase the size of the structure too much, lest it does
6317 not fit in return registers anymore. */
6318 SET_TYPE_ALIGN (gnu_cico_return_type,
6319 get_mode_alignment (ptr_mode));
6322 tree gnu_field
6323 = create_field_decl (gnu_param_name, gnu_param_type,
6324 gnu_cico_return_type, NULL_TREE, NULL_TREE,
6325 0, 0);
6326 Sloc_to_locus (Sloc (gnat_param),
6327 &DECL_SOURCE_LOCATION (gnu_field));
6328 DECL_CHAIN (gnu_field) = gnu_cico_field_list;
6329 gnu_cico_field_list = gnu_field;
6330 gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
6331 if (!type_contains_only_integral_data (gnu_param_type))
6332 gnu_cico_only_integral_type = false;
6336 /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
6337 and finish up the return type. */
6338 if (gnu_cico_list && !incomplete_profile_p)
6340 /* If we have a CICO list but it has only one entry, we convert
6341 this function into a function that returns this object. */
6342 if (list_length (gnu_cico_list) == 1)
6343 gnu_cico_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
6345 /* Do not finalize the return type if the subprogram is stubbed
6346 since structures are incomplete for the back-end. */
6347 else if (Convention (gnat_subprog) != Convention_Stubbed)
6349 finish_record_type (gnu_cico_return_type,
6350 nreverse (gnu_cico_field_list),
6351 0, false);
6353 /* Try to promote the mode if the return type is fully returned
6354 in integer registers, again to speed up accesses. */
6355 if (TYPE_MODE (gnu_cico_return_type) == BLKmode
6356 && gnu_cico_only_integral_type
6357 && !targetm.calls.return_in_memory (gnu_cico_return_type,
6358 NULL_TREE))
6360 unsigned int size
6361 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type));
6362 unsigned int i = BITS_PER_UNIT;
6363 scalar_int_mode mode;
6365 while (i < size)
6366 i <<= 1;
6367 if (int_mode_for_size (i, 0).exists (&mode))
6369 SET_TYPE_MODE (gnu_cico_return_type, mode);
6370 SET_TYPE_ALIGN (gnu_cico_return_type,
6371 GET_MODE_ALIGNMENT (mode));
6372 TYPE_SIZE (gnu_cico_return_type)
6373 = bitsize_int (GET_MODE_BITSIZE (mode));
6374 TYPE_SIZE_UNIT (gnu_cico_return_type)
6375 = size_int (GET_MODE_SIZE (mode));
6379 /* But demote the mode if the return type is partly returned in FP
6380 registers to avoid creating problematic paradoxical subregs.
6381 Note that we need to cater to historical 32-bit architectures
6382 that incorrectly use the mode to select the return mechanism. */
6383 else if (INTEGRAL_MODE_P (TYPE_MODE (gnu_cico_return_type))
6384 && !gnu_cico_only_integral_type
6385 && BITS_PER_WORD >= 64
6386 && !targetm.calls.return_in_memory (gnu_cico_return_type,
6387 NULL_TREE))
6388 SET_TYPE_MODE (gnu_cico_return_type, BLKmode);
6390 if (debug_info_p)
6391 rest_of_record_type_compilation (gnu_cico_return_type);
6393 /* Declare it now since it will never be declared otherwise. This
6394 is necessary to ensure that its subtrees are properly marked. */
6395 create_type_decl (TYPE_NAME (gnu_cico_return_type),
6396 gnu_cico_return_type,
6397 true, debug_info_p, gnat_subprog);
6400 gnu_return_type = gnu_cico_return_type;
6403 /* The lists have been built in reverse. */
6404 gnu_param_type_list = nreverse (gnu_param_type_list);
6405 if (!variadic)
6406 gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
6407 gnu_param_list = nreverse (gnu_param_list);
6408 gnu_cico_list = nreverse (gnu_cico_list);
6410 /* Turn imported C++ constructors into their callable form as done in the
6411 front-end, i.e. add the "this" pointer and void the return type. */
6412 if (method_p
6413 && Is_Constructor (gnat_subprog)
6414 && !VOID_TYPE_P (gnu_return_type))
6416 tree gnu_param_type
6417 = build_pointer_type (gnat_to_gnu_profile_type (gnat_return_type));
6418 tree gnu_param_name = get_identifier (Get_Name_String (Name_uInit));
6419 tree gnu_param
6420 = build_decl (input_location, PARM_DECL, gnu_param_name,
6421 gnu_param_type);
6422 gnu_param_type_list
6423 = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
6424 DECL_CHAIN (gnu_param) = gnu_param_list;
6425 gnu_param_list = gnu_param;
6426 gnu_return_type = void_type_node;
6429 /* If the profile is incomplete, we only set the (temporary) return and
6430 parameter types; otherwise, we build the full type. In either case,
6431 we reuse an already existing GCC tree that we built previously here. */
6432 if (incomplete_profile_p)
6434 if (gnu_type && FUNC_OR_METHOD_TYPE_P (gnu_type))
6436 else
6437 gnu_type = make_node (method_p ? METHOD_TYPE : FUNCTION_TYPE);
6438 TREE_TYPE (gnu_type) = gnu_return_type;
6439 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
6440 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
6441 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6443 else
6445 if (gnu_type && FUNC_OR_METHOD_TYPE_P (gnu_type))
6447 TREE_TYPE (gnu_type) = gnu_return_type;
6448 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
6449 if (method_p)
6451 tree gnu_basetype = TREE_TYPE (TREE_VALUE (gnu_param_type_list));
6452 TYPE_METHOD_BASETYPE (gnu_type)
6453 = TYPE_MAIN_VARIANT (gnu_basetype);
6455 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
6456 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
6457 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6458 TYPE_CANONICAL (gnu_type) = gnu_type;
6459 layout_type (gnu_type);
6461 else
6463 if (method_p)
6465 tree gnu_basetype = TREE_TYPE (TREE_VALUE (gnu_param_type_list));
6466 gnu_type
6467 = build_method_type_directly (gnu_basetype, gnu_return_type,
6468 TREE_CHAIN (gnu_param_type_list));
6470 else
6471 gnu_type
6472 = build_function_type (gnu_return_type, gnu_param_type_list);
6474 /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
6475 has a different TYPE_CI_CO_LIST or flags. */
6476 if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
6477 return_by_direct_ref_p,
6478 return_by_invisi_ref_p))
6480 gnu_type = copy_type (gnu_type);
6481 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
6482 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
6483 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6487 if (pure_flag)
6488 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_RESTRICT);
6490 if (No_Return (gnat_subprog))
6491 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
6493 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
6494 corresponding DECL node and check the parameter association. */
6495 if (Is_Intrinsic_Subprogram (gnat_subprog)
6496 && Present (Interface_Name (gnat_subprog)))
6498 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6499 tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
6501 /* If we have a builtin DECL for that function, use it. Check if
6502 the profiles are compatible and warn if they are not. Note that
6503 the checker is expected to post diagnostics in this case. */
6504 if (gnu_builtin_decl)
6506 if (fndecl_built_in_p (gnu_builtin_decl, BUILT_IN_NORMAL))
6508 const enum built_in_function fncode
6509 = DECL_FUNCTION_CODE (gnu_builtin_decl);
6511 switch (fncode)
6513 case BUILT_IN_SYNC_FETCH_AND_ADD_N:
6514 case BUILT_IN_SYNC_FETCH_AND_SUB_N:
6515 case BUILT_IN_SYNC_FETCH_AND_OR_N:
6516 case BUILT_IN_SYNC_FETCH_AND_AND_N:
6517 case BUILT_IN_SYNC_FETCH_AND_XOR_N:
6518 case BUILT_IN_SYNC_FETCH_AND_NAND_N:
6519 case BUILT_IN_SYNC_ADD_AND_FETCH_N:
6520 case BUILT_IN_SYNC_SUB_AND_FETCH_N:
6521 case BUILT_IN_SYNC_OR_AND_FETCH_N:
6522 case BUILT_IN_SYNC_AND_AND_FETCH_N:
6523 case BUILT_IN_SYNC_XOR_AND_FETCH_N:
6524 case BUILT_IN_SYNC_NAND_AND_FETCH_N:
6525 case BUILT_IN_SYNC_VAL_COMPARE_AND_SWAP_N:
6526 case BUILT_IN_SYNC_LOCK_TEST_AND_SET_N:
6527 case BUILT_IN_ATOMIC_EXCHANGE_N:
6528 case BUILT_IN_ATOMIC_LOAD_N:
6529 case BUILT_IN_ATOMIC_ADD_FETCH_N:
6530 case BUILT_IN_ATOMIC_SUB_FETCH_N:
6531 case BUILT_IN_ATOMIC_AND_FETCH_N:
6532 case BUILT_IN_ATOMIC_NAND_FETCH_N:
6533 case BUILT_IN_ATOMIC_XOR_FETCH_N:
6534 case BUILT_IN_ATOMIC_OR_FETCH_N:
6535 case BUILT_IN_ATOMIC_FETCH_ADD_N:
6536 case BUILT_IN_ATOMIC_FETCH_SUB_N:
6537 case BUILT_IN_ATOMIC_FETCH_AND_N:
6538 case BUILT_IN_ATOMIC_FETCH_NAND_N:
6539 case BUILT_IN_ATOMIC_FETCH_XOR_N:
6540 case BUILT_IN_ATOMIC_FETCH_OR_N:
6541 /* This is a generic builtin overloaded on its return
6542 type, so do type resolution based on it. */
6543 if (!VOID_TYPE_P (gnu_return_type)
6544 && type_for_atomic_builtin_p (gnu_return_type))
6545 gnu_builtin_decl
6546 = resolve_atomic_builtin (fncode, gnu_return_type);
6547 else
6549 post_error
6550 ("??cannot import type-generic 'G'C'C builtin!",
6551 gnat_subprog);
6552 post_error
6553 ("\\?use a supported result type",
6554 gnat_subprog);
6555 gnu_builtin_decl = NULL_TREE;
6557 break;
6559 case BUILT_IN_SYNC_BOOL_COMPARE_AND_SWAP_N:
6560 case BUILT_IN_ATOMIC_STORE_N:
6561 /* This is a generic builtin overloaded on its second
6562 parameter type, so do type resolution based on it. */
6563 if (list_length (gnu_param_type_list) >= 3
6564 && type_for_atomic_builtin_p
6565 (list_second (gnu_param_type_list)))
6566 gnu_builtin_decl
6567 = resolve_atomic_builtin
6568 (fncode, list_second (gnu_param_type_list));
6569 else
6571 post_error
6572 ("??cannot import type-generic 'G'C'C builtin!",
6573 gnat_subprog);
6574 post_error
6575 ("\\?use a supported second parameter type",
6576 gnat_subprog);
6577 gnu_builtin_decl = NULL_TREE;
6579 break;
6581 case BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N:
6582 /* This is a generic builtin overloaded on its third
6583 parameter type, so do type resolution based on it. */
6584 if (list_length (gnu_param_type_list) >= 4
6585 && type_for_atomic_builtin_p
6586 (list_third (gnu_param_type_list)))
6587 gnu_builtin_decl
6588 = resolve_atomic_builtin
6589 (fncode, list_third (gnu_param_type_list));
6590 else
6592 post_error
6593 ("??cannot import type-generic 'G'C'C builtin!",
6594 gnat_subprog);
6595 post_error
6596 ("\\?use a supported third parameter type",
6597 gnat_subprog);
6598 gnu_builtin_decl = NULL_TREE;
6600 break;
6602 case BUILT_IN_SYNC_LOCK_RELEASE_N:
6603 post_error
6604 ("??unsupported type-generic 'G'C'C builtin!",
6605 gnat_subprog);
6606 gnu_builtin_decl = NULL_TREE;
6607 break;
6609 default:
6610 break;
6614 if (gnu_builtin_decl)
6616 const intrin_binding_t inb
6617 = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) };
6619 if (!intrin_profiles_compatible_p (&inb))
6620 post_error
6621 ("??profile of& doesn''t match the builtin it binds!",
6622 gnat_subprog);
6624 return gnu_builtin_decl;
6628 /* Inability to find the builtin DECL most often indicates a genuine
6629 mistake, but imports of unregistered intrinsics are sometimes used
6630 on purpose to allow hooking in alternate bodies; we post a warning
6631 conditioned on Wshadow in this case, to let developers be notified
6632 on demand without risking false positives with common default sets
6633 of options. */
6634 if (warn_shadow)
6635 post_error ("'G'C'C builtin not found for&!??", gnat_subprog);
6638 /* Finally deal with the return mechanism for a function. */
6639 if (kind == E_Function)
6641 /* We return by reference either if this is required by the semantics
6642 of the language or if this is the default for the function. */
6643 const bool by_ref = return_by_direct_ref_p
6644 || return_by_invisi_ref_p
6645 || aggregate_value_p (gnu_return_type, gnu_type);
6646 Mechanism_Type mech = Mechanism (gnat_subprog);
6648 /* Warn if we are asked to return by copy but cannot. */
6649 if (mech == By_Copy && by_ref)
6650 post_error ("??cannot return from & by copy", gnat_subprog);
6652 /* If no mechanism was specified, indicate what we will use. */
6653 if (mech == Default)
6654 mech = by_ref ? By_Reference : By_Copy;
6656 /* Back-annotate the mechanism in all cases. */
6657 Set_Mechanism (gnat_subprog, mech);
6661 *param_list = gnu_param_list;
6663 return gnu_type;
6666 /* Return the external name for GNAT_SUBPROG given its entity name. */
6668 static tree
6669 gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name)
6671 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6673 /* If there was no specified Interface_Name and the external and
6674 internal names of the subprogram are the same, only use the
6675 internal name to allow disambiguation of nested subprograms. */
6676 if (No (Interface_Name (gnat_subprog)) && gnu_ext_name == gnu_entity_name)
6677 gnu_ext_name = NULL_TREE;
6679 return gnu_ext_name;
6682 /* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
6683 build_nonshared_array_type. */
6685 static void
6686 set_nonaliased_component_on_array_type (tree type)
6688 TYPE_NONALIASED_COMPONENT (type) = 1;
6689 if (TYPE_CANONICAL (type))
6690 TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1;
6693 /* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
6694 build_nonshared_array_type. */
6696 static void
6697 set_reverse_storage_order_on_array_type (tree type)
6699 TYPE_REVERSE_STORAGE_ORDER (type) = 1;
6700 if (TYPE_CANONICAL (type))
6701 TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
6704 /* Set TYPE_TYPELESS_STORAGE on an aggregate type. */
6706 static void
6707 set_typeless_storage_on_aggregate_type (tree type)
6709 TYPE_TYPELESS_STORAGE (type) = 1;
6710 if (TYPE_CANONICAL (type))
6711 TYPE_TYPELESS_STORAGE (TYPE_CANONICAL (type)) = 1;
6714 /* Set TYPE_UNIVERSAL_ALIASING_P on a type. */
6716 static void
6717 set_universal_aliasing_on_type (tree type)
6719 TYPE_UNIVERSAL_ALIASING_P (type) = 1;
6720 if (TYPE_CANONICAL (type))
6721 TYPE_UNIVERSAL_ALIASING_P (TYPE_CANONICAL (type)) = 1;
6724 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
6726 static bool
6727 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
6729 while (Present (Corresponding_Discriminant (discr1)))
6730 discr1 = Corresponding_Discriminant (discr1);
6732 while (Present (Corresponding_Discriminant (discr2)))
6733 discr2 = Corresponding_Discriminant (discr2);
6735 return
6736 Original_Record_Component (discr1) == Original_Record_Component (discr2);
6739 /* Return true if the array type GNU_TYPE, which represents a dimension of
6740 GNAT_TYPE, has a non-aliased component in the back-end sense. */
6742 static bool
6743 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
6745 /* If the array type has an aliased component in the front-end sense,
6746 then it also has an aliased component in the back-end sense. */
6747 if (Has_Aliased_Components (gnat_type))
6748 return false;
6750 /* If this is a derived type, then it has a non-aliased component if
6751 and only if its parent type also has one. */
6752 if (Is_Derived_Type (gnat_type))
6754 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
6755 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
6756 gnu_parent_type
6757 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
6758 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
6761 /* For a multi-dimensional array type, find the component type. */
6762 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6763 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
6764 gnu_type = TREE_TYPE (gnu_type);
6766 /* Consider that an array of pointers has an aliased component, which is
6767 sort of logical and helps with Taft Amendment types in LTO mode. */
6768 if (POINTER_TYPE_P (TREE_TYPE (gnu_type)))
6769 return false;
6771 /* Otherwise, rely exclusively on properties of the element type. */
6772 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
6775 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
6777 static bool
6778 compile_time_known_address_p (Node_Id gnat_address)
6780 /* Handle reference to a constant. */
6781 if (Is_Entity_Name (gnat_address)
6782 && Ekind (Entity (gnat_address)) == E_Constant)
6784 gnat_address = Constant_Value (Entity (gnat_address));
6785 if (No (gnat_address))
6786 return false;
6789 /* Catch System'To_Address. */
6790 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
6791 gnat_address = Expression (gnat_address);
6793 return Compile_Time_Known_Value (gnat_address);
6796 /* Return true if GNAT_INDIC, a N_Subtype_Indication node for the index of a
6797 FLB, cannot yield superflat objects, i.e. if the inequality HB >= LB - 1
6798 is true for these objects. LB and HB are the low and high bounds. */
6800 static bool
6801 flb_cannot_be_superflat (Node_Id gnat_indic)
6803 const Entity_Id gnat_type = Entity (Subtype_Mark (gnat_indic));
6804 const Entity_Id gnat_subtype = Etype (gnat_indic);
6805 Node_Id gnat_scalar_range, gnat_lb, gnat_hb;
6806 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
6808 /* This is a FLB so LB is fixed. */
6809 if ((Ekind (gnat_subtype) == E_Signed_Integer_Subtype
6810 || Ekind (gnat_subtype) == E_Modular_Integer_Subtype)
6811 && (gnat_scalar_range = Scalar_Range (gnat_subtype)))
6813 gnat_lb = Low_Bound (gnat_scalar_range);
6814 gcc_assert (Nkind (gnat_lb) == N_Integer_Literal);
6816 else
6817 return false;
6819 /* The low bound of the type is a lower bound for HB. */
6820 if ((Ekind (gnat_type) == E_Signed_Integer_Subtype
6821 || Ekind (gnat_type) == E_Modular_Integer_Subtype)
6822 && (gnat_scalar_range = Scalar_Range (gnat_type)))
6824 gnat_hb = Low_Bound (gnat_scalar_range);
6825 gcc_assert (Nkind (gnat_hb) == N_Integer_Literal);
6827 else
6828 return false;
6830 /* We need at least a signed 64-bit type to catch most cases. */
6831 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
6832 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
6833 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
6834 return false;
6836 /* If the low bound is the smallest integer, nothing can be smaller. */
6837 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
6838 if (TREE_OVERFLOW (gnu_lb_minus_one))
6839 return true;
6841 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
6844 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
6845 inequality HB >= LB - 1 is true. LB and HB are the low and high bounds. */
6847 static bool
6848 range_cannot_be_superflat (Node_Id gnat_range)
6850 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
6851 Node_Id gnat_scalar_range;
6852 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
6854 /* This is the easy case. */
6855 if (Cannot_Be_Superflat (gnat_range))
6856 return true;
6858 /* If the low bound is not constant, take the worst case by finding an upper
6859 bound for its type, repeatedly if need be. */
6860 while (Nkind (gnat_lb) != N_Integer_Literal
6861 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
6862 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
6863 && (gnat_scalar_range = Scalar_Range (Etype (gnat_lb)))
6864 && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition
6865 || Nkind (gnat_scalar_range) == N_Range))
6866 gnat_lb = High_Bound (gnat_scalar_range);
6868 /* If the high bound is not constant, take the worst case by finding a lower
6869 bound for its type, repeatedly if need be. */
6870 while (Nkind (gnat_hb) != N_Integer_Literal
6871 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
6872 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
6873 && (gnat_scalar_range = Scalar_Range (Etype (gnat_hb)))
6874 && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition
6875 || Nkind (gnat_scalar_range) == N_Range))
6876 gnat_hb = Low_Bound (gnat_scalar_range);
6878 /* If we have failed to find constant bounds, punt. */
6879 if (Nkind (gnat_lb) != N_Integer_Literal
6880 || Nkind (gnat_hb) != N_Integer_Literal)
6881 return false;
6883 /* We need at least a signed 64-bit type to catch most cases. */
6884 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
6885 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
6886 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
6887 return false;
6889 /* If the low bound is the smallest integer, nothing can be smaller. */
6890 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
6891 if (TREE_OVERFLOW (gnu_lb_minus_one))
6892 return true;
6894 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
6897 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
6899 static bool
6900 constructor_address_p (tree gnu_expr)
6902 while (CONVERT_EXPR_P (gnu_expr)
6903 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
6904 gnu_expr = TREE_OPERAND (gnu_expr, 0);
6906 return (TREE_CODE (gnu_expr) == ADDR_EXPR
6907 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
6910 /* Return true if the size in units represented by GNU_SIZE can be handled by
6911 an allocation. If STATIC_P is true, consider only what can be done with a
6912 static allocation. */
6914 static bool
6915 allocatable_size_p (tree gnu_size, bool static_p)
6917 /* We can allocate a fixed size if it is a valid for the middle-end but, for
6918 a static allocation, we do not allocate more than 2 GB because this would
6919 very likely be unintended and problematic for usual code models. */
6920 if (TREE_CODE (gnu_size) == INTEGER_CST)
6921 return valid_constant_size_p (gnu_size)
6922 && (!static_p || tree_to_uhwi (gnu_size) <= INT_MAX);
6924 /* We can allocate a variable size if this isn't a static allocation. */
6925 else
6926 return !static_p;
6929 /* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
6930 initial value of an object of GNU_TYPE. */
6932 static bool
6933 initial_value_needs_conversion (tree gnu_type, tree gnu_expr)
6935 /* Do not convert if the object's type is unconstrained because this would
6936 generate useless evaluations of the CONSTRUCTOR to compute the size. */
6937 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
6938 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
6939 return false;
6941 /* Do not convert if the object's type is a padding record whose field is of
6942 self-referential size because we want to copy only the actual data. */
6943 if (type_is_padding_self_referential (gnu_type))
6944 return false;
6946 /* Do not convert a call to a function that returns with variable size since
6947 we want to use the return slot optimization in this case. */
6948 if (TREE_CODE (gnu_expr) == CALL_EXPR
6949 && return_type_with_variable_size_p (TREE_TYPE (gnu_expr)))
6950 return false;
6952 /* Do not convert to a record type with a variant part from a record type
6953 without one, to keep the object simpler. */
6954 if (TREE_CODE (gnu_type) == RECORD_TYPE
6955 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
6956 && get_variant_part (gnu_type)
6957 && !get_variant_part (TREE_TYPE (gnu_expr)))
6958 return false;
6960 /* In all the other cases, convert the expression to the object's type. */
6961 return true;
6964 /* Add the contribution of [MIN, MAX] to the current number of elements N_ELEM
6965 of an array type and return the result, or NULL_TREE if it overflowed. */
6967 static tree
6968 update_n_elem (tree n_elem, tree min, tree max)
6970 /* First deal with the empty case. */
6971 if (TREE_CODE (min) == INTEGER_CST
6972 && TREE_CODE (max) == INTEGER_CST
6973 && tree_int_cst_lt (max, min))
6974 return size_zero_node;
6976 min = convert (sizetype, min);
6977 max = convert (sizetype, max);
6979 /* Compute the number of elements in this dimension. */
6980 tree this_n_elem
6981 = size_binop (PLUS_EXPR, size_one_node, size_binop (MINUS_EXPR, max, min));
6983 if (TREE_CODE (this_n_elem) == INTEGER_CST && TREE_OVERFLOW (this_n_elem))
6984 return NULL_TREE;
6986 /* Multiply the current number of elements by the result. */
6987 n_elem = size_binop (MULT_EXPR, n_elem, this_n_elem);
6989 if (TREE_CODE (n_elem) == INTEGER_CST && TREE_OVERFLOW (n_elem))
6990 return NULL_TREE;
6992 return n_elem;
6995 /* Given GNAT_ENTITY, elaborate all expressions that are required to
6996 be elaborated at the point of its definition, but do nothing else. */
6998 void
6999 elaborate_entity (Entity_Id gnat_entity)
7001 switch (Ekind (gnat_entity))
7003 case E_Signed_Integer_Subtype:
7004 case E_Modular_Integer_Subtype:
7005 case E_Enumeration_Subtype:
7006 case E_Ordinary_Fixed_Point_Subtype:
7007 case E_Decimal_Fixed_Point_Subtype:
7008 case E_Floating_Point_Subtype:
7010 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
7011 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
7013 /* ??? Tests to avoid Constraint_Error in static expressions
7014 are needed until after the front stops generating bogus
7015 conversions on bounds of real types. */
7016 if (!Raises_Constraint_Error (gnat_lb))
7017 elaborate_expression (gnat_lb, gnat_entity, "L", true, false,
7018 Needs_Debug_Info (gnat_entity));
7019 if (!Raises_Constraint_Error (gnat_hb))
7020 elaborate_expression (gnat_hb, gnat_entity, "U", true, false,
7021 Needs_Debug_Info (gnat_entity));
7022 break;
7025 case E_Record_Subtype:
7026 case E_Private_Subtype:
7027 case E_Limited_Private_Subtype:
7028 case E_Record_Subtype_With_Private:
7029 if (Has_Discriminants (gnat_entity) && Is_Constrained (gnat_entity))
7031 Node_Id gnat_discriminant_expr;
7032 Entity_Id gnat_field;
7034 for (gnat_field
7035 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
7036 gnat_discriminant_expr
7037 = First_Elmt (Discriminant_Constraint (gnat_entity));
7038 Present (gnat_field);
7039 gnat_field = Next_Discriminant (gnat_field),
7040 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
7041 /* Ignore access discriminants. */
7042 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
7043 elaborate_expression (Node (gnat_discriminant_expr),
7044 gnat_entity, get_entity_char (gnat_field),
7045 true, false, false);
7047 break;
7049 /* -Wswitch warning avoidance. */
7050 default:
7051 break;
7055 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
7056 NAME, ARGS and ERROR_POINT. */
7058 static void
7059 prepend_one_attribute (struct attrib **attr_list,
7060 enum attrib_type attrib_type,
7061 tree attr_name,
7062 tree attr_args,
7063 Node_Id attr_error_point)
7065 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
7067 attr->type = attrib_type;
7068 attr->name = attr_name;
7069 attr->args = attr_args;
7070 attr->error_point = attr_error_point;
7072 attr->next = *attr_list;
7073 *attr_list = attr;
7076 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
7078 static void
7079 prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma)
7081 const Node_Id gnat_arg = First (Pragma_Argument_Associations (gnat_pragma));
7082 Node_Id gnat_next_arg = Next (gnat_arg);
7083 tree gnu_arg1 = NULL_TREE, gnu_arg_list = NULL_TREE;
7084 enum attrib_type etype;
7086 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
7087 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
7089 case Pragma_Linker_Alias:
7090 etype = ATTR_LINK_ALIAS;
7091 break;
7093 case Pragma_Linker_Constructor:
7094 etype = ATTR_LINK_CONSTRUCTOR;
7095 break;
7097 case Pragma_Linker_Destructor:
7098 etype = ATTR_LINK_DESTRUCTOR;
7099 break;
7101 case Pragma_Linker_Section:
7102 etype = ATTR_LINK_SECTION;
7103 break;
7105 case Pragma_Machine_Attribute:
7106 etype = ATTR_MACHINE_ATTRIBUTE;
7107 break;
7109 case Pragma_Thread_Local_Storage:
7110 etype = ATTR_THREAD_LOCAL_STORAGE;
7111 break;
7113 case Pragma_Weak_External:
7114 etype = ATTR_WEAK_EXTERNAL;
7115 break;
7117 default:
7118 return;
7121 /* See what arguments we have and turn them into GCC trees for attribute
7122 handlers. The first one is always expected to be a string meant to be
7123 turned into an identifier. The next ones are all static expressions,
7124 among which strings meant to be turned into an identifier, except for
7125 a couple of specific attributes that require raw strings. */
7126 if (Present (gnat_next_arg))
7128 gnu_arg1 = gnat_to_gnu (Expression (gnat_next_arg));
7129 gcc_assert (TREE_CODE (gnu_arg1) == STRING_CST);
7131 const char *const p = TREE_STRING_POINTER (gnu_arg1);
7132 const bool string_args
7133 = strcmp (p, "simd") == 0
7134 || strcmp (p, "target") == 0
7135 || strcmp (p, "target_clones") == 0;
7136 gnu_arg1 = get_identifier (p);
7137 if (IDENTIFIER_LENGTH (gnu_arg1) == 0)
7138 return;
7139 gnat_next_arg = Next (gnat_next_arg);
7141 while (Present (gnat_next_arg))
7143 tree gnu_arg = gnat_to_gnu (Expression (gnat_next_arg));
7144 if (TREE_CODE (gnu_arg) == STRING_CST && !string_args)
7145 gnu_arg = get_identifier (TREE_STRING_POINTER (gnu_arg));
7146 gnu_arg_list
7147 = chainon (gnu_arg_list, build_tree_list (NULL_TREE, gnu_arg));
7148 gnat_next_arg = Next (gnat_next_arg);
7152 prepend_one_attribute (attr_list, etype, gnu_arg1, gnu_arg_list,
7153 Present (Next (gnat_arg))
7154 ? Expression (Next (gnat_arg)) : gnat_pragma);
7157 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
7159 static void
7160 prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
7162 Node_Id gnat_temp;
7164 /* Attributes are stored as Representation Item pragmas. */
7165 for (gnat_temp = First_Rep_Item (gnat_entity);
7166 Present (gnat_temp);
7167 gnat_temp = Next_Rep_Item (gnat_temp))
7168 if (Nkind (gnat_temp) == N_Pragma)
7169 prepend_one_attribute_pragma (attr_list, gnat_temp);
7172 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
7173 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
7174 return the GCC tree to use for that expression. S is the suffix to use
7175 if a variable needs to be created and DEFINITION is true if this is done
7176 for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
7177 otherwise, we are just elaborating the expression for side-effects. If
7178 NEED_FOR_DEBUG is true, we need a variable for debugging purposes even
7179 if it isn't needed for code generation. */
7181 static tree
7182 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
7183 bool definition, bool need_value, bool need_for_debug)
7185 tree gnu_expr;
7187 /* If we already elaborated this expression (e.g. it was involved
7188 in the definition of a private type), use the old value. */
7189 if (present_gnu_tree (gnat_expr))
7190 return get_gnu_tree (gnat_expr);
7192 /* If we don't need a value and this is static or a discriminant,
7193 we don't need to do anything. */
7194 if (!need_value
7195 && (Compile_Time_Known_Value (gnat_expr)
7196 || (Nkind (gnat_expr) == N_Identifier
7197 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
7198 return NULL_TREE;
7200 /* If it's a static expression, we don't need a variable for debugging. */
7201 if (need_for_debug && Compile_Time_Known_Value (gnat_expr))
7202 need_for_debug = false;
7204 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
7205 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s,
7206 definition, need_for_debug);
7208 /* Save the expression in case we try to elaborate this entity again. Since
7209 it's not a DECL, don't check it. Don't save if it's a discriminant. */
7210 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
7211 save_gnu_tree (gnat_expr, gnu_expr, true);
7213 return need_value ? gnu_expr : error_mark_node;
7216 /* Similar, but take a GNU expression and always return a result. */
7218 static tree
7219 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
7220 bool definition, bool need_for_debug)
7222 const bool expr_public_p = Is_Public (gnat_entity);
7223 const bool expr_global_p = expr_public_p || global_bindings_p ();
7224 bool expr_variable_p, use_variable;
7226 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
7227 that an expression cannot contain both a discriminant and a variable. */
7228 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
7229 return gnu_expr;
7231 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
7232 a variable that is initialized to contain the expression when the package
7233 containing the definition is elaborated. If this entity is defined at top
7234 level, replace the expression by the variable; otherwise use a SAVE_EXPR
7235 if this is necessary. */
7236 if (TREE_CONSTANT (gnu_expr))
7237 expr_variable_p = false;
7238 else
7240 /* Skip any conversions and simple constant arithmetics to see if the
7241 expression is based on a read-only variable. */
7242 tree inner = remove_conversions (gnu_expr, true);
7244 inner = skip_simple_constant_arithmetic (inner);
7246 if (handled_component_p (inner))
7247 inner = get_inner_constant_reference (inner);
7249 expr_variable_p
7250 = !(inner
7251 && VAR_P (inner)
7252 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
7255 /* We only need to use the variable if we are in a global context since GCC
7256 can do the right thing in the local case. However, when not optimizing,
7257 use it for bounds of loop iteration scheme to avoid code duplication. */
7258 use_variable = expr_variable_p
7259 && (expr_global_p
7260 || (!optimize
7261 && definition
7262 && Is_Itype (gnat_entity)
7263 && Nkind (Associated_Node_For_Itype (gnat_entity))
7264 == N_Loop_Parameter_Specification));
7266 /* If the GNAT encodings are not used, we don't need a variable for debug
7267 info purposes if the expression is a constant or another variable, but
7268 we must be careful because we do not generate debug info for external
7269 variables so DECL_IGNORED_P is not stable across units. */
7270 if (need_for_debug
7271 && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL
7272 && (TREE_CONSTANT (gnu_expr)
7273 || (!expr_public_p
7274 && DECL_P (gnu_expr)
7275 && !DECL_IGNORED_P (gnu_expr))))
7276 need_for_debug = false;
7278 /* Now create it, possibly only for debugging purposes. */
7279 if (use_variable || need_for_debug)
7281 /* The following variable creation can happen when processing the body
7282 of subprograms that are defined outside of the extended main unit and
7283 inlined. In this case, we are not at the global scope, and thus the
7284 new variable must not be tagged "external", as we used to do here as
7285 soon as DEFINITION was false. And note that we test Needs_Debug_Info
7286 here instead of NEED_FOR_DEBUG because, once the variable is created,
7287 whether or not debug information is generated for it is orthogonal to
7288 the reason why it was created in the first place. */
7289 tree gnu_decl
7290 = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE,
7291 TREE_TYPE (gnu_expr), gnu_expr, true,
7292 expr_public_p, !definition && expr_global_p,
7293 expr_global_p, false, true,
7294 Needs_Debug_Info (gnat_entity),
7295 NULL, gnat_entity, false);
7297 /* Using this variable for debug (if need_for_debug is true) requires
7298 a proper location. The back-end will compute a location for this
7299 variable only if the variable is used by the generated code.
7300 Returning the variable ensures the caller will use it in generated
7301 code. Note that there is no need for a location if the debug info
7302 contains an integer constant. */
7303 if (use_variable || (need_for_debug && !TREE_CONSTANT (gnu_expr)))
7304 return gnu_decl;
7307 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
7310 /* Similar, but take an alignment factor and make it explicit in the tree. */
7312 static tree
7313 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
7314 bool definition, bool need_for_debug, unsigned int align)
7316 tree unit_align = size_int (align / BITS_PER_UNIT);
7317 return
7318 size_binop (MULT_EXPR,
7319 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
7320 gnu_expr,
7321 unit_align),
7322 gnat_entity, s, definition,
7323 need_for_debug),
7324 unit_align);
7327 /* Structure to hold internal data for elaborate_reference. */
7329 struct er_data
7331 Entity_Id entity;
7332 bool definition;
7333 unsigned int n;
7336 /* Wrapper function around elaborate_expression_1 for elaborate_reference. */
7338 static tree
7339 elaborate_reference_1 (tree ref, void *data)
7341 struct er_data *er = (struct er_data *)data;
7342 char suffix[16];
7344 /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */
7345 if (TREE_CONSTANT (ref))
7346 return ref;
7348 /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat
7349 pointer. This may be more efficient, but will also allow us to more
7350 easily find the match for the PLACEHOLDER_EXPR. */
7351 if (TREE_CODE (ref) == COMPONENT_REF
7352 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
7353 return build3 (COMPONENT_REF, TREE_TYPE (ref),
7354 elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
7355 TREE_OPERAND (ref, 1), NULL_TREE);
7357 /* If this is the displacement of a pointer, elaborate the pointer and then
7358 displace the result. The actual purpose here is to drop the location on
7359 the expression, which may be problematic if replicated on references. */
7360 if (TREE_CODE (ref) == POINTER_PLUS_EXPR
7361 && TREE_CODE (TREE_OPERAND (ref, 1)) == INTEGER_CST)
7362 return build2 (POINTER_PLUS_EXPR, TREE_TYPE (ref),
7363 elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
7364 TREE_OPERAND (ref, 1));
7366 sprintf (suffix, "EXP%d", ++er->n);
7367 return
7368 elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
7371 /* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
7372 DEFINITION is true if this is done for a definition of GNAT_ENTITY and
7373 INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
7375 static tree
7376 elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
7377 tree *init)
7379 struct er_data er = { gnat_entity, definition, 0 };
7380 return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
7383 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
7384 the value passed against the list of choices. */
7386 static tree
7387 choices_to_gnu (tree gnu_operand, Node_Id gnat_choices)
7389 tree gnu_result = boolean_false_node, gnu_type;
7391 gnu_operand = maybe_character_value (gnu_operand);
7392 gnu_type = TREE_TYPE (gnu_operand);
7394 for (Node_Id gnat_choice = First (gnat_choices);
7395 Present (gnat_choice);
7396 gnat_choice = Next (gnat_choice))
7398 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
7399 tree gnu_test;
7401 switch (Nkind (gnat_choice))
7403 case N_Range:
7404 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
7405 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
7406 break;
7408 case N_Subtype_Indication:
7409 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
7410 (Constraint (gnat_choice))));
7411 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
7412 (Constraint (gnat_choice))));
7413 break;
7415 case N_Identifier:
7416 case N_Expanded_Name:
7417 /* This represents either a subtype range or a static value of
7418 some kind; Ekind says which. */
7419 if (Is_Type (Entity (gnat_choice)))
7421 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
7423 gnu_low = TYPE_MIN_VALUE (gnu_type);
7424 gnu_high = TYPE_MAX_VALUE (gnu_type);
7425 break;
7428 /* ... fall through ... */
7430 case N_Character_Literal:
7431 case N_Integer_Literal:
7432 gnu_low = gnat_to_gnu (gnat_choice);
7433 break;
7435 case N_Others_Choice:
7436 break;
7438 default:
7439 gcc_unreachable ();
7442 /* Everything should be folded into constants at this point. */
7443 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
7444 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
7446 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
7447 gnu_low = convert (gnu_type, gnu_low);
7448 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
7449 gnu_high = convert (gnu_type, gnu_high);
7451 if (gnu_low && gnu_high)
7452 gnu_test
7453 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
7454 build_binary_op (GE_EXPR, boolean_type_node,
7455 gnu_operand, gnu_low, true),
7456 build_binary_op (LE_EXPR, boolean_type_node,
7457 gnu_operand, gnu_high, true),
7458 true);
7459 else if (gnu_low == boolean_true_node
7460 && TREE_TYPE (gnu_operand) == boolean_type_node)
7461 gnu_test = gnu_operand;
7462 else if (gnu_low)
7463 gnu_test
7464 = build_binary_op (EQ_EXPR, boolean_type_node, gnu_operand, gnu_low,
7465 true);
7466 else
7467 gnu_test = boolean_true_node;
7469 if (gnu_result == boolean_false_node)
7470 gnu_result = gnu_test;
7471 else
7472 gnu_result
7473 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_result,
7474 gnu_test, true);
7477 return gnu_result;
7480 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
7481 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
7483 static int
7484 adjust_packed (tree field_type, tree record_type, int packed)
7486 /* If the field is an array of variable size, we'd better not pack it because
7487 this would misalign it and, therefore, probably cause large temporarie to
7488 be created in case we need to take its address. See addressable_p and the
7489 notes on the addressability issues for further details. */
7490 if (TREE_CODE (field_type) == ARRAY_TYPE
7491 && type_has_variable_size (field_type))
7492 return 0;
7494 /* In the other cases, we can honor the packing. */
7495 if (packed)
7496 return packed;
7498 /* If the alignment of the record is specified and the field type
7499 is over-aligned, request Storage_Unit alignment for the field. */
7500 if (TYPE_ALIGN (record_type)
7501 && TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
7502 return -1;
7504 /* Likewise if the maximum alignment of the record is specified. */
7505 if (TYPE_MAX_ALIGN (record_type)
7506 && TYPE_ALIGN (field_type) > TYPE_MAX_ALIGN (record_type))
7507 return -1;
7509 return 0;
7512 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
7513 placed in GNU_RECORD_TYPE.
7515 PACKED is 1 if the enclosing record is packed or -1 if the enclosing
7516 record has Component_Alignment of Storage_Unit.
7518 DEFINITION is true if this field is for a record being defined.
7520 DEBUG_INFO_P is true if we need to write debug information for types
7521 that we may create in the process. */
7523 static tree
7524 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
7525 bool definition, bool debug_info_p)
7527 const Node_Id gnat_clause = Component_Clause (gnat_field);
7528 const Entity_Id gnat_record_type = Underlying_Type (Scope (gnat_field));
7529 const Entity_Id gnat_field_type = Etype (gnat_field);
7530 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
7531 tree gnu_field_id = get_entity_name (gnat_field);
7532 const bool is_aliased = Is_Aliased (gnat_field);
7533 const bool is_full_access
7534 = (Is_Full_Access (gnat_field) || Is_Full_Access (gnat_field_type));
7535 const bool is_independent
7536 = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
7537 const bool is_volatile
7538 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
7539 const bool is_by_ref = TYPE_IS_BY_REFERENCE_P (gnu_field_type);
7540 const bool is_strict_alignment = Strict_Alignment (gnat_field_type);
7541 /* We used to consider that volatile fields also require strict alignment,
7542 but that was an interpolation and would cause us to reject a pragma
7543 volatile on a packed record type containing boolean components, while
7544 there is no basis to do so in the RM. In such cases, the writes will
7545 involve load-modify-store sequences, but that's OK for volatile. The
7546 only constraint is the implementation advice whereby only the bits of
7547 the components should be accessed if they both start and end on byte
7548 boundaries, but that should be guaranteed by the GCC memory model.
7549 Note that we have some redundancies (is_full_access => is_independent,
7550 is_aliased => is_independent and is_by_ref => is_strict_alignment)
7551 so the following formula is sufficient. */
7552 const bool needs_strict_alignment = (is_independent || is_strict_alignment);
7553 const char *field_s, *size_s;
7554 tree gnu_field, gnu_size, gnu_pos;
7555 bool is_bitfield;
7557 /* Force the type of the Not_Handled_By_Others field to be that of the
7558 field in struct Exception_Data declared in raise.h instead of using
7559 the declared boolean type. We need to do that because there is no
7560 easy way to make use of a C compatible boolean type for the latter. */
7561 if (gnu_field_id == not_handled_by_others_name_id
7562 && gnu_field_type == boolean_type_node)
7563 gnu_field_type = char_type_node;
7565 /* The qualifier to be used in messages. */
7566 if (is_aliased)
7567 field_s = "aliased&";
7568 else if (is_full_access)
7570 if (Is_Volatile_Full_Access (gnat_field)
7571 || Is_Volatile_Full_Access (gnat_field_type))
7572 field_s = "volatile full access&";
7573 else
7574 field_s = "atomic&";
7576 else if (is_independent)
7577 field_s = "independent&";
7578 else if (is_by_ref)
7579 field_s = "& with by-reference type";
7580 else if (is_strict_alignment)
7581 field_s = "& with aliased part";
7582 else
7583 field_s = "&";
7585 /* The message to be used for incompatible size. */
7586 if (is_aliased || is_full_access)
7587 size_s = "size for %s must be ^";
7588 else if (field_s)
7589 size_s = "size for %s too small{, minimum allowed is ^}";
7591 /* If a field requires strict alignment, we cannot pack it (RM 13.2(7)). */
7592 if (needs_strict_alignment)
7593 packed = 0;
7594 else
7595 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
7597 /* If a size is specified, use it. Otherwise, if the record type is packed,
7598 use the official RM size. See "Handling of Type'Size Values" in Einfo
7599 for further details. */
7600 if (Present (gnat_clause) || Known_Esize (gnat_field))
7601 gnu_size = validate_size (Esize (gnat_field), gnu_field_type, gnat_field,
7602 FIELD_DECL, false, true, size_s, field_s);
7603 else if (packed == 1)
7605 gnu_size = rm_size (gnu_field_type);
7606 if (TREE_CODE (gnu_size) != INTEGER_CST)
7607 gnu_size = NULL_TREE;
7609 else
7610 gnu_size = NULL_TREE;
7612 /* Likewise for the position. */
7613 if (Present (gnat_clause))
7615 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
7616 is_bitfield = !value_factor_p (gnu_pos, BITS_PER_UNIT);
7619 /* If the record has rep clauses and this is the tag field, make a rep
7620 clause for it as well. */
7621 else if (Has_Specified_Layout (gnat_record_type)
7622 && Chars (gnat_field) == Name_uTag)
7624 gnu_pos = bitsize_zero_node;
7625 gnu_size = TYPE_SIZE (gnu_field_type);
7626 is_bitfield = false;
7629 else
7631 gnu_pos = NULL_TREE;
7632 is_bitfield = false;
7635 /* If the field's type is a fixed-size record that does not require strict
7636 alignment, and the record is packed or we have a position specified for
7637 the field that makes it a bitfield or we have a specified size that is
7638 smaller than that of the field's type, then see if we can get either an
7639 integral mode form of the field's type or a smaller form. If we can,
7640 consider that a size was specified for the field if there wasn't one
7641 already, so we know to make it a bitfield and avoid making things wider.
7643 Changing to an integral mode form is useful when the record is packed as
7644 we can then place the field at a non-byte-aligned position and so achieve
7645 tighter packing. This is in addition required if the field shares a byte
7646 with another field and the front-end lets the back-end handle the access
7647 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
7649 Changing to a smaller form is required if the specified size is smaller
7650 than that of the field's type and the type contains sub-fields that are
7651 padded, in order to avoid generating accesses to these sub-fields that
7652 are wider than the field.
7654 We avoid the transformation if it is not required or potentially useful,
7655 as it might entail an increase of the field's alignment and have ripple
7656 effects on the outer record type. A typical case is a field known to be
7657 byte-aligned and not to share a byte with another field. */
7658 if (!needs_strict_alignment
7659 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
7660 && !TYPE_FAT_POINTER_P (gnu_field_type)
7661 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
7662 && (packed == 1
7663 || is_bitfield
7664 || (gnu_size
7665 && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))))
7667 tree gnu_packable_type
7668 = make_packable_type (gnu_field_type, true, is_bitfield ? 1 : 0);
7669 if (gnu_packable_type != gnu_field_type)
7671 gnu_field_type = gnu_packable_type;
7672 if (!gnu_size)
7673 gnu_size = rm_size (gnu_field_type);
7677 /* Now check if the type of the field allows atomic access. */
7678 if (Is_Full_Access (gnat_field))
7680 const unsigned int align
7681 = promote_object_alignment (gnu_field_type, NULL_TREE, gnat_field);
7682 if (align > 0)
7683 gnu_field_type
7684 = maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field,
7685 false, definition, true);
7686 check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
7689 /* If a position is specified, check that it is valid. */
7690 if (gnu_pos)
7692 Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
7694 /* Ensure the position doesn't overlap with the parent subtype if there
7695 is one. It would be impossible to build CONSTRUCTORs and accessing
7696 the parent could clobber the component in the extension if directly
7697 done. We accept it with -gnatd.K for the sake of compatibility. */
7698 if (Present (gnat_parent)
7699 && !(Debug_Flag_Dot_KK && Is_Fully_Repped_Tagged_Type (gnat_parent)))
7701 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
7703 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
7704 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
7705 post_error_ne_tree
7706 ("position for& must be beyond parent{, minimum allowed is ^}",
7707 Position (gnat_clause), gnat_field, TYPE_SIZE_UNIT (gnu_parent));
7710 /* If this field needs strict alignment, make sure that the record is
7711 sufficiently aligned and that the position and size are consistent
7712 with the type. But don't do it if we are just annotating types and
7713 the field's type is tagged, since tagged types aren't fully laid out
7714 in this mode. Also, note that atomic implies volatile so the inner
7715 test sequences ordering is significant here. */
7716 if (needs_strict_alignment
7717 && !(type_annotate_only && Is_Tagged_Type (gnat_field_type)))
7719 const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
7721 if (TYPE_ALIGN (gnu_record_type)
7722 && TYPE_ALIGN (gnu_record_type) < type_align)
7723 SET_TYPE_ALIGN (gnu_record_type, type_align);
7725 /* If the position is not a multiple of the storage unit, then error
7726 out and reset the position. */
7727 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
7728 bitsize_unit_node)))
7730 char s[128];
7731 snprintf (s, sizeof (s), "position for %s must be "
7732 "multiple of Storage_Unit", field_s);
7733 post_error_ne (s, First_Bit (gnat_clause), gnat_field);
7734 gnu_pos = NULL_TREE;
7737 /* If the position is not a multiple of the alignment of the type,
7738 then error out and reset the position. */
7739 else if (type_align > BITS_PER_UNIT
7740 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
7741 bitsize_int (type_align))))
7743 char s[128];
7744 snprintf (s, sizeof (s), "position for %s must be multiple of ^",
7745 field_s);
7746 post_error_ne_num (s, First_Bit (gnat_clause), gnat_field,
7747 type_align / BITS_PER_UNIT);
7748 post_error_ne_num ("\\because alignment of its type& is ^",
7749 First_Bit (gnat_clause), Etype (gnat_field),
7750 type_align / BITS_PER_UNIT);
7751 gnu_pos = NULL_TREE;
7754 if (gnu_size)
7756 tree type_size = TYPE_SIZE (gnu_field_type);
7757 int cmp;
7759 /* If the size is not a multiple of the storage unit, then error
7760 out and reset the size. */
7761 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
7762 bitsize_unit_node)))
7764 char s[128];
7765 snprintf (s, sizeof (s), "size for %s must be "
7766 "multiple of Storage_Unit", field_s);
7767 post_error_ne (s, Last_Bit (gnat_clause), gnat_field);
7768 gnu_size = NULL_TREE;
7771 /* If the size is lower than that of the type, or greater for
7772 atomic and aliased, then error out and reset the size. */
7773 else if ((cmp = tree_int_cst_compare (gnu_size, type_size)) < 0
7774 || (cmp > 0 && (is_aliased || is_full_access)))
7776 char s[128];
7777 snprintf (s, sizeof (s), size_s, field_s);
7778 post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field,
7779 type_size);
7780 gnu_size = NULL_TREE;
7786 else
7788 /* If we are packing the record and the field is BLKmode, round the
7789 size up to a byte boundary. */
7790 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
7791 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
7794 /* We need to make the size the maximum for the type if it is
7795 self-referential and an unconstrained type. In that case, we can't
7796 pack the field since we can't make a copy to align it. */
7797 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
7798 && !gnu_size
7799 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
7800 && !Is_Constrained (Underlying_Type (gnat_field_type)))
7802 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
7803 packed = 0;
7806 /* If a size is specified, adjust the field's type to it. */
7807 if (gnu_size)
7809 tree orig_field_type;
7811 /* If the field's type is justified modular, we would need to remove
7812 the wrapper to (better) meet the layout requirements. However we
7813 can do so only if the field is not aliased to preserve the unique
7814 layout, if it has the same storage order as the enclosing record
7815 and if the prescribed size is not greater than that of the packed
7816 array to preserve the justification. */
7817 if (!needs_strict_alignment
7818 && TREE_CODE (gnu_field_type) == RECORD_TYPE
7819 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
7820 && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type)
7821 == Reverse_Storage_Order (gnat_record_type)
7822 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
7823 <= 0)
7824 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7826 /* Similarly if the field's type is a misaligned integral type, but
7827 there is no restriction on the size as there is no justification. */
7828 if (!needs_strict_alignment
7829 && TYPE_IS_PADDING_P (gnu_field_type)
7830 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
7831 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7833 orig_field_type = gnu_field_type;
7834 gnu_field_type
7835 = make_type_from_size (gnu_field_type, gnu_size,
7836 Has_Biased_Representation (gnat_field));
7838 /* If the type has been extended, we may need to cap the alignment. */
7839 if (!needs_strict_alignment
7840 && gnu_field_type != orig_field_type
7841 && tree_int_cst_lt (TYPE_SIZE (orig_field_type), gnu_size))
7842 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
7844 orig_field_type = gnu_field_type;
7845 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
7846 false, definition, true);
7848 /* For a bitfield, if the type still has BLKmode, try again to change it
7849 to an integral mode form. This may be necessary on strict-alignment
7850 platforms with a size clause that is much larger than the field type,
7851 because maybe_pad_type has preserved the alignment of the field type,
7852 which may be too low for the new size. */
7853 if (!needs_strict_alignment
7854 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
7855 && !TYPE_FAT_POINTER_P (gnu_field_type)
7856 && TYPE_MODE (gnu_field_type) == BLKmode
7857 && is_bitfield)
7858 gnu_field_type = make_packable_type (gnu_field_type, true, 1);
7860 /* If a padding record was made, declare it now since it will never be
7861 declared otherwise. This is necessary to ensure that its subtrees
7862 are properly marked. */
7863 if (gnu_field_type != orig_field_type
7864 && !DECL_P (TYPE_NAME (gnu_field_type)))
7865 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true,
7866 debug_info_p, gnat_field);
7869 /* Otherwise (or if there was an error), don't specify a position. */
7870 else
7871 gnu_pos = NULL_TREE;
7873 /* If the field's type is a padded type made for a scalar field of a record
7874 type with reverse storage order, we need to propagate the reverse storage
7875 order to the padding type since it is the innermost enclosing aggregate
7876 type around the scalar. */
7877 if (TYPE_IS_PADDING_P (gnu_field_type)
7878 && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type)
7879 && Is_Scalar_Type (gnat_field_type))
7880 gnu_field_type = set_reverse_storage_order_on_pad_type (gnu_field_type);
7882 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
7883 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
7885 /* Now create the decl for the field. */
7886 gnu_field
7887 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
7888 gnu_size, gnu_pos, packed, is_aliased);
7889 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
7890 DECL_ALIASED_P (gnu_field) = is_aliased;
7891 TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile;
7893 /* If this is a discriminant, then we treat it specially: first, we set its
7894 index number for the back-annotation; second, we record whether it cannot
7895 be changed once it has been set for the computation of loop invariants;
7896 third, we make it addressable in order for the optimizer to more easily
7897 see that it cannot be modified by assignments to the other fields of the
7898 record (see create_field_decl for a more detailed explanation), which is
7899 crucial to hoist the offset and size computations of dynamic fields. */
7900 if (Ekind (gnat_field) == E_Discriminant)
7902 DECL_DISCRIMINANT_NUMBER (gnu_field)
7903 = UI_To_gnu (Discriminant_Number (gnat_field), integer_type_node);
7904 DECL_INVARIANT_P (gnu_field)
7905 = No (Discriminant_Default_Value (gnat_field));
7906 DECL_NONADDRESSABLE_P (gnu_field) = 0;
7909 return gnu_field;
7912 /* Return true if at least one member of COMPONENT_LIST needs strict
7913 alignment. */
7915 static bool
7916 components_need_strict_alignment (Node_Id component_list)
7918 Node_Id component_decl;
7920 for (component_decl = First_Non_Pragma (Component_Items (component_list));
7921 Present (component_decl);
7922 component_decl = Next_Non_Pragma (component_decl))
7924 Entity_Id gnat_field = Defining_Entity (component_decl);
7926 if (Is_Independent (gnat_field) || Is_Independent (Etype (gnat_field)))
7927 return true;
7929 if (Strict_Alignment (Etype (gnat_field)))
7930 return true;
7933 return false;
7936 /* Return true if FIELD is an artificial field. */
7938 static bool
7939 field_is_artificial (tree field)
7941 /* These fields are generated by the front-end proper. */
7942 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
7943 return true;
7945 /* These fields are generated by gigi. */
7946 if (DECL_INTERNAL_P (field))
7947 return true;
7949 return false;
7952 /* Return true if FIELD is a non-artificial field with self-referential
7953 size. */
7955 static bool
7956 field_has_self_size (tree field)
7958 if (field_is_artificial (field))
7959 return false;
7961 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7962 return false;
7964 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
7967 /* Return true if FIELD is a non-artificial field with variable size. */
7969 static bool
7970 field_has_variable_size (tree field)
7972 if (field_is_artificial (field))
7973 return false;
7975 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7976 return false;
7978 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
7981 /* qsort comparer for the bit positions of two record components. */
7983 static int
7984 compare_field_bitpos (const void *rt1, const void *rt2)
7986 const_tree const field1 = * (const_tree const *) rt1;
7987 const_tree const field2 = * (const_tree const *) rt2;
7988 const int ret
7989 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7991 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7994 /* Sort the LIST of fields in reverse order of increasing position. */
7996 static tree
7997 reverse_sort_field_list (tree list)
7999 const int len = list_length (list);
8000 tree *field_arr = XALLOCAVEC (tree, len);
8002 for (int i = 0; list; list = DECL_CHAIN (list), i++)
8003 field_arr[i] = list;
8005 qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
8007 for (int i = 0; i < len; i++)
8009 DECL_CHAIN (field_arr[i]) = list;
8010 list = field_arr[i];
8013 return list;
8016 /* Reverse function from gnat_to_gnu_field: return the GNAT field present in
8017 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and
8018 corresponding to the GNU tree GNU_FIELD. */
8020 static Entity_Id
8021 gnu_field_to_gnat (tree gnu_field, Node_Id gnat_component_list,
8022 Entity_Id gnat_record_type)
8024 Entity_Id gnat_component_decl, gnat_field;
8026 if (Present (Component_Items (gnat_component_list)))
8027 for (gnat_component_decl
8028 = First_Non_Pragma (Component_Items (gnat_component_list));
8029 Present (gnat_component_decl);
8030 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
8032 gnat_field = Defining_Entity (gnat_component_decl);
8033 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
8034 return gnat_field;
8037 if (Has_Discriminants (gnat_record_type))
8038 for (gnat_field = First_Stored_Discriminant (gnat_record_type);
8039 Present (gnat_field);
8040 gnat_field = Next_Stored_Discriminant (gnat_field))
8041 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
8042 return gnat_field;
8044 return Empty;
8047 /* Issue a warning for the problematic placement of GNU_FIELD present in
8048 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE.
8049 IN_VARIANT is true if GNAT_COMPONENT_LIST is the list of a variant.
8050 DO_REORDER is true if fields of GNAT_RECORD_TYPE are being reordered. */
8052 static void
8053 warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list,
8054 Entity_Id gnat_record_type, bool in_variant,
8055 bool do_reorder)
8057 if (!Comes_From_Source (gnat_record_type))
8058 return;
8060 Entity_Id gnat_field
8061 = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type);
8062 gcc_assert (Present (gnat_field));
8064 const char *msg1
8065 = in_variant
8066 ? "?.q?variant layout may cause performance issues"
8067 : "?.q?record layout may cause performance issues";
8068 const char *msg2
8069 = Ekind (gnat_field) == E_Discriminant
8070 ? "?.q?discriminant & whose length is not multiple of a byte"
8071 : field_has_self_size (gnu_field)
8072 ? "?.q?component & whose length depends on a discriminant"
8073 : field_has_variable_size (gnu_field)
8074 ? "?.q?component & whose length is not fixed"
8075 : "?.q?component & whose length is not multiple of a byte";
8076 const char *msg3
8077 = do_reorder
8078 ? "?.q?comes too early and was moved down"
8079 : "?.q?comes too early and ought to be moved down";
8081 post_error (msg1, gnat_field);
8082 post_error_ne (msg2, gnat_field, gnat_field);
8083 post_error (msg3, gnat_field);
8086 /* Likewise but for every field present on GNU_FIELD_LIST. */
8088 static void
8089 warn_on_list_placement (tree gnu_field_list, Node_Id gnat_component_list,
8090 Entity_Id gnat_record_type, bool in_variant,
8091 bool do_reorder)
8093 for (tree gnu_tmp = gnu_field_list; gnu_tmp; gnu_tmp = DECL_CHAIN (gnu_tmp))
8094 warn_on_field_placement (gnu_tmp, gnat_component_list, gnat_record_type,
8095 in_variant, do_reorder);
8098 /* Structure holding information for a given variant. */
8099 typedef struct vinfo
8101 /* The record type of the variant. */
8102 tree type;
8104 /* The name of the variant. */
8105 tree name;
8107 /* The qualifier of the variant. */
8108 tree qual;
8110 /* Whether the variant has a rep clause. */
8111 bool has_rep;
8113 /* Whether the variant is packed. */
8114 bool packed;
8116 } vinfo_t;
8118 /* Translate and chain GNAT_COMPONENT_LIST present in GNAT_RECORD_TYPE to
8119 GNU_FIELD_LIST, set the result as the field list of GNU_RECORD_TYPE and
8120 finish it up. Return true if GNU_RECORD_TYPE has a rep clause that affects
8121 the layout (see below). When called from gnat_to_gnu_entity during the
8122 processing of a record definition, the GCC node for the parent, if any,
8123 will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
8124 discriminants will be on GNU_FIELD_LIST. The other call to this function
8125 is a recursive call for the component list of a variant and, in this case,
8126 GNU_FIELD_LIST is empty. Note that GNAT_COMPONENT_LIST may be Empty.
8128 PACKED is 1 if this is for a packed record or -1 if this is for a record
8129 with Component_Alignment of Storage_Unit.
8131 DEFINITION is true if we are defining this record type.
8133 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
8134 out the record. This means the alignment only serves to force fields to
8135 be bitfields, but not to require the record to be that aligned. This is
8136 used for variants.
8138 ALL_REP is true if a rep clause is present for all the fields.
8140 UNCHECKED_UNION is true if we are building this type for a record with a
8141 Pragma Unchecked_Union.
8143 ARTIFICIAL is true if this is a type that was generated by the compiler.
8145 DEBUG_INFO is true if we need to write debug information about the type.
8147 IN_VARIANT is true if the componennt list is that of a variant.
8149 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
8150 the outer record type down to this variant level. It is nonzero only if
8151 all the fields down to this level have a rep clause and ALL_REP is false.
8153 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
8154 with a rep clause is to be added; in this case, that is all that should
8155 be done with such fields and the return value will be false. */
8157 static bool
8158 components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
8159 tree gnu_field_list, tree gnu_record_type, int packed,
8160 bool definition, bool cancel_alignment, bool all_rep,
8161 bool unchecked_union, bool artificial, bool debug_info,
8162 bool in_variant, tree first_free_pos,
8163 tree *p_gnu_rep_list)
8165 const bool needs_xv_encodings
8166 = debug_info && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL;
8167 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
8168 bool variants_have_rep = all_rep;
8169 bool layout_with_rep = false;
8170 bool has_non_packed_fixed_size_field = false;
8171 bool has_self_field = false;
8172 bool has_aliased_after_self_field = false;
8173 Entity_Id gnat_component_decl, gnat_variant_part;
8174 tree gnu_field, gnu_next, gnu_last;
8175 tree gnu_variant_part = NULL_TREE;
8176 tree gnu_rep_list = NULL_TREE;
8178 /* For each component referenced in a component declaration create a GCC
8179 field and add it to the list, skipping pragmas in the GNAT list. */
8180 gnu_last = tree_last (gnu_field_list);
8181 if (Present (gnat_component_list)
8182 && (Present (Component_Items (gnat_component_list))))
8183 for (gnat_component_decl
8184 = First_Non_Pragma (Component_Items (gnat_component_list));
8185 Present (gnat_component_decl);
8186 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
8188 Entity_Id gnat_field = Defining_Entity (gnat_component_decl);
8189 Name_Id gnat_name = Chars (gnat_field);
8191 /* If present, the _Parent field must have been created as the single
8192 field of the record type. Put it before any other fields. */
8193 if (gnat_name == Name_uParent)
8195 gnu_field = TYPE_FIELDS (gnu_record_type);
8196 gnu_field_list = chainon (gnu_field_list, gnu_field);
8198 else
8200 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
8201 definition, debug_info);
8203 /* If this is the _Tag field, put it before any other fields. */
8204 if (gnat_name == Name_uTag)
8205 gnu_field_list = chainon (gnu_field_list, gnu_field);
8207 /* If this is the _Controller field, put it before the other
8208 fields except for the _Tag or _Parent field. */
8209 else if (gnat_name == Name_uController && gnu_last)
8211 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
8212 DECL_CHAIN (gnu_last) = gnu_field;
8215 /* If this is a regular field, put it after the other fields. */
8216 else
8218 DECL_CHAIN (gnu_field) = gnu_field_list;
8219 gnu_field_list = gnu_field;
8220 if (!gnu_last)
8221 gnu_last = gnu_field;
8223 /* And record information for the final layout. */
8224 if (field_has_self_size (gnu_field))
8225 has_self_field = true;
8226 else if (has_self_field && DECL_ALIASED_P (gnu_field))
8227 has_aliased_after_self_field = true;
8228 else if (!DECL_FIELD_OFFSET (gnu_field)
8229 && !DECL_PACKED (gnu_field)
8230 && !field_has_variable_size (gnu_field))
8231 has_non_packed_fixed_size_field = true;
8235 save_gnu_tree (gnat_field, gnu_field, false);
8238 /* At the end of the component list there may be a variant part. */
8239 if (Present (gnat_component_list))
8240 gnat_variant_part = Variant_Part (gnat_component_list);
8241 else
8242 gnat_variant_part = Empty;
8244 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
8245 mutually exclusive and should go in the same memory. To do this we need
8246 to treat each variant as a record whose elements are created from the
8247 component list for the variant. So here we create the records from the
8248 lists for the variants and put them all into the QUAL_UNION_TYPE.
8249 If this is an Unchecked_Union, we make a UNION_TYPE instead or
8250 use GNU_RECORD_TYPE if there are no fields so far. */
8251 if (Present (gnat_variant_part))
8253 Node_Id gnat_discr = Name (gnat_variant_part), variant;
8254 tree gnu_discr = gnat_to_gnu (gnat_discr);
8255 tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
8256 tree gnu_var_name
8257 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
8258 "XVN");
8259 tree gnu_union_name
8260 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
8261 tree gnu_union_type;
8262 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
8263 bool union_field_needs_strict_alignment = false;
8264 bool innermost_variant_level = true;
8265 auto_vec <vinfo_t, 16> variant_types;
8266 vinfo_t *gnu_variant;
8267 unsigned int variants_align = 0;
8268 unsigned int i;
8270 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
8271 are all in the variant part, to match the layout of C unions. There
8272 is an associated check below. */
8273 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
8274 gnu_union_type = gnu_record_type;
8275 else
8277 gnu_union_type
8278 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
8280 TYPE_NAME (gnu_union_type) = gnu_union_name;
8281 SET_TYPE_ALIGN (gnu_union_type, 0);
8282 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
8283 TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
8284 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
8287 /* If all the fields down to this level have a rep clause, find out
8288 whether all the fields at this level also have one. If so, then
8289 compute the new first free position to be passed downward. */
8290 this_first_free_pos = first_free_pos;
8291 if (this_first_free_pos)
8293 for (gnu_field = gnu_field_list;
8294 gnu_field;
8295 gnu_field = DECL_CHAIN (gnu_field))
8296 if (DECL_FIELD_OFFSET (gnu_field))
8298 tree pos = bit_position (gnu_field);
8299 if (!tree_int_cst_lt (pos, this_first_free_pos))
8300 this_first_free_pos
8301 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
8303 else
8305 this_first_free_pos = NULL_TREE;
8306 break;
8310 /* For an unchecked union with a fixed part, we need to compute whether
8311 we are at the innermost level of the variant part. */
8312 if (unchecked_union && gnu_field_list)
8313 for (variant = First_Non_Pragma (Variants (gnat_variant_part));
8314 Present (variant);
8315 variant = Next_Non_Pragma (variant))
8316 if (Present (Component_List (variant))
8317 && Present (Variant_Part (Component_List (variant))))
8319 innermost_variant_level = false;
8320 break;
8323 /* We build the variants in two passes. The bulk of the work is done in
8324 the first pass, that is to say translating the GNAT nodes, building
8325 the container types and computing the associated properties. However
8326 we cannot finish up the container types during this pass because we
8327 don't know where the variant part will be placed until the end. */
8328 for (variant = First_Non_Pragma (Variants (gnat_variant_part));
8329 Present (variant);
8330 variant = Next_Non_Pragma (variant))
8332 tree gnu_variant_type = make_node (RECORD_TYPE);
8333 tree gnu_inner_name, gnu_qual;
8334 bool has_rep;
8335 int field_packed;
8336 vinfo_t vinfo;
8338 Get_Variant_Encoding (variant);
8339 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
8340 TYPE_NAME (gnu_variant_type)
8341 = concat_name (gnu_union_name,
8342 IDENTIFIER_POINTER (gnu_inner_name));
8344 /* Set the alignment of the inner type in case we need to make
8345 inner objects into bitfields, but then clear it out so the
8346 record actually gets only the alignment required. */
8347 SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
8348 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
8349 TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
8350 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
8352 /* Similarly, if the outer record has a size specified and all
8353 the fields have a rep clause, we can propagate the size. */
8354 if (all_rep_and_size)
8356 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
8357 TYPE_SIZE_UNIT (gnu_variant_type)
8358 = TYPE_SIZE_UNIT (gnu_record_type);
8361 /* Add the fields into the record type for the variant but note that
8362 we aren't sure to really use it at this point, see below. In the
8363 case of an unchecked union with a fixed part, we force the fields
8364 with a rep clause present in the innermost variant to be moved to
8365 the outer variant, so as to flatten the rep-ed layout as much as
8366 possible, the reason being that we cannot do any flattening when
8367 a subtype statically selects a variant later on, for example for
8368 an aggregate. */
8369 has_rep
8370 = components_to_record (Component_List (variant), gnat_record_type,
8371 NULL_TREE, gnu_variant_type, packed,
8372 definition, !all_rep_and_size, all_rep,
8373 unchecked_union, true, needs_xv_encodings,
8374 true, this_first_free_pos,
8375 (all_rep || this_first_free_pos)
8376 && !(unchecked_union
8377 && gnu_field_list
8378 && innermost_variant_level)
8379 ? NULL : &gnu_rep_list);
8381 /* Translate the qualifier and annotate the GNAT node. */
8382 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
8383 Set_Present_Expr (variant, annotate_value (gnu_qual));
8385 /* Deal with packedness like in gnat_to_gnu_field. */
8386 if (components_need_strict_alignment (Component_List (variant)))
8388 field_packed = 0;
8389 union_field_needs_strict_alignment = true;
8391 else
8392 field_packed
8393 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
8395 /* Push this variant onto the stack for the second pass. */
8396 vinfo.type = gnu_variant_type;
8397 vinfo.name = gnu_inner_name;
8398 vinfo.qual = gnu_qual;
8399 vinfo.has_rep = has_rep;
8400 vinfo.packed = field_packed;
8401 variant_types.safe_push (vinfo);
8403 /* Compute the global properties that will determine the placement of
8404 the variant part. */
8405 variants_have_rep |= has_rep;
8406 if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align)
8407 variants_align = TYPE_ALIGN (gnu_variant_type);
8410 /* Round up the first free position to the alignment of the variant part
8411 for the variants without rep clause. This will guarantee a consistent
8412 layout independently of the placement of the variant part. */
8413 if (variants_have_rep && variants_align > 0 && this_first_free_pos)
8414 this_first_free_pos = round_up (this_first_free_pos, variants_align);
8416 /* In the second pass, the container types are adjusted if necessary and
8417 finished up, then the corresponding fields of the variant part are
8418 built with their qualifier, unless this is an unchecked union. */
8419 FOR_EACH_VEC_ELT (variant_types, i, gnu_variant)
8421 tree gnu_variant_type = gnu_variant->type;
8422 tree gnu_field_list = TYPE_FIELDS (gnu_variant_type);
8424 /* If this is an Unchecked_Union whose fields are all in the variant
8425 part and we have a single field with no representation clause or
8426 placed at offset zero, use the field directly to match the layout
8427 of C unions. */
8428 if (TREE_CODE (gnu_record_type) == UNION_TYPE
8429 && gnu_field_list
8430 && !DECL_CHAIN (gnu_field_list)
8431 && (!DECL_FIELD_OFFSET (gnu_field_list)
8432 || integer_zerop (bit_position (gnu_field_list))))
8434 gnu_field = gnu_field_list;
8435 DECL_CONTEXT (gnu_field) = gnu_record_type;
8437 else
8439 /* Finalize the variant type now. We used to throw away empty
8440 record types but we no longer do that because we need them to
8441 generate complete debug info for the variant; otherwise, the
8442 union type definition will be lacking the fields associated
8443 with these empty variants. */
8444 if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep)
8446 /* The variant part will be at offset 0 so we need to ensure
8447 that the fields are laid out starting from the first free
8448 position at this level. */
8449 tree gnu_rep_type = make_node (RECORD_TYPE);
8450 tree gnu_rep_part;
8451 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
8452 = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type);
8453 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
8454 gnu_rep_part
8455 = create_rep_part (gnu_rep_type, gnu_variant_type,
8456 this_first_free_pos);
8457 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
8458 gnu_field_list = gnu_rep_part;
8459 finish_record_type (gnu_variant_type, gnu_field_list, 0,
8460 false);
8463 if (debug_info)
8464 rest_of_record_type_compilation (gnu_variant_type);
8465 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
8466 true, needs_xv_encodings, gnat_component_list);
8468 gnu_field
8469 = create_field_decl (gnu_variant->name, gnu_variant_type,
8470 gnu_union_type,
8471 all_rep_and_size
8472 ? TYPE_SIZE (gnu_variant_type) : 0,
8473 variants_have_rep ? bitsize_zero_node : 0,
8474 gnu_variant->packed, 0);
8476 DECL_INTERNAL_P (gnu_field) = 1;
8478 if (!unchecked_union)
8479 DECL_QUALIFIER (gnu_field) = gnu_variant->qual;
8482 DECL_CHAIN (gnu_field) = gnu_variant_list;
8483 gnu_variant_list = gnu_field;
8486 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
8487 if (gnu_variant_list)
8489 int union_field_packed;
8491 if (all_rep_and_size)
8493 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
8494 TYPE_SIZE_UNIT (gnu_union_type)
8495 = TYPE_SIZE_UNIT (gnu_record_type);
8498 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
8499 all_rep_and_size ? 1 : 0, needs_xv_encodings);
8501 /* If GNU_UNION_TYPE is our record type, this means that we must have
8502 an Unchecked_Union whose fields are all in the variant part. Now
8503 verify that and, if so, just return. */
8504 if (gnu_union_type == gnu_record_type)
8506 gcc_assert (unchecked_union
8507 && !gnu_field_list
8508 && !gnu_rep_list);
8509 return variants_have_rep;
8512 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true,
8513 needs_xv_encodings, gnat_component_list);
8515 /* Deal with packedness like in gnat_to_gnu_field. */
8516 if (union_field_needs_strict_alignment)
8517 union_field_packed = 0;
8518 else
8519 union_field_packed
8520 = adjust_packed (gnu_union_type, gnu_record_type, packed);
8522 gnu_variant_part
8523 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
8524 all_rep_and_size
8525 ? TYPE_SIZE (gnu_union_type) : 0,
8526 variants_have_rep ? bitsize_zero_node : 0,
8527 union_field_packed, 0);
8529 DECL_INTERNAL_P (gnu_variant_part) = 1;
8533 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
8534 pull them out and put them onto the appropriate list.
8536 Similarly, pull out the fields with zero size and no rep clause, as they
8537 would otherwise modify the layout and thus very likely run afoul of the
8538 Ada semantics, which are different from those of C here.
8540 Finally, if there is an aliased field placed in the list after fields
8541 with self-referential size, pull out the latter in the same way.
8543 Optionally, if the reordering mechanism is enabled, pull out the fields
8544 with self-referential size, variable size and fixed size not a multiple
8545 of a byte, so that they don't cause the regular fields to be either at
8546 self-referential/variable offset or misaligned. Note, in the latter
8547 case, that this can only happen in packed record types so the alignment
8548 is effectively capped to the byte for the whole record. But we don't
8549 do it for packed record types if not all fixed-size fiels can be packed
8550 and for non-packed record types if pragma Optimize_Alignment (Space) is
8551 specified, because this can prevent alignment gaps from being filled.
8553 Optionally, if the layout warning is enabled, keep track of the above 4
8554 different kinds of fields and issue a warning if some of them would be
8555 (or are being) reordered by the reordering mechanism.
8557 ??? If we reorder fields, the debugging information will be affected and
8558 the debugger print fields in a different order from the source code. */
8559 const bool do_reorder
8560 = (Convention (gnat_record_type) == Convention_Ada
8561 && !No_Reordering (gnat_record_type)
8562 && !(Is_Packed (gnat_record_type)
8563 ? has_non_packed_fixed_size_field
8564 : Optimize_Alignment_Space (gnat_record_type))
8565 && !Debug_Flag_Dot_R);
8566 const bool w_reorder
8567 = (Convention (gnat_record_type) == Convention_Ada
8568 && Get_Warn_On_Questionable_Layout ()
8569 && !(No_Reordering (gnat_record_type) && GNAT_Mode));
8570 tree gnu_zero_list = NULL_TREE;
8571 tree gnu_self_list = NULL_TREE;
8572 tree gnu_var_list = NULL_TREE;
8573 tree gnu_bitp_list = NULL_TREE;
8574 tree gnu_tmp_bitp_list = NULL_TREE;
8575 unsigned int tmp_bitp_size = 0;
8576 unsigned int last_reorder_field_type = -1;
8577 unsigned int tmp_last_reorder_field_type = -1;
8579 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
8580 do { \
8581 if (gnu_last) \
8582 DECL_CHAIN (gnu_last) = gnu_next; \
8583 else \
8584 gnu_field_list = gnu_next; \
8586 DECL_CHAIN (gnu_field) = (LIST); \
8587 (LIST) = gnu_field; \
8588 } while (0)
8590 gnu_last = NULL_TREE;
8591 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
8593 gnu_next = DECL_CHAIN (gnu_field);
8595 if (DECL_FIELD_OFFSET (gnu_field))
8597 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
8598 continue;
8601 if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
8603 DECL_SIZE_UNIT (gnu_field) = size_zero_node;
8604 DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
8605 SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
8606 DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
8607 if (DECL_ALIASED_P (gnu_field))
8608 SET_TYPE_ALIGN (gnu_record_type,
8609 MAX (TYPE_ALIGN (gnu_record_type),
8610 TYPE_ALIGN (TREE_TYPE (gnu_field))));
8611 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
8612 continue;
8615 if (has_aliased_after_self_field && field_has_self_size (gnu_field))
8617 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
8618 continue;
8621 /* We don't need further processing in default mode. */
8622 if (!w_reorder && !do_reorder)
8624 gnu_last = gnu_field;
8625 continue;
8628 if (field_has_self_size (gnu_field))
8630 if (w_reorder)
8632 if (last_reorder_field_type < 4)
8633 warn_on_field_placement (gnu_field, gnat_component_list,
8634 gnat_record_type, in_variant,
8635 do_reorder);
8636 else
8637 last_reorder_field_type = 4;
8640 if (do_reorder)
8642 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
8643 continue;
8647 else if (field_has_variable_size (gnu_field))
8649 if (w_reorder)
8651 if (last_reorder_field_type < 3)
8652 warn_on_field_placement (gnu_field, gnat_component_list,
8653 gnat_record_type, in_variant,
8654 do_reorder);
8655 else
8656 last_reorder_field_type = 3;
8659 if (do_reorder)
8661 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
8662 continue;
8666 else
8668 /* If the field has no size, then it cannot be bit-packed. */
8669 const unsigned int bitp_size
8670 = DECL_SIZE (gnu_field)
8671 ? TREE_INT_CST_LOW (DECL_SIZE (gnu_field)) % BITS_PER_UNIT
8672 : 0;
8674 /* If the field is bit-packed, we move it to a temporary list that
8675 contains the contiguously preceding bit-packed fields, because
8676 we want to be able to put them back if the misalignment happens
8677 to cancel itself after several bit-packed fields. */
8678 if (bitp_size != 0)
8680 tmp_bitp_size = (tmp_bitp_size + bitp_size) % BITS_PER_UNIT;
8682 if (last_reorder_field_type != 2)
8684 tmp_last_reorder_field_type = last_reorder_field_type;
8685 last_reorder_field_type = 2;
8688 if (do_reorder)
8690 MOVE_FROM_FIELD_LIST_TO (gnu_tmp_bitp_list);
8691 continue;
8695 /* No more bit-packed fields, move the existing ones to the end or
8696 put them back at their original location. */
8697 else if (last_reorder_field_type == 2 || gnu_tmp_bitp_list)
8699 last_reorder_field_type = 1;
8701 if (tmp_bitp_size != 0)
8703 if (w_reorder && tmp_last_reorder_field_type < 2)
8705 if (gnu_tmp_bitp_list)
8706 warn_on_list_placement (gnu_tmp_bitp_list,
8707 gnat_component_list,
8708 gnat_record_type, in_variant,
8709 do_reorder);
8710 else
8711 warn_on_field_placement (gnu_last,
8712 gnat_component_list,
8713 gnat_record_type, in_variant,
8714 do_reorder);
8717 if (do_reorder)
8718 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
8720 gnu_tmp_bitp_list = NULL_TREE;
8721 tmp_bitp_size = 0;
8723 else
8725 /* Rechain the temporary list in front of GNU_FIELD. */
8726 tree gnu_bitp_field = gnu_field;
8727 while (gnu_tmp_bitp_list)
8729 tree gnu_bitp_next = DECL_CHAIN (gnu_tmp_bitp_list);
8730 DECL_CHAIN (gnu_tmp_bitp_list) = gnu_bitp_field;
8731 if (gnu_last)
8732 DECL_CHAIN (gnu_last) = gnu_tmp_bitp_list;
8733 else
8734 gnu_field_list = gnu_tmp_bitp_list;
8735 gnu_bitp_field = gnu_tmp_bitp_list;
8736 gnu_tmp_bitp_list = gnu_bitp_next;
8741 else
8742 last_reorder_field_type = 1;
8745 gnu_last = gnu_field;
8748 #undef MOVE_FROM_FIELD_LIST_TO
8750 gnu_field_list = nreverse (gnu_field_list);
8752 /* If permitted, we reorder the fields as follows:
8754 1) all (groups of) fields whose length is fixed and multiple of a byte,
8755 2) the remaining fields whose length is fixed and not multiple of a byte,
8756 3) the remaining fields whose length doesn't depend on discriminants,
8757 4) all fields whose length depends on discriminants,
8758 5) the variant part,
8760 within the record and within each variant recursively. */
8762 if (w_reorder)
8764 /* If we have pending bit-packed fields, warn if they would be moved
8765 to after regular fields. */
8766 if (last_reorder_field_type == 2
8767 && tmp_bitp_size != 0
8768 && tmp_last_reorder_field_type < 2)
8770 if (gnu_tmp_bitp_list)
8771 warn_on_list_placement (gnu_tmp_bitp_list,
8772 gnat_component_list, gnat_record_type,
8773 in_variant, do_reorder);
8774 else
8775 warn_on_field_placement (gnu_field_list,
8776 gnat_component_list, gnat_record_type,
8777 in_variant, do_reorder);
8781 if (do_reorder)
8783 /* If we have pending bit-packed fields on the temporary list, we put
8784 them either on the bit-packed list or back on the regular list. */
8785 if (gnu_tmp_bitp_list)
8787 if (tmp_bitp_size != 0)
8788 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
8789 else
8790 gnu_field_list = chainon (gnu_tmp_bitp_list, gnu_field_list);
8793 gnu_field_list
8794 = chainon (gnu_field_list,
8795 chainon (gnu_bitp_list,
8796 chainon (gnu_var_list, gnu_self_list)));
8799 /* Otherwise, if there is an aliased field placed after a field whose length
8800 depends on discriminants, we put all the fields of the latter sort, last.
8801 We need to do this in case an object of this record type is mutable. */
8802 else if (has_aliased_after_self_field)
8803 gnu_field_list = chainon (gnu_field_list, gnu_self_list);
8805 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
8806 in our REP list to the previous level because this level needs them in
8807 order to do a correct layout, i.e. avoid having overlapping fields. */
8808 if (p_gnu_rep_list && gnu_rep_list)
8809 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
8811 /* Deal with the case of an extension of a record type with variable size and
8812 partial rep clause, for which the _Parent field is forced at offset 0 and
8813 has variable size. Note that we cannot do it if the field has fixed size
8814 because we rely on the presence of the REP part built below to trigger the
8815 reordering of the fields in a derived record type when all the fields have
8816 a fixed position. */
8817 else if (gnu_rep_list
8818 && !DECL_CHAIN (gnu_rep_list)
8819 && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
8820 && !variants_have_rep
8821 && first_free_pos
8822 && integer_zerop (first_free_pos)
8823 && integer_zerop (bit_position (gnu_rep_list)))
8825 DECL_CHAIN (gnu_rep_list) = gnu_field_list;
8826 gnu_field_list = gnu_rep_list;
8827 gnu_rep_list = NULL_TREE;
8830 /* Otherwise, sort the fields by bit position and put them into their own
8831 record, before the others, if we also have fields without rep clause. */
8832 else if (gnu_rep_list)
8834 tree gnu_parent, gnu_rep_type;
8836 /* If all the fields have a rep clause, we can do a flat layout. */
8837 layout_with_rep = !gnu_field_list
8838 && (!gnu_variant_part || variants_have_rep);
8840 /* Same as above but the extension itself has a rep clause, in which case
8841 we need to set aside the _Parent field to lay out the REP part. */
8842 if (TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
8843 && !layout_with_rep
8844 && !variants_have_rep
8845 && first_free_pos
8846 && integer_zerop (first_free_pos)
8847 && integer_zerop (bit_position (gnu_rep_list)))
8849 gnu_parent = gnu_rep_list;
8850 gnu_rep_list = DECL_CHAIN (gnu_rep_list);
8852 else
8853 gnu_parent = NULL_TREE;
8855 gnu_rep_type
8856 = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE);
8858 /* Sort the fields in order of increasing bit position. */
8859 const int len = list_length (gnu_rep_list);
8860 tree *gnu_arr = XALLOCAVEC (tree, len);
8862 gnu_field = gnu_rep_list;
8863 for (int i = 0; i < len; i++)
8865 gnu_arr[i] = gnu_field;
8866 gnu_field = DECL_CHAIN (gnu_field);
8869 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
8871 gnu_rep_list = NULL_TREE;
8872 for (int i = len - 1; i >= 0; i--)
8874 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
8875 gnu_rep_list = gnu_arr[i];
8876 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
8879 /* Do the layout of the REP part, if any. */
8880 if (layout_with_rep)
8881 gnu_field_list = gnu_rep_list;
8882 else
8884 TYPE_NAME (gnu_rep_type)
8885 = create_concat_name (gnat_record_type, "REP");
8886 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
8887 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
8888 finish_record_type (gnu_rep_type, gnu_rep_list, 1, false);
8890 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
8891 without rep clause are laid out starting from this position.
8892 Therefore, we force it as a minimal size on the REP part. */
8893 tree gnu_rep_part
8894 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
8896 /* If this is an extension, put back the _Parent field as the first
8897 field of the REP part at offset 0 and update its layout. */
8898 if (gnu_parent)
8900 const unsigned int align = DECL_ALIGN (gnu_parent);
8901 DECL_CHAIN (gnu_parent) = TYPE_FIELDS (gnu_rep_type);
8902 TYPE_FIELDS (gnu_rep_type) = gnu_parent;
8903 DECL_CONTEXT (gnu_parent) = gnu_rep_type;
8904 if (align > TYPE_ALIGN (gnu_rep_type))
8906 SET_TYPE_ALIGN (gnu_rep_type, align);
8907 TYPE_SIZE (gnu_rep_type)
8908 = round_up (TYPE_SIZE (gnu_rep_type), align);
8909 TYPE_SIZE_UNIT (gnu_rep_type)
8910 = round_up (TYPE_SIZE_UNIT (gnu_rep_type), align);
8911 SET_DECL_ALIGN (gnu_rep_part, align);
8915 if (debug_info)
8916 rest_of_record_type_compilation (gnu_rep_type);
8918 /* Chain the REP part at the beginning of the field list. */
8919 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
8920 gnu_field_list = gnu_rep_part;
8924 /* Chain the variant part at the end of the field list. */
8925 if (gnu_variant_part)
8926 gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
8928 if (cancel_alignment)
8929 SET_TYPE_ALIGN (gnu_record_type, 0);
8931 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
8933 finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0,
8934 debug_info && !in_variant);
8936 /* Chain the fields with zero size at the beginning of the field list. */
8937 if (gnu_zero_list)
8938 TYPE_FIELDS (gnu_record_type)
8939 = chainon (gnu_zero_list, TYPE_FIELDS (gnu_record_type));
8941 return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
8944 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
8945 placed into an Esize, Component_Bit_Offset, or Component_Size value
8946 in the GNAT tree. */
8948 static Uint
8949 annotate_value (tree gnu_size)
8951 static int var_count = 0;
8952 TCode tcode;
8953 Node_Ref_Or_Val ops[3] = { No_Uint, No_Uint, No_Uint };
8954 struct tree_int_map in;
8956 /* See if we've already saved the value for this node. */
8957 if (EXPR_P (gnu_size) || DECL_P (gnu_size))
8959 struct tree_int_map *e;
8961 in.base.from = gnu_size;
8962 e = annotate_value_cache->find (&in);
8964 if (e)
8965 return (Node_Ref_Or_Val) e->to;
8967 else
8968 in.base.from = NULL_TREE;
8970 /* If we do not return inside this switch, TCODE will be set to the
8971 code to be used in a call to Create_Node. */
8972 switch (TREE_CODE (gnu_size))
8974 case INTEGER_CST:
8975 /* For negative values, build NEGATE_EXPR of the opposite. Such values
8976 can appear for discriminants in expressions for variants. */
8977 if (tree_int_cst_sgn (gnu_size) < 0)
8979 tree t = wide_int_to_tree (sizetype, -wi::to_wide (gnu_size));
8980 tcode = Negate_Expr;
8981 ops[0] = UI_From_gnu (t);
8983 else
8984 return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
8985 break;
8987 case COMPONENT_REF:
8988 /* The only case we handle here is a simple discriminant reference. */
8989 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
8991 tree ref = gnu_size;
8992 gnu_size = TREE_OPERAND (ref, 1);
8994 /* Climb up the chain of successive extensions, if any. */
8995 while (TREE_CODE (TREE_OPERAND (ref, 0)) == COMPONENT_REF
8996 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (ref, 0), 1))
8997 == parent_name_id)
8998 ref = TREE_OPERAND (ref, 0);
9000 if (TREE_CODE (TREE_OPERAND (ref, 0)) == PLACEHOLDER_EXPR)
9002 /* Fall through to common processing as a FIELD_DECL. */
9003 tcode = Discrim_Val;
9004 ops[0] = UI_From_gnu (DECL_DISCRIMINANT_NUMBER (gnu_size));
9006 else
9007 return No_Uint;
9009 else
9010 return No_Uint;
9011 break;
9013 case PARM_DECL:
9014 case VAR_DECL:
9015 tcode = Dynamic_Val;
9016 ops[0] = UI_From_Int (++var_count);
9017 break;
9019 CASE_CONVERT:
9020 case NON_LVALUE_EXPR:
9021 return annotate_value (TREE_OPERAND (gnu_size, 0));
9023 /* Now just list the operations we handle. */
9024 case COND_EXPR: tcode = Cond_Expr; break;
9025 case MINUS_EXPR: tcode = Minus_Expr; break;
9026 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
9027 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
9028 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
9029 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
9030 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
9031 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
9032 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
9033 case NEGATE_EXPR: tcode = Negate_Expr; break;
9034 case MIN_EXPR: tcode = Min_Expr; break;
9035 case MAX_EXPR: tcode = Max_Expr; break;
9036 case ABS_EXPR: tcode = Abs_Expr; break;
9037 case TRUTH_ANDIF_EXPR:
9038 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
9039 case TRUTH_ORIF_EXPR:
9040 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
9041 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
9042 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
9043 case LT_EXPR: tcode = Lt_Expr; break;
9044 case LE_EXPR: tcode = Le_Expr; break;
9045 case GT_EXPR: tcode = Gt_Expr; break;
9046 case GE_EXPR: tcode = Ge_Expr; break;
9047 case EQ_EXPR: tcode = Eq_Expr; break;
9048 case NE_EXPR: tcode = Ne_Expr; break;
9050 case PLUS_EXPR:
9051 /* Turn addition of negative constant into subtraction. */
9052 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST
9053 && tree_int_cst_sign_bit (TREE_OPERAND (gnu_size, 1)))
9055 tcode = Minus_Expr;
9056 wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
9057 ops[1] = annotate_value (wide_int_to_tree (sizetype, wop1));
9058 break;
9061 /* ... fall through ... */
9063 case MULT_EXPR:
9064 tcode = (TREE_CODE (gnu_size) == MULT_EXPR ? Mult_Expr : Plus_Expr);
9065 /* Fold conversions from bytes to bits into inner operations. */
9066 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST
9067 && CONVERT_EXPR_P (TREE_OPERAND (gnu_size, 0)))
9069 tree inner_op = TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 0);
9070 if (TREE_CODE (inner_op) == TREE_CODE (gnu_size)
9071 && TREE_CODE (TREE_OPERAND (inner_op, 1)) == INTEGER_CST)
9073 ops[0] = annotate_value (TREE_OPERAND (inner_op, 0));
9074 tree inner_op_op1 = TREE_OPERAND (inner_op, 1);
9075 tree gnu_size_op1 = TREE_OPERAND (gnu_size, 1);
9076 widest_int op1;
9077 if (TREE_CODE (gnu_size) == MULT_EXPR)
9078 op1 = (wi::to_widest (inner_op_op1)
9079 * wi::to_widest (gnu_size_op1));
9080 else
9082 op1 = (wi::to_widest (inner_op_op1)
9083 + wi::to_widest (gnu_size_op1));
9084 if (wi::zext (op1, TYPE_PRECISION (sizetype)) == 0)
9085 return ops[0];
9087 ops[1] = annotate_value (wide_int_to_tree (sizetype, op1));
9090 break;
9092 case BIT_AND_EXPR:
9093 tcode = Bit_And_Expr;
9094 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
9095 Such values can appear in expressions with aligning patterns. */
9096 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
9098 wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
9099 tree op1 = wide_int_to_tree (sizetype, wop1);
9100 ops[1] = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
9102 break;
9104 case CALL_EXPR:
9105 /* In regular mode, inline back only if symbolic annotation is requested
9106 in order to avoid memory explosion on big discriminated record types.
9107 But not in ASIS mode, as symbolic annotation is required for DDA. */
9108 if (List_Representation_Info >= 3 || type_annotate_only)
9110 tree t = maybe_inline_call_in_expr (gnu_size);
9111 return t ? annotate_value (t) : No_Uint;
9113 else
9114 return Uint_Minus_1;
9116 default:
9117 return No_Uint;
9120 /* Now get each of the operands that's relevant for this code. If any
9121 cannot be expressed as a repinfo node, say we can't. */
9122 for (int i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
9123 if (ops[i] == No_Uint)
9125 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
9126 if (ops[i] == No_Uint)
9127 return No_Uint;
9130 Node_Ref_Or_Val ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
9132 /* Save the result in the cache. */
9133 if (in.base.from)
9135 struct tree_int_map **h;
9136 /* We can't assume the hash table data hasn't moved since the initial
9137 look up, so we have to search again. Allocating and inserting an
9138 entry at that point would be an alternative, but then we'd better
9139 discard the entry if we decided not to cache it. */
9140 h = annotate_value_cache->find_slot (&in, INSERT);
9141 gcc_assert (!*h);
9142 *h = ggc_alloc<tree_int_map> ();
9143 (*h)->base.from = in.base.from;
9144 (*h)->to = ret;
9147 return ret;
9150 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
9151 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
9152 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
9153 BY_REF is true if the object is used by reference. */
9155 void
9156 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
9158 if (by_ref)
9160 if (TYPE_IS_FAT_POINTER_P (gnu_type))
9161 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
9162 else
9163 gnu_type = TREE_TYPE (gnu_type);
9166 if (!Known_Esize (gnat_entity))
9168 if (TREE_CODE (gnu_type) == RECORD_TYPE
9169 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9170 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
9171 else if (!size)
9172 size = TYPE_SIZE (gnu_type);
9174 if (size)
9175 Set_Esize (gnat_entity, No_Uint_To_0 (annotate_value (size)));
9178 if (!Known_Alignment (gnat_entity))
9179 Set_Alignment (gnat_entity,
9180 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
9183 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
9184 Return NULL_TREE if there is no such element in the list. */
9186 static tree
9187 purpose_member_field (const_tree elem, tree list)
9189 while (list)
9191 tree field = TREE_PURPOSE (list);
9192 if (SAME_FIELD_P (field, elem))
9193 return list;
9194 list = TREE_CHAIN (list);
9196 return NULL_TREE;
9199 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
9200 set Component_Bit_Offset and Esize of the components to the position and
9201 size used by Gigi. */
9203 static void
9204 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
9206 /* For an extension, the inherited components have not been translated because
9207 they are fetched from the _Parent component on the fly. */
9208 const bool is_extension
9209 = Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity);
9211 /* We operate by first making a list of all fields and their position (we
9212 can get the size easily) and then update all the sizes in the tree. */
9213 tree gnu_list
9214 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
9215 BIGGEST_ALIGNMENT, NULL_TREE);
9217 for (Entity_Id gnat_field = First_Entity (gnat_entity);
9218 Present (gnat_field);
9219 gnat_field = Next_Entity (gnat_field))
9220 if ((Ekind (gnat_field) == E_Component
9221 && (is_extension || present_gnu_tree (gnat_field)))
9222 || (Ekind (gnat_field) == E_Discriminant
9223 && !Is_Unchecked_Union (Scope (gnat_field))))
9225 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
9226 gnu_list);
9227 if (t)
9229 tree offset = TREE_VEC_ELT (TREE_VALUE (t), 0);
9230 tree bit_offset = TREE_VEC_ELT (TREE_VALUE (t), 2);
9232 /* If we are just annotating types and the type is tagged, the tag
9233 and the parent components are not generated by the front-end so
9234 we need to add the appropriate offset to each component without
9235 representation clause. */
9236 if (type_annotate_only
9237 && Is_Tagged_Type (gnat_entity)
9238 && No (Component_Clause (gnat_field)))
9240 tree parent_bit_offset;
9242 /* For a component appearing in the current extension, the
9243 offset is the size of the parent. */
9244 if (Is_Derived_Type (gnat_entity)
9245 && Original_Record_Component (gnat_field) == gnat_field)
9246 parent_bit_offset
9247 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
9248 bitsizetype);
9249 else
9250 parent_bit_offset = bitsize_int (POINTER_SIZE);
9252 if (TYPE_FIELDS (gnu_type))
9253 parent_bit_offset
9254 = round_up (parent_bit_offset,
9255 DECL_ALIGN (TYPE_FIELDS (gnu_type)));
9257 offset
9258 = size_binop (PLUS_EXPR, offset,
9259 fold_convert (sizetype,
9260 size_binop (TRUNC_DIV_EXPR,
9261 parent_bit_offset,
9262 bitsize_unit_node)));
9265 /* If the field has a variable offset, also compute the normalized
9266 position since it's easier to do on trees here than to deduce
9267 it from the annotated expression of Component_Bit_Offset. */
9268 if (TREE_CODE (offset) != INTEGER_CST)
9270 normalize_offset (&offset, &bit_offset, BITS_PER_UNIT);
9271 Set_Normalized_Position (gnat_field,
9272 annotate_value (offset));
9273 Set_Normalized_First_Bit (gnat_field,
9274 annotate_value (bit_offset));
9277 Set_Component_Bit_Offset
9278 (gnat_field,
9279 annotate_value (bit_from_pos (offset, bit_offset)));
9281 Set_Esize
9282 (gnat_field,
9283 No_Uint_To_0 (annotate_value (DECL_SIZE (TREE_PURPOSE (t)))));
9285 else if (is_extension)
9287 /* If there is no entry, this is an inherited component whose
9288 position is the same as in the parent type. */
9289 Entity_Id gnat_orig = Original_Record_Component (gnat_field);
9291 /* If we are just annotating types, discriminants renaming those of
9292 the parent have no entry so deal with them specifically. */
9293 if (type_annotate_only
9294 && gnat_orig == gnat_field
9295 && Ekind (gnat_field) == E_Discriminant)
9296 gnat_orig = Corresponding_Discriminant (gnat_field);
9298 if (Known_Normalized_Position (gnat_orig))
9300 Set_Normalized_Position (gnat_field,
9301 Normalized_Position (gnat_orig));
9302 Set_Normalized_First_Bit (gnat_field,
9303 Normalized_First_Bit (gnat_orig));
9306 Set_Component_Bit_Offset (gnat_field,
9307 Component_Bit_Offset (gnat_orig));
9309 Set_Esize (gnat_field, Esize (gnat_orig));
9314 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
9315 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
9316 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
9317 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
9318 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
9319 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
9320 pre-existing list to be chained to the newly created entries. */
9322 static tree
9323 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
9324 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
9326 tree gnu_field;
9328 for (gnu_field = TYPE_FIELDS (gnu_type);
9329 gnu_field;
9330 gnu_field = DECL_CHAIN (gnu_field))
9332 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
9333 DECL_FIELD_BIT_OFFSET (gnu_field));
9334 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
9335 DECL_FIELD_OFFSET (gnu_field));
9336 unsigned int our_offset_align
9337 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
9338 tree v = make_tree_vec (3);
9340 TREE_VEC_ELT (v, 0) = gnu_our_offset;
9341 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
9342 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
9343 gnu_list = tree_cons (gnu_field, v, gnu_list);
9345 /* Recurse on internal fields, flattening the nested fields except for
9346 those in the variant part, if requested. */
9347 if (DECL_INTERNAL_P (gnu_field))
9349 tree gnu_field_type = TREE_TYPE (gnu_field);
9350 if (do_not_flatten_variant
9351 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
9352 gnu_list
9353 = build_position_list (gnu_field_type, do_not_flatten_variant,
9354 size_zero_node, bitsize_zero_node,
9355 BIGGEST_ALIGNMENT, gnu_list);
9356 else
9357 gnu_list
9358 = build_position_list (gnu_field_type, do_not_flatten_variant,
9359 gnu_our_offset, gnu_our_bitpos,
9360 our_offset_align, gnu_list);
9364 return gnu_list;
9367 /* Return a list describing the substitutions needed to reflect the
9368 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
9369 be in any order. The values in an element of the list are in the form
9370 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
9371 a definition of GNAT_SUBTYPE. */
9373 static vec<subst_pair>
9374 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
9376 vec<subst_pair> gnu_list = vNULL;
9377 Entity_Id gnat_discrim;
9378 Node_Id gnat_constr;
9380 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
9381 gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
9382 Present (gnat_discrim);
9383 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
9384 gnat_constr = Next_Elmt (gnat_constr))
9385 /* Ignore access discriminants. */
9386 if (!Is_Access_Type (Etype (Node (gnat_constr))))
9388 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
9389 tree replacement
9390 = elaborate_expression (Node (gnat_constr), gnat_subtype,
9391 get_entity_char (gnat_discrim),
9392 definition, true, false);
9393 /* If this is a definition, we need to make sure that the SAVE_EXPRs
9394 are instantiated on every possibly path in size computations. */
9395 if (definition && TREE_CODE (replacement) == SAVE_EXPR)
9396 add_stmt (replacement);
9397 replacement = convert (TREE_TYPE (gnu_field), replacement);
9398 subst_pair s = { gnu_field, replacement };
9399 gnu_list.safe_push (s);
9402 return gnu_list;
9405 /* Scan all fields in {GNU_QUAL_UNION_TYPE,GNAT_VARIANT_PART} and return a list
9406 describing the variants of GNU_QUAL_UNION_TYPE that are still relevant after
9407 applying the substitutions described in SUBST_LIST. GNU_LIST is an existing
9408 list to be prepended to the newly created entries. */
9410 static vec<variant_desc>
9411 build_variant_list (tree gnu_qual_union_type, Node_Id gnat_variant_part,
9412 vec<subst_pair> subst_list, vec<variant_desc> gnu_list)
9414 Node_Id gnat_variant;
9415 tree gnu_field;
9417 for (gnu_field = TYPE_FIELDS (gnu_qual_union_type),
9418 gnat_variant
9419 = Present (gnat_variant_part)
9420 ? First_Non_Pragma (Variants (gnat_variant_part))
9421 : Empty;
9422 gnu_field;
9423 gnu_field = DECL_CHAIN (gnu_field),
9424 gnat_variant
9425 = Present (gnat_variant_part)
9426 ? Next_Non_Pragma (gnat_variant)
9427 : Empty)
9429 tree qual = DECL_QUALIFIER (gnu_field);
9430 unsigned int i;
9431 subst_pair *s;
9433 FOR_EACH_VEC_ELT (subst_list, i, s)
9434 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
9436 /* If the new qualifier is not unconditionally false, its variant may
9437 still be accessed. */
9438 if (!integer_zerop (qual))
9440 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
9441 variant_desc v
9442 = { variant_type, gnu_field, qual, NULL_TREE, NULL_TREE };
9444 gnu_list.safe_push (v);
9446 /* Annotate the GNAT node if present. */
9447 if (Present (gnat_variant))
9448 Set_Present_Expr (gnat_variant, annotate_value (qual));
9450 /* Recurse on the variant subpart of the variant, if any. */
9451 variant_subpart = get_variant_part (variant_type);
9452 if (variant_subpart)
9453 gnu_list
9454 = build_variant_list (TREE_TYPE (variant_subpart),
9455 Present (gnat_variant)
9456 ? Variant_Part
9457 (Component_List (gnat_variant))
9458 : Empty,
9459 subst_list,
9460 gnu_list);
9462 /* If the new qualifier is unconditionally true, the subsequent
9463 variants cannot be accessed. */
9464 if (integer_onep (qual))
9465 break;
9469 return gnu_list;
9472 /* If SIZE has overflowed, return the maximum valid size, which is the upper
9473 bound of the signed sizetype in bits, rounded down to ALIGN. Otherwise
9474 return SIZE unmodified. */
9476 static tree
9477 maybe_saturate_size (tree size, unsigned int align)
9479 if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
9481 size
9482 = size_binop (MULT_EXPR,
9483 fold_convert (bitsizetype, TYPE_MAX_VALUE (ssizetype)),
9484 build_int_cst (bitsizetype, BITS_PER_UNIT));
9485 size = round_down (size, align);
9488 return size;
9491 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
9492 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
9493 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
9494 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
9495 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
9496 true if we are being called to process the Component_Size of GNAT_OBJECT;
9497 this is used only for error messages. ZERO_OK is true if a size of zero
9498 is permitted; if ZERO_OK is false, it means that a size of zero should be
9499 treated as an unspecified size. S1 and S2 are used for error messages. */
9501 static tree
9502 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
9503 enum tree_code kind, bool component_p, bool zero_ok,
9504 const char *s1, const char *s2)
9506 Node_Id gnat_error_node;
9507 tree old_size, size;
9509 /* Return 0 if no size was specified. */
9510 if (uint_size == No_Uint)
9511 return NULL_TREE;
9513 /* Ignore a negative size since that corresponds to our back-annotation. */
9514 if (UI_Lt (uint_size, Uint_0))
9515 return NULL_TREE;
9517 /* Find the node to use for error messages. */
9518 if ((Ekind (gnat_object) == E_Component
9519 || Ekind (gnat_object) == E_Discriminant)
9520 && Present (Component_Clause (gnat_object)))
9521 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
9522 else if (Present (Size_Clause (gnat_object)))
9523 gnat_error_node = Expression (Size_Clause (gnat_object));
9524 else if (Has_Object_Size_Clause (gnat_object))
9525 gnat_error_node = Expression (Object_Size_Clause (gnat_object));
9526 else
9527 gnat_error_node = gnat_object;
9529 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
9530 but cannot be represented in bitsizetype. */
9531 size = UI_To_gnu (uint_size, bitsizetype);
9532 if (TREE_OVERFLOW (size))
9534 if (component_p)
9535 post_error_ne ("component size for& is too large", gnat_error_node,
9536 gnat_object);
9537 else
9538 post_error_ne ("size for& is too large", gnat_error_node,
9539 gnat_object);
9540 return NULL_TREE;
9543 /* Ignore a zero size if it is not permitted. */
9544 if (!zero_ok && integer_zerop (size))
9545 return NULL_TREE;
9547 /* The size of objects is always a multiple of a byte. */
9548 if (kind == VAR_DECL
9549 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
9551 if (component_p)
9552 post_error_ne ("component size for& must be multiple of Storage_Unit",
9553 gnat_error_node, gnat_object);
9554 else
9555 post_error_ne ("size for& must be multiple of Storage_Unit",
9556 gnat_error_node, gnat_object);
9557 return NULL_TREE;
9560 /* If this is an integral type or a bit-packed array type, the front-end has
9561 already verified the size, so we need not do it again (which would mean
9562 checking against the bounds). However, if this is an aliased object, it
9563 may not be smaller than the type of the object. */
9564 if ((INTEGRAL_TYPE_P (gnu_type) || BIT_PACKED_ARRAY_TYPE_P (gnu_type))
9565 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
9566 return size;
9568 /* If the object is a record that contains a template, add the size of the
9569 template to the specified size. */
9570 if (TREE_CODE (gnu_type) == RECORD_TYPE
9571 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9572 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
9574 old_size = (kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type));
9576 /* If the old size is self-referential, get the maximum size. */
9577 if (CONTAINS_PLACEHOLDER_P (old_size))
9578 old_size = max_size (old_size, true);
9580 /* If this is an access type or a fat pointer, the minimum size is that given
9581 by the smallest integral mode that's valid for pointers. */
9582 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
9584 scalar_int_mode p_mode = NARROWEST_INT_MODE;
9585 while (!targetm.valid_pointer_mode (p_mode))
9586 p_mode = GET_MODE_WIDER_MODE (p_mode).require ();
9587 old_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
9590 /* Issue an error either if the default size of the object isn't a constant
9591 or if the new size is smaller than it. */
9592 if (TREE_CODE (old_size) != INTEGER_CST
9593 || (!TREE_OVERFLOW (old_size) && tree_int_cst_lt (size, old_size)))
9595 char buf[128];
9596 const char *s;
9598 if (s1 && s2)
9600 snprintf (buf, sizeof (buf), s1, s2);
9601 s = buf;
9603 else if (component_p)
9604 s = "component size for& too small{, minimum allowed is ^}";
9605 else
9606 s = "size for& too small{, minimum allowed is ^}";
9608 post_error_ne_tree (s, gnat_error_node, gnat_object, old_size);
9610 return NULL_TREE;
9613 return size;
9616 /* Similarly, but both validate and process a value of RM size. This routine
9617 is only called for types. */
9619 static void
9620 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
9622 Node_Id gnat_attr_node;
9623 tree old_size, size;
9625 /* Do nothing if no size was specified. */
9626 if (uint_size == No_Uint)
9627 return;
9629 /* Only issue an error if a Value_Size clause was explicitly given for the
9630 entity; otherwise, we'd be duplicating an error on the Size clause. */
9631 gnat_attr_node
9632 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
9633 if (Present (gnat_attr_node) && Entity (gnat_attr_node) != gnat_entity)
9634 gnat_attr_node = Empty;
9636 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
9637 but cannot be represented in bitsizetype. */
9638 size = UI_To_gnu (uint_size, bitsizetype);
9639 if (TREE_OVERFLOW (size))
9641 if (Present (gnat_attr_node))
9642 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
9643 gnat_entity);
9644 return;
9647 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
9648 exists, or this is an integer type, in which case the front-end will
9649 have always set it. */
9650 if (No (gnat_attr_node)
9651 && integer_zerop (size)
9652 && !Has_Size_Clause (gnat_entity)
9653 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
9654 return;
9656 old_size = rm_size (gnu_type);
9658 /* If the old size is self-referential, get the maximum size. */
9659 if (CONTAINS_PLACEHOLDER_P (old_size))
9660 old_size = max_size (old_size, true);
9662 /* Issue an error either if the old size of the object isn't a constant or
9663 if the new size is smaller than it. The front-end has already verified
9664 this for scalar and bit-packed array types. */
9665 if (TREE_CODE (old_size) != INTEGER_CST
9666 || TREE_OVERFLOW (old_size)
9667 || (AGGREGATE_TYPE_P (gnu_type)
9668 && !BIT_PACKED_ARRAY_TYPE_P (gnu_type)
9669 && !(TYPE_IS_PADDING_P (gnu_type)
9670 && BIT_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
9671 && tree_int_cst_lt (size, old_size)))
9673 if (Present (gnat_attr_node))
9674 post_error_ne_tree
9675 ("Value_Size for& too small{, minimum allowed is ^}",
9676 gnat_attr_node, gnat_entity, old_size);
9677 return;
9680 /* Otherwise, set the RM size proper for integral types... */
9681 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
9682 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
9683 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
9684 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
9685 SET_TYPE_RM_SIZE (gnu_type, size);
9687 /* ...or the Ada size for record and union types. */
9688 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
9689 && !TYPE_FAT_POINTER_P (gnu_type))
9690 SET_TYPE_ADA_SIZE (gnu_type, size);
9693 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
9694 a type or object whose present alignment is ALIGN. If this alignment is
9695 valid, return it. Otherwise, give an error and return ALIGN. */
9697 static unsigned int
9698 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
9700 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
9701 unsigned int new_align;
9702 Node_Id gnat_error_node;
9704 /* Don't worry about checking alignment if alignment was not specified
9705 by the source program and we already posted an error for this entity. */
9706 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
9707 return align;
9709 /* Post the error on the alignment clause if any. Note, for the implicit
9710 base type of an array type, the alignment clause is on the first
9711 subtype. */
9712 if (Present (Alignment_Clause (gnat_entity)))
9713 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
9715 else if (Is_Itype (gnat_entity)
9716 && Is_Array_Type (gnat_entity)
9717 && Etype (gnat_entity) == gnat_entity
9718 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
9719 gnat_error_node =
9720 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
9722 else
9723 gnat_error_node = gnat_entity;
9725 /* Within GCC, an alignment is an integer, so we must make sure a value is
9726 specified that fits in that range. Also, there is an upper bound to
9727 alignments we can support/allow. */
9728 if (!UI_Is_In_Int_Range (alignment)
9729 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
9730 post_error_ne_num ("largest supported alignment for& is ^",
9731 gnat_error_node, gnat_entity, max_allowed_alignment);
9732 else if (!(Present (Alignment_Clause (gnat_entity))
9733 && From_At_Mod (Alignment_Clause (gnat_entity)))
9734 && new_align * BITS_PER_UNIT < align)
9736 unsigned int double_align;
9737 bool is_capped_double, align_clause;
9739 /* If the default alignment of "double" or larger scalar types is
9740 specifically capped and the new alignment is above the cap, do
9741 not post an error and change the alignment only if there is an
9742 alignment clause; this makes it possible to have the associated
9743 GCC type overaligned by default for performance reasons. */
9744 if ((double_align = double_float_alignment) > 0)
9746 Entity_Id gnat_type
9747 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
9748 is_capped_double
9749 = is_double_float_or_array (gnat_type, &align_clause);
9751 else if ((double_align = double_scalar_alignment) > 0)
9753 Entity_Id gnat_type
9754 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
9755 is_capped_double
9756 = is_double_scalar_or_array (gnat_type, &align_clause);
9758 else
9759 is_capped_double = align_clause = false;
9761 if (is_capped_double && new_align >= double_align)
9763 if (align_clause)
9764 align = new_align * BITS_PER_UNIT;
9766 else
9768 if (is_capped_double)
9769 align = double_align * BITS_PER_UNIT;
9771 post_error_ne_num ("alignment for& must be at least ^",
9772 gnat_error_node, gnat_entity,
9773 align / BITS_PER_UNIT);
9776 else
9778 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
9779 if (new_align > align)
9780 align = new_align;
9783 return align;
9786 /* Promote the alignment of GNU_TYPE for an object with GNU_SIZE corresponding
9787 to GNAT_ENTITY. Return a positive value on success or zero on failure. */
9789 static unsigned int
9790 promote_object_alignment (tree gnu_type, tree gnu_size, Entity_Id gnat_entity)
9792 unsigned int align, size_cap, align_cap;
9794 /* No point in promoting the alignment if this doesn't prevent BLKmode access
9795 to the object, in particular block copy, as this will for example disable
9796 the NRV optimization for it. No point in jumping through all the hoops
9797 needed in order to support BIGGEST_ALIGNMENT if we don't really have to.
9798 So we cap to the smallest alignment that corresponds to a known efficient
9799 memory access pattern, except for a full access entity. */
9800 if (Is_Full_Access (gnat_entity))
9802 size_cap = UINT_MAX;
9803 align_cap = BIGGEST_ALIGNMENT;
9805 else
9807 size_cap = MAX_FIXED_MODE_SIZE;
9808 align_cap = get_mode_alignment (ptr_mode);
9811 if (!gnu_size)
9812 gnu_size = TYPE_SIZE (gnu_type);
9814 /* Do the promotion within the above limits. */
9815 if (!tree_fits_uhwi_p (gnu_size)
9816 || compare_tree_int (gnu_size, size_cap) > 0)
9817 align = 0;
9818 else if (compare_tree_int (gnu_size, align_cap) > 0)
9819 align = align_cap;
9820 else
9821 align = ceil_pow2 (tree_to_uhwi (gnu_size));
9823 /* But make sure not to under-align the object. */
9824 if (align <= TYPE_ALIGN (gnu_type))
9825 align = 0;
9827 /* And honor the minimum valid atomic alignment, if any. */
9828 #ifdef MINIMUM_ATOMIC_ALIGNMENT
9829 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
9830 align = MINIMUM_ATOMIC_ALIGNMENT;
9831 #endif
9833 return align;
9836 /* Return whether GNAT_ENTITY is a simple constant, i.e. it represents only
9837 its value and reading it has no side effects. */
9839 bool
9840 simple_constant_p (Entity_Id gnat_entity)
9842 return Ekind (gnat_entity) == E_Constant
9843 && Present (Constant_Value (gnat_entity))
9844 && !No_Initialization (gnat_entity)
9845 && No (Address_Clause (gnat_entity))
9846 && No (Renamed_Object (gnat_entity));
9849 /* Verify that TYPE is something we can implement atomically. If not, issue
9850 an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
9851 process a component type. */
9853 static void
9854 check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p)
9856 Node_Id gnat_error_point = gnat_entity;
9857 Node_Id gnat_node;
9858 machine_mode mode;
9859 enum mode_class mclass;
9860 unsigned int align;
9861 tree size;
9863 /* If this is an anonymous base type, nothing to check, the error will be
9864 reported on the source type if need be. */
9865 if (!Comes_From_Source (gnat_entity))
9866 return;
9868 mode = TYPE_MODE (type);
9869 mclass = GET_MODE_CLASS (mode);
9870 align = TYPE_ALIGN (type);
9871 size = TYPE_SIZE (type);
9873 /* Consider all aligned floating-point types atomic and any aligned types
9874 that are represented by integers no wider than a machine word. */
9875 scalar_int_mode int_mode;
9876 if ((mclass == MODE_FLOAT
9877 || (is_a <scalar_int_mode> (mode, &int_mode)
9878 && GET_MODE_BITSIZE (int_mode) <= BITS_PER_WORD))
9879 && align >= GET_MODE_ALIGNMENT (mode))
9880 return;
9882 /* For the moment, also allow anything that has an alignment equal to its
9883 size and which is smaller than a word. */
9884 if (size
9885 && TREE_CODE (size) == INTEGER_CST
9886 && compare_tree_int (size, align) == 0
9887 && align <= BITS_PER_WORD)
9888 return;
9890 for (gnat_node = First_Rep_Item (gnat_entity);
9891 Present (gnat_node);
9892 gnat_node = Next_Rep_Item (gnat_node))
9893 if (Nkind (gnat_node) == N_Pragma)
9895 const Pragma_Id pragma_id
9896 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
9898 if ((pragma_id == Pragma_Atomic && !component_p)
9899 || (pragma_id == Pragma_Atomic_Components && component_p))
9901 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
9902 break;
9906 if (component_p)
9907 post_error_ne ("atomic access to component of & cannot be guaranteed",
9908 gnat_error_point, gnat_entity);
9909 else if (Is_Volatile_Full_Access (gnat_entity))
9910 post_error_ne ("volatile full access to & cannot be guaranteed",
9911 gnat_error_point, gnat_entity);
9912 else
9913 post_error_ne ("atomic access to & cannot be guaranteed",
9914 gnat_error_point, gnat_entity);
9917 /* Return true if TYPE is suitable for a type-generic atomic builtin. */
9919 static bool
9920 type_for_atomic_builtin_p (tree type)
9922 const enum machine_mode mode = TYPE_MODE (type);
9923 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
9924 return true;
9926 scalar_int_mode imode;
9927 if (is_a <scalar_int_mode> (mode, &imode) && GET_MODE_SIZE (imode) <= 16)
9928 return true;
9930 return false;
9933 /* Return the GCC atomic builtin based on CODE and sized for TYPE. */
9935 static tree
9936 resolve_atomic_builtin (enum built_in_function code, tree type)
9938 const unsigned int size = resolve_atomic_size (type);
9939 code = (enum built_in_function) ((int) code + exact_log2 (size) + 1);
9941 return builtin_decl_implicit (code);
9944 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
9945 on the Ada/builtin argument lists for the INB binding. */
9947 static bool
9948 intrin_arglists_compatible_p (const intrin_binding_t *inb)
9950 function_args_iterator ada_iter, btin_iter;
9952 function_args_iter_init (&ada_iter, inb->ada_fntype);
9953 function_args_iter_init (&btin_iter, inb->btin_fntype);
9955 /* Sequence position of the last argument we checked. */
9956 int argpos = 0;
9958 while (true)
9960 tree ada_type = function_args_iter_cond (&ada_iter);
9961 tree btin_type = function_args_iter_cond (&btin_iter);
9963 /* If we've exhausted both lists simultaneously, we're done. */
9964 if (!ada_type && !btin_type)
9965 break;
9967 /* If the internal builtin uses a variable list, accept anything. */
9968 if (!btin_type)
9969 break;
9971 /* If we're done with the Ada args and not with the internal builtin
9972 args, or the other way around, complain. */
9973 if (ada_type == void_type_node && btin_type != void_type_node)
9975 post_error ("??Ada parameter list too short!", inb->gnat_entity);
9976 return false;
9979 if (btin_type == void_type_node && ada_type != void_type_node)
9981 post_error_ne_num ("??Ada parameter list too long ('> ^)!",
9982 inb->gnat_entity, inb->gnat_entity, argpos);
9983 return false;
9986 /* Otherwise, check that types match for the current argument. */
9987 argpos++;
9988 if (!types_compatible_p (ada_type, btin_type))
9990 /* For vector builtins, issue an error to avoid an ICE. */
9991 if (VECTOR_TYPE_P (btin_type))
9992 post_error_ne_num
9993 ("intrinsic binding type mismatch on parameter ^",
9994 inb->gnat_entity, inb->gnat_entity, argpos);
9995 else
9996 post_error_ne_num
9997 ("??intrinsic binding type mismatch on parameter ^!",
9998 inb->gnat_entity, inb->gnat_entity, argpos);
9999 return false;
10003 function_args_iter_next (&ada_iter);
10004 function_args_iter_next (&btin_iter);
10007 return true;
10010 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
10011 on the Ada/builtin return values for the INB binding. */
10013 static bool
10014 intrin_return_compatible_p (const intrin_binding_t *inb)
10016 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
10017 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
10019 /* Accept function imported as procedure, common and convenient. */
10020 if (VOID_TYPE_P (ada_return_type) && !VOID_TYPE_P (btin_return_type))
10021 return true;
10023 /* Check return types compatibility otherwise. Note that this
10024 handles void/void as well. */
10025 if (!types_compatible_p (btin_return_type, ada_return_type))
10027 /* For vector builtins, issue an error to avoid an ICE. */
10028 if (VECTOR_TYPE_P (btin_return_type))
10029 post_error ("intrinsic binding type mismatch on result",
10030 inb->gnat_entity);
10031 else
10032 post_error ("??intrinsic binding type mismatch on result",
10033 inb->gnat_entity);
10034 return false;
10037 return true;
10040 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
10041 compatible. Issue relevant warnings when they are not.
10043 This is intended as a light check to diagnose the most obvious cases, not
10044 as a full fledged type compatibility predicate. It is the programmer's
10045 responsibility to ensure correctness of the Ada declarations in Imports,
10046 especially when binding straight to a compiler internal. */
10048 static bool
10049 intrin_profiles_compatible_p (const intrin_binding_t *inb)
10051 /* Check compatibility on return values and argument lists, each responsible
10052 for posting warnings as appropriate. Ensure use of the proper sloc for
10053 this purpose. */
10055 bool arglists_compatible_p, return_compatible_p;
10056 location_t saved_location = input_location;
10058 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
10060 return_compatible_p = intrin_return_compatible_p (inb);
10061 arglists_compatible_p = intrin_arglists_compatible_p (inb);
10063 input_location = saved_location;
10065 return return_compatible_p && arglists_compatible_p;
10068 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
10069 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
10070 specified size for this field. POS_LIST is a position list describing
10071 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
10072 to this layout. */
10074 static tree
10075 create_field_decl_from (tree old_field, tree field_type, tree record_type,
10076 tree size, tree pos_list,
10077 vec<subst_pair> subst_list)
10079 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
10080 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
10081 unsigned int offset_align = tree_to_uhwi (TREE_VEC_ELT (t, 1));
10082 tree new_pos, new_field;
10083 unsigned int i;
10084 subst_pair *s;
10086 if (CONTAINS_PLACEHOLDER_P (pos))
10087 FOR_EACH_VEC_ELT (subst_list, i, s)
10088 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
10090 /* If the position is now a constant, we can set it as the position of the
10091 field when we make it. Otherwise, we need to deal with it specially. */
10092 if (TREE_CONSTANT (pos))
10093 new_pos = bit_from_pos (pos, bitpos);
10094 else
10095 new_pos = NULL_TREE;
10097 new_field
10098 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
10099 size, new_pos, DECL_PACKED (old_field),
10100 !DECL_NONADDRESSABLE_P (old_field));
10102 if (!new_pos)
10104 normalize_offset (&pos, &bitpos, offset_align);
10105 /* Finalize the position. */
10106 DECL_FIELD_OFFSET (new_field) = variable_size (pos);
10107 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
10108 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
10109 DECL_SIZE (new_field) = size;
10110 DECL_SIZE_UNIT (new_field)
10111 = convert (sizetype,
10112 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
10113 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
10116 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
10117 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
10118 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
10119 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
10121 return new_field;
10124 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
10125 it is the minimal size the REP_PART must have. */
10127 static tree
10128 create_rep_part (tree rep_type, tree record_type, tree min_size)
10130 tree field;
10132 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
10133 min_size = NULL_TREE;
10135 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
10136 min_size, NULL_TREE, 0, 1);
10137 DECL_INTERNAL_P (field) = 1;
10139 return field;
10142 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
10144 static tree
10145 get_rep_part (tree record_type)
10147 tree field = TYPE_FIELDS (record_type);
10149 /* The REP part is the first field, internal, another record, and its name
10150 starts with an 'R'. */
10151 if (field
10152 && DECL_INTERNAL_P (field)
10153 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
10154 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
10155 return field;
10157 return NULL_TREE;
10160 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
10162 tree
10163 get_variant_part (tree record_type)
10165 tree field;
10167 /* The variant part is the only internal field that is a qualified union. */
10168 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
10169 if (DECL_INTERNAL_P (field)
10170 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
10171 return field;
10173 return NULL_TREE;
10176 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
10177 the list of variants to be used and RECORD_TYPE is the type of the parent.
10178 POS_LIST is a position list describing the layout of fields present in
10179 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
10180 layout. DEBUG_INFO_P is true if we need to write debug information. */
10182 static tree
10183 create_variant_part_from (tree old_variant_part,
10184 vec<variant_desc> variant_list,
10185 tree record_type, tree pos_list,
10186 vec<subst_pair> subst_list,
10187 bool debug_info_p)
10189 tree offset = DECL_FIELD_OFFSET (old_variant_part);
10190 tree old_union_type = TREE_TYPE (old_variant_part);
10191 tree new_union_type, new_variant_part;
10192 tree union_field_list = NULL_TREE;
10193 variant_desc *v;
10194 unsigned int i;
10196 /* First create the type of the variant part from that of the old one. */
10197 new_union_type = make_node (QUAL_UNION_TYPE);
10198 TYPE_NAME (new_union_type)
10199 = concat_name (TYPE_NAME (record_type),
10200 IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
10202 /* If the position of the variant part is constant, subtract it from the
10203 size of the type of the parent to get the new size. This manual CSE
10204 reduces the code size when not optimizing. */
10205 if (TREE_CODE (offset) == INTEGER_CST
10206 && TYPE_SIZE (record_type)
10207 && TYPE_SIZE_UNIT (record_type))
10209 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
10210 tree first_bit = bit_from_pos (offset, bitpos);
10211 TYPE_SIZE (new_union_type)
10212 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
10213 TYPE_SIZE_UNIT (new_union_type)
10214 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
10215 byte_from_pos (offset, bitpos));
10216 SET_TYPE_ADA_SIZE (new_union_type,
10217 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
10218 first_bit));
10219 SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
10220 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
10222 else
10223 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
10225 /* Now finish up the new variants and populate the union type. */
10226 FOR_EACH_VEC_ELT_REVERSE (variant_list, i, v)
10228 tree old_field = v->field, new_field;
10229 tree old_variant, old_variant_subpart, new_variant, field_list;
10231 /* Skip variants that don't belong to this nesting level. */
10232 if (DECL_CONTEXT (old_field) != old_union_type)
10233 continue;
10235 /* Retrieve the list of fields already added to the new variant. */
10236 new_variant = v->new_type;
10237 field_list = TYPE_FIELDS (new_variant);
10239 /* If the old variant had a variant subpart, we need to create a new
10240 variant subpart and add it to the field list. */
10241 old_variant = v->type;
10242 old_variant_subpart = get_variant_part (old_variant);
10243 if (old_variant_subpart)
10245 tree new_variant_subpart
10246 = create_variant_part_from (old_variant_subpart, variant_list,
10247 new_variant, pos_list, subst_list,
10248 debug_info_p);
10249 DECL_CHAIN (new_variant_subpart) = field_list;
10250 field_list = new_variant_subpart;
10253 /* Finish up the new variant and create the field. */
10254 finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p);
10255 create_type_decl (TYPE_NAME (new_variant), new_variant, true,
10256 debug_info_p, Empty);
10258 new_field
10259 = create_field_decl_from (old_field, new_variant, new_union_type,
10260 TYPE_SIZE (new_variant),
10261 pos_list, subst_list);
10262 DECL_QUALIFIER (new_field) = v->qual;
10263 DECL_INTERNAL_P (new_field) = 1;
10264 DECL_CHAIN (new_field) = union_field_list;
10265 union_field_list = new_field;
10268 /* Finish up the union type and create the variant part. Note that we don't
10269 reverse the field list because VARIANT_LIST has been traversed in reverse
10270 order. */
10271 finish_record_type (new_union_type, union_field_list, 2, debug_info_p);
10272 create_type_decl (TYPE_NAME (new_union_type), new_union_type, true,
10273 debug_info_p, Empty);
10275 new_variant_part
10276 = create_field_decl_from (old_variant_part, new_union_type, record_type,
10277 TYPE_SIZE (new_union_type),
10278 pos_list, subst_list);
10279 DECL_INTERNAL_P (new_variant_part) = 1;
10281 /* With multiple discriminants it is possible for an inner variant to be
10282 statically selected while outer ones are not; in this case, the list
10283 of fields of the inner variant is not flattened and we end up with a
10284 qualified union with a single member. Drop the useless container. */
10285 if (!DECL_CHAIN (union_field_list))
10287 DECL_CONTEXT (union_field_list) = record_type;
10288 DECL_FIELD_OFFSET (union_field_list)
10289 = DECL_FIELD_OFFSET (new_variant_part);
10290 DECL_FIELD_BIT_OFFSET (union_field_list)
10291 = DECL_FIELD_BIT_OFFSET (new_variant_part);
10292 SET_DECL_OFFSET_ALIGN (union_field_list,
10293 DECL_OFFSET_ALIGN (new_variant_part));
10294 new_variant_part = union_field_list;
10297 return new_variant_part;
10300 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
10301 which are both RECORD_TYPE, after applying the substitutions described
10302 in SUBST_LIST. */
10304 static void
10305 copy_and_substitute_in_size (tree new_type, tree old_type,
10306 vec<subst_pair> subst_list)
10308 unsigned int i;
10309 subst_pair *s;
10311 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
10312 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
10313 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
10314 SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
10315 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
10317 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
10318 FOR_EACH_VEC_ELT (subst_list, i, s)
10319 TYPE_SIZE (new_type)
10320 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
10321 s->discriminant, s->replacement);
10323 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
10324 FOR_EACH_VEC_ELT (subst_list, i, s)
10325 TYPE_SIZE_UNIT (new_type)
10326 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
10327 s->discriminant, s->replacement);
10329 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
10330 FOR_EACH_VEC_ELT (subst_list, i, s)
10331 SET_TYPE_ADA_SIZE
10332 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
10333 s->discriminant, s->replacement));
10335 /* Finalize the size. */
10336 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
10337 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
10340 /* Return true if DISC is a stored discriminant of RECORD_TYPE. */
10342 static inline bool
10343 is_stored_discriminant (Entity_Id discr, Entity_Id record_type)
10345 if (Is_Unchecked_Union (record_type))
10346 return false;
10347 else if (Is_Tagged_Type (record_type))
10348 return No (Corresponding_Discriminant (discr));
10349 else if (Ekind (record_type) == E_Record_Type)
10350 return Original_Record_Component (discr) == discr;
10351 else
10352 return true;
10355 /* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are
10356 both record types, after applying the substitutions described in SUBST_LIST.
10357 DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */
10359 static void
10360 copy_and_substitute_in_layout (Entity_Id gnat_new_type,
10361 Entity_Id gnat_old_type,
10362 tree gnu_new_type,
10363 tree gnu_old_type,
10364 vec<subst_pair> subst_list,
10365 bool debug_info_p)
10367 const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
10368 tree gnu_field_list = NULL_TREE;
10369 tree gnu_variable_field_list = NULL_TREE;
10370 bool selected_variant;
10371 vec<variant_desc> gnu_variant_list;
10373 /* Look for REP and variant parts in the old type. */
10374 tree gnu_rep_part = get_rep_part (gnu_old_type);
10375 tree gnu_variant_part = get_variant_part (gnu_old_type);
10377 /* If there is a variant part, we must compute whether the constraints
10378 statically select a particular variant. If so, we simply drop the
10379 qualified union and flatten the list of fields. Otherwise we will
10380 build a new qualified union for the variants that are still relevant. */
10381 if (gnu_variant_part)
10383 const Node_Id gnat_decl = Declaration_Node (gnat_new_type);
10384 variant_desc *v;
10385 unsigned int i;
10387 gnu_variant_list
10388 = build_variant_list (TREE_TYPE (gnu_variant_part),
10389 is_subtype
10390 ? Empty
10391 : Variant_Part
10392 (Component_List (Type_Definition (gnat_decl))),
10393 subst_list,
10394 vNULL);
10396 /* If all the qualifiers are unconditionally true, the innermost variant
10397 is statically selected. */
10398 selected_variant = true;
10399 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
10400 if (!integer_onep (v->qual))
10402 selected_variant = false;
10403 break;
10406 /* Otherwise, create the new variants. */
10407 if (!selected_variant)
10408 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
10410 tree old_variant = v->type;
10411 tree new_variant = make_node (RECORD_TYPE);
10412 tree suffix
10413 = concat_name (DECL_NAME (gnu_variant_part),
10414 IDENTIFIER_POINTER (DECL_NAME (v->field)));
10415 TYPE_NAME (new_variant)
10416 = concat_name (TYPE_NAME (gnu_new_type),
10417 IDENTIFIER_POINTER (suffix));
10418 TYPE_REVERSE_STORAGE_ORDER (new_variant)
10419 = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
10420 copy_and_substitute_in_size (new_variant, old_variant, subst_list);
10421 v->new_type = new_variant;
10424 else
10426 gnu_variant_list.create (0);
10427 selected_variant = false;
10430 /* Make a list of fields and their position in the old type. */
10431 tree gnu_pos_list
10432 = build_position_list (gnu_old_type,
10433 gnu_variant_list.exists () && !selected_variant,
10434 size_zero_node, bitsize_zero_node,
10435 BIGGEST_ALIGNMENT, NULL_TREE);
10437 /* Now go down every component in the new type and compute its size and
10438 position from those of the component in the old type and the stored
10439 constraints of the new type. */
10440 Entity_Id gnat_field, gnat_old_field;
10441 for (gnat_field = First_Entity (gnat_new_type);
10442 Present (gnat_field);
10443 gnat_field = Next_Entity (gnat_field))
10444 if ((Ekind (gnat_field) == E_Component
10445 || (Ekind (gnat_field) == E_Discriminant
10446 && is_stored_discriminant (gnat_field, gnat_new_type)))
10447 && (gnat_old_field = is_subtype
10448 ? Original_Record_Component (gnat_field)
10449 : Corresponding_Record_Component (gnat_field))
10450 && Underlying_Type (Scope (gnat_old_field)) == gnat_old_type
10451 && present_gnu_tree (gnat_old_field))
10453 Name_Id gnat_name = Chars (gnat_field);
10454 tree gnu_old_field = get_gnu_tree (gnat_old_field);
10455 if (TREE_CODE (gnu_old_field) == COMPONENT_REF)
10456 gnu_old_field = TREE_OPERAND (gnu_old_field, 1);
10457 tree gnu_context = DECL_CONTEXT (gnu_old_field);
10458 tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
10459 tree gnu_cont_type, gnu_last = NULL_TREE;
10460 variant_desc *v = NULL;
10462 /* If the type is the same, retrieve the GCC type from the
10463 old field to take into account possible adjustments. */
10464 if (Etype (gnat_field) == Etype (gnat_old_field))
10465 gnu_field_type = TREE_TYPE (gnu_old_field);
10466 else
10467 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
10469 /* If there was a component clause, the field types must be the same
10470 for the old and new types, so copy the data from the old field to
10471 avoid recomputation here. Also if the field is justified modular
10472 and the optimization in gnat_to_gnu_field was applied. */
10473 if (Present (Component_Clause (gnat_old_field))
10474 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
10475 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
10476 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
10477 == TREE_TYPE (gnu_old_field)))
10479 gnu_size = DECL_SIZE (gnu_old_field);
10480 gnu_field_type = TREE_TYPE (gnu_old_field);
10483 /* If the old field was packed and of constant size, we have to get the
10484 old size here as it might differ from what the Etype conveys and the
10485 latter might overlap with the following field. Try to arrange the
10486 type for possible better packing along the way. */
10487 else if (DECL_PACKED (gnu_old_field)
10488 && TREE_CODE (DECL_SIZE (gnu_old_field)) == INTEGER_CST)
10490 gnu_size = DECL_SIZE (gnu_old_field);
10491 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
10492 && !TYPE_FAT_POINTER_P (gnu_field_type)
10493 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
10494 gnu_field_type = make_packable_type (gnu_field_type, true, 0);
10497 else
10498 gnu_size = TYPE_SIZE (gnu_field_type);
10500 /* If the context of the old field is the old type or its REP part,
10501 put the field directly in the new type; otherwise look up the
10502 context in the variant list and put the field either in the new
10503 type if there is a selected variant or in one new variant. */
10504 if (gnu_context == gnu_old_type
10505 || (gnu_rep_part && gnu_context == TREE_TYPE (gnu_rep_part)))
10506 gnu_cont_type = gnu_new_type;
10507 else
10509 unsigned int i;
10510 tree rep_part;
10512 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
10513 if (gnu_context == v->type
10514 || ((rep_part = get_rep_part (v->type))
10515 && gnu_context == TREE_TYPE (rep_part)))
10516 break;
10518 if (v)
10519 gnu_cont_type = selected_variant ? gnu_new_type : v->new_type;
10520 else
10521 /* The front-end may pass us zombie components if it fails to
10522 recognize that a constrain statically selects a particular
10523 variant. Discard them. */
10524 continue;
10527 /* Now create the new field modeled on the old one. */
10528 gnu_field
10529 = create_field_decl_from (gnu_old_field, gnu_field_type,
10530 gnu_cont_type, gnu_size,
10531 gnu_pos_list, subst_list);
10532 gnu_pos = DECL_FIELD_OFFSET (gnu_field);
10534 /* If the context is a variant, put it in the new variant directly. */
10535 if (gnu_cont_type != gnu_new_type)
10537 if (TREE_CODE (gnu_pos) == INTEGER_CST)
10539 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
10540 TYPE_FIELDS (gnu_cont_type) = gnu_field;
10542 else
10544 DECL_CHAIN (gnu_field) = v->aux;
10545 v->aux = gnu_field;
10549 /* To match the layout crafted in components_to_record, if this is
10550 the _Tag or _Parent field, put it before any other fields. */
10551 else if (gnat_name == Name_uTag || gnat_name == Name_uParent)
10552 gnu_field_list = chainon (gnu_field_list, gnu_field);
10554 /* Similarly, if this is the _Controller field, put it before the
10555 other fields except for the _Tag or _Parent field. */
10556 else if (gnat_name == Name_uController && gnu_last)
10558 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
10559 DECL_CHAIN (gnu_last) = gnu_field;
10562 /* Otherwise, put it after the other fields. */
10563 else
10565 if (TREE_CODE (gnu_pos) == INTEGER_CST)
10567 DECL_CHAIN (gnu_field) = gnu_field_list;
10568 gnu_field_list = gnu_field;
10569 if (!gnu_last)
10570 gnu_last = gnu_field;
10572 else
10574 DECL_CHAIN (gnu_field) = gnu_variable_field_list;
10575 gnu_variable_field_list = gnu_field;
10579 /* For a stored discriminant in a derived type, replace the field. */
10580 if (!is_subtype && Ekind (gnat_field) == E_Discriminant)
10582 tree gnu_ref = get_gnu_tree (gnat_field);
10583 TREE_OPERAND (gnu_ref, 1) = gnu_field;
10585 else
10586 save_gnu_tree (gnat_field, gnu_field, false);
10589 /* Put the fields with fixed position in order of increasing position. */
10590 if (gnu_field_list)
10591 gnu_field_list = reverse_sort_field_list (gnu_field_list);
10593 /* Put the fields with variable position at the end. */
10594 if (gnu_variable_field_list)
10595 gnu_field_list = chainon (gnu_variable_field_list, gnu_field_list);
10597 /* If there is a variant list and no selected variant, we need to create the
10598 nest of variant parts from the old nest. */
10599 if (gnu_variant_list.exists () && !selected_variant)
10601 variant_desc *v;
10602 unsigned int i;
10604 /* Same processing as above for the fields of each variant. */
10605 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
10607 if (TYPE_FIELDS (v->new_type))
10608 TYPE_FIELDS (v->new_type)
10609 = reverse_sort_field_list (TYPE_FIELDS (v->new_type));
10610 if (v->aux)
10611 TYPE_FIELDS (v->new_type)
10612 = chainon (v->aux, TYPE_FIELDS (v->new_type));
10615 tree new_variant_part
10616 = create_variant_part_from (gnu_variant_part, gnu_variant_list,
10617 gnu_new_type, gnu_pos_list,
10618 subst_list, debug_info_p);
10619 DECL_CHAIN (new_variant_part) = gnu_field_list;
10620 gnu_field_list = new_variant_part;
10623 gnu_variant_list.release ();
10624 subst_list.release ();
10626 /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
10627 Otherwise sizes and alignment must be computed independently. */
10628 finish_record_type (gnu_new_type, nreverse (gnu_field_list),
10629 is_subtype ? 2 : 1, debug_info_p);
10631 /* Now go through the entities again looking for itypes that we have not yet
10632 elaborated (e.g. Etypes of fields that have Original_Components). */
10633 for (Entity_Id gnat_field = First_Entity (gnat_new_type);
10634 Present (gnat_field);
10635 gnat_field = Next_Entity (gnat_field))
10636 if ((Ekind (gnat_field) == E_Component
10637 || Ekind (gnat_field) == E_Discriminant)
10638 && Is_Itype (Etype (gnat_field))
10639 && !present_gnu_tree (Etype (gnat_field)))
10640 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
10643 /* Associate to the implementation type of a packed array type specified by
10644 GNU_TYPE, which is the translation of GNAT_ENTITY, the original array type
10645 if it has been translated. This association is a parallel type for GNAT
10646 encodings or a debug type for standard DWARF. Note that for standard DWARF,
10647 we also want to get the original type name and therefore we return it. */
10649 static tree
10650 associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
10652 const Entity_Id gnat_original_array_type
10653 = Underlying_Type (Original_Array_Type (gnat_entity));
10654 tree gnu_original_array_type;
10656 if (!present_gnu_tree (gnat_original_array_type))
10657 return NULL_TREE;
10659 gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
10661 if (TYPE_IS_DUMMY_P (gnu_original_array_type))
10662 return NULL_TREE;
10664 gcc_assert (TYPE_IMPL_PACKED_ARRAY_P (gnu_type));
10666 if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL)
10668 add_parallel_type (gnu_type, gnu_original_array_type);
10669 return NULL_TREE;
10671 else
10673 SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
10675 tree original_name = TYPE_NAME (gnu_original_array_type);
10676 if (TREE_CODE (original_name) == TYPE_DECL)
10677 original_name = DECL_NAME (original_name);
10678 return original_name;
10682 /* Given a type T, a FIELD_DECL F, and a replacement value R, return an
10683 equivalent type with adjusted size expressions where all occurrences
10684 of references to F in a PLACEHOLDER_EXPR have been replaced by R.
10686 The function doesn't update the layout of the type, i.e. it assumes
10687 that the substitution is purely formal. That's why the replacement
10688 value R must itself contain a PLACEHOLDER_EXPR. */
10690 tree
10691 substitute_in_type (tree t, tree f, tree r)
10693 tree nt;
10695 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
10697 switch (TREE_CODE (t))
10699 case INTEGER_TYPE:
10700 case ENUMERAL_TYPE:
10701 case BOOLEAN_TYPE:
10702 case REAL_TYPE:
10704 /* First the domain types of arrays. */
10705 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
10706 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
10708 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
10709 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
10711 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
10712 return t;
10714 nt = copy_type (t);
10715 TYPE_GCC_MIN_VALUE (nt) = low;
10716 TYPE_GCC_MAX_VALUE (nt) = high;
10718 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
10719 SET_TYPE_INDEX_TYPE
10720 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
10722 return nt;
10725 /* Then the subtypes. */
10726 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
10727 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
10729 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
10730 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
10732 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
10733 return t;
10735 nt = copy_type (t);
10736 SET_TYPE_RM_MIN_VALUE (nt, low);
10737 SET_TYPE_RM_MAX_VALUE (nt, high);
10739 return nt;
10742 return t;
10744 case COMPLEX_TYPE:
10745 nt = substitute_in_type (TREE_TYPE (t), f, r);
10746 if (nt == TREE_TYPE (t))
10747 return t;
10749 return build_complex_type (nt);
10751 case FUNCTION_TYPE:
10752 case METHOD_TYPE:
10753 /* These should never show up here. */
10754 gcc_unreachable ();
10756 case ARRAY_TYPE:
10758 tree component = substitute_in_type (TREE_TYPE (t), f, r);
10759 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
10761 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
10762 return t;
10764 nt = build_nonshared_array_type (component, domain);
10765 SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
10766 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
10767 SET_TYPE_MODE (nt, TYPE_MODE (t));
10768 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
10769 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
10770 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
10771 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
10772 if (TYPE_REVERSE_STORAGE_ORDER (t))
10773 set_reverse_storage_order_on_array_type (nt);
10774 if (TYPE_NONALIASED_COMPONENT (t))
10775 set_nonaliased_component_on_array_type (nt);
10776 return nt;
10779 case RECORD_TYPE:
10780 case UNION_TYPE:
10781 case QUAL_UNION_TYPE:
10783 bool changed_field = false;
10784 tree field;
10786 /* Start out with no fields, make new fields, and chain them
10787 in. If we haven't actually changed the type of any field,
10788 discard everything we've done and return the old type. */
10789 nt = copy_type (t);
10790 TYPE_FIELDS (nt) = NULL_TREE;
10792 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
10794 tree new_field = copy_node (field), new_n;
10796 new_n = substitute_in_type (TREE_TYPE (field), f, r);
10797 if (new_n != TREE_TYPE (field))
10799 TREE_TYPE (new_field) = new_n;
10800 changed_field = true;
10803 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
10804 if (new_n != DECL_FIELD_OFFSET (field))
10806 DECL_FIELD_OFFSET (new_field) = new_n;
10807 changed_field = true;
10810 /* Do the substitution inside the qualifier, if any. */
10811 if (TREE_CODE (t) == QUAL_UNION_TYPE)
10813 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
10814 if (new_n != DECL_QUALIFIER (field))
10816 DECL_QUALIFIER (new_field) = new_n;
10817 changed_field = true;
10821 DECL_CONTEXT (new_field) = nt;
10822 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
10824 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
10825 TYPE_FIELDS (nt) = new_field;
10828 if (!changed_field)
10829 return t;
10831 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
10832 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
10833 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
10834 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
10835 return nt;
10838 default:
10839 return t;
10843 /* Return the RM size of GNU_TYPE. This is the actual number of bits
10844 needed to represent the object. */
10846 tree
10847 rm_size (tree gnu_type)
10849 /* For integral types, we store the RM size explicitly. */
10850 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
10851 return TYPE_RM_SIZE (gnu_type);
10853 /* If the type contains a template, return the padded size of the template
10854 plus the RM size of the actual data. */
10855 if (TREE_CODE (gnu_type) == RECORD_TYPE
10856 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
10857 return
10858 size_binop (PLUS_EXPR,
10859 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type))),
10860 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))));
10862 /* For record or union types, we store the size explicitly. */
10863 if (RECORD_OR_UNION_TYPE_P (gnu_type)
10864 && !TYPE_FAT_POINTER_P (gnu_type)
10865 && TYPE_ADA_SIZE (gnu_type))
10866 return TYPE_ADA_SIZE (gnu_type);
10868 /* For other types, this is just the size. */
10869 return TYPE_SIZE (gnu_type);
10872 /* Return the name to be used for GNAT_ENTITY. If a type, create a
10873 fully-qualified name, possibly with type information encoding.
10874 Otherwise, return the name. */
10876 static const char *
10877 get_entity_char (Entity_Id gnat_entity)
10879 Get_Encoded_Name (gnat_entity);
10880 return ggc_strdup (Name_Buffer);
10883 tree
10884 get_entity_name (Entity_Id gnat_entity)
10886 Get_Encoded_Name (gnat_entity);
10887 return get_identifier_with_length (Name_Buffer, Name_Len);
10890 /* Return an identifier representing the external name to be used for
10891 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
10892 and the specified suffix. */
10894 tree
10895 create_concat_name (Entity_Id gnat_entity, const char *suffix)
10897 const Entity_Kind kind = Ekind (gnat_entity);
10898 const bool has_suffix = (suffix != NULL);
10899 String_Template temp = {1, has_suffix ? (int) strlen (suffix) : 0};
10900 String_Pointer sp = {suffix, &temp};
10902 Get_External_Name (gnat_entity, has_suffix, sp);
10904 /* A variable using the Stdcall convention lives in a DLL. We adjust
10905 its name to use the jump table, the _imp__NAME contains the address
10906 for the NAME variable. */
10907 if ((kind == E_Variable || kind == E_Constant)
10908 && Has_Stdcall_Convention (gnat_entity))
10910 const int len = strlen (STDCALL_PREFIX) + Name_Len;
10911 char *new_name = (char *) alloca (len + 1);
10912 strcpy (new_name, STDCALL_PREFIX);
10913 strcat (new_name, Name_Buffer);
10914 return get_identifier_with_length (new_name, len);
10917 return get_identifier_with_length (Name_Buffer, Name_Len);
10920 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
10921 string, return a new IDENTIFIER_NODE that is the concatenation of
10922 the name followed by "___" and the specified suffix. */
10924 tree
10925 concat_name (tree gnu_name, const char *suffix)
10927 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
10928 char *new_name = (char *) alloca (len + 1);
10929 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
10930 strcat (new_name, "___");
10931 strcat (new_name, suffix);
10932 return get_identifier_with_length (new_name, len);
10935 /* Initialize the data structures of the decl.cc module. */
10937 void
10938 init_gnat_decl (void)
10940 /* Initialize the cache of annotated values. */
10941 annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
10943 /* Initialize the association of dummy types with subprograms. */
10944 dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
10947 /* Destroy the data structures of the decl.cc module. */
10949 void
10950 destroy_gnat_decl (void)
10952 /* Destroy the cache of annotated values. */
10953 annotate_value_cache->empty ();
10954 annotate_value_cache = NULL;
10956 /* Destroy the association of dummy types with subprograms. */
10957 dummy_to_subprog_map->empty ();
10958 dummy_to_subprog_map = NULL;
10961 #include "gt-ada-decl.h"