[33/77] Add a NARROWEST_INT_MODE macro
[official-gcc.git] / gcc / ada / gcc-interface / decl.c
blobae4c6ec27b1774035d22aa9d9190e8e6c7f0cd6c
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2017, 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 "tree.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h"
33 #include "alias.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
36 #include "tree-inline.h"
37 #include "demangle.h"
39 #include "ada.h"
40 #include "types.h"
41 #include "atree.h"
42 #include "elists.h"
43 #include "namet.h"
44 #include "nlists.h"
45 #include "repinfo.h"
46 #include "snames.h"
47 #include "uintp.h"
48 #include "urealp.h"
49 #include "fe.h"
50 #include "sinfo.h"
51 #include "einfo.h"
52 #include "ada-tree.h"
53 #include "gigi.h"
55 /* "stdcall" and "thiscall" conventions should be processed in a specific way
56 on 32-bit x86/Windows only. The macros below are helpers to avoid having
57 to check for a Windows specific attribute throughout this unit. */
59 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
60 #ifdef TARGET_64BIT
61 #define Has_Stdcall_Convention(E) \
62 (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
63 #define Has_Thiscall_Convention(E) \
64 (!TARGET_64BIT && is_cplusplus_method (E))
65 #else
66 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
67 #define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
68 #endif
69 #else
70 #define Has_Stdcall_Convention(E) 0
71 #define Has_Thiscall_Convention(E) 0
72 #endif
74 #define STDCALL_PREFIX "_imp__"
76 /* Stack realignment is necessary for functions with foreign conventions when
77 the ABI doesn't mandate as much as what the compiler assumes - that is, up
78 to PREFERRED_STACK_BOUNDARY.
80 Such realignment can be requested with a dedicated function type attribute
81 on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
82 characterize the situations where the attribute should be set. We rely on
83 compiler configuration settings for 'main' to decide. */
85 #ifdef MAIN_STACK_BOUNDARY
86 #define FOREIGN_FORCE_REALIGN_STACK \
87 (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
88 #else
89 #define FOREIGN_FORCE_REALIGN_STACK 0
90 #endif
92 struct incomplete
94 struct incomplete *next;
95 tree old_type;
96 Entity_Id full_type;
99 /* These variables are used to defer recursively expanding incomplete types
100 while we are processing a record, an array or a subprogram type. */
101 static int defer_incomplete_level = 0;
102 static struct incomplete *defer_incomplete_list;
104 /* This variable is used to delay expanding types coming from a limited with
105 clause and completed Taft Amendment types until the end of the spec. */
106 static struct incomplete *defer_limited_with_list;
108 typedef struct subst_pair_d {
109 tree discriminant;
110 tree replacement;
111 } subst_pair;
114 typedef struct variant_desc_d {
115 /* The type of the variant. */
116 tree type;
118 /* The associated field. */
119 tree field;
121 /* The value of the qualifier. */
122 tree qual;
124 /* The type of the variant after transformation. */
125 tree new_type;
126 } variant_desc;
129 /* A map used to cache the result of annotate_value. */
130 struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
132 static inline hashval_t
133 hash (tree_int_map *m)
135 return htab_hash_pointer (m->base.from);
138 static inline bool
139 equal (tree_int_map *a, tree_int_map *b)
141 return a->base.from == b->base.from;
144 static int
145 keep_cache_entry (tree_int_map *&m)
147 return ggc_marked_p (m->base.from);
151 static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
153 /* A map used to associate a dummy type with a list of subprogram entities. */
154 struct GTY((for_user)) tree_entity_vec_map
156 struct tree_map_base base;
157 vec<Entity_Id, va_gc_atomic> *to;
160 void
161 gt_pch_nx (Entity_Id &)
165 void
166 gt_pch_nx (Entity_Id *x, gt_pointer_operator op, void *cookie)
168 op (x, cookie);
171 struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
173 static inline hashval_t
174 hash (tree_entity_vec_map *m)
176 return htab_hash_pointer (m->base.from);
179 static inline bool
180 equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
182 return a->base.from == b->base.from;
185 static int
186 keep_cache_entry (tree_entity_vec_map *&m)
188 return ggc_marked_p (m->base.from);
192 static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
194 static void prepend_one_attribute (struct attrib **,
195 enum attrib_type, tree, tree, Node_Id);
196 static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
197 static void prepend_attributes (struct attrib **, Entity_Id);
198 static tree elaborate_expression (Node_Id, Entity_Id, const char *, bool, bool,
199 bool);
200 static bool type_has_variable_size (tree);
201 static tree elaborate_expression_1 (tree, Entity_Id, const char *, bool, bool);
202 static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
203 unsigned int);
204 static tree elaborate_reference (tree, Entity_Id, bool, tree *);
205 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
206 static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
207 static int adjust_packed (tree, tree, int);
208 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
209 static tree gnu_ext_name_for_subprog (Entity_Id, tree);
210 static tree change_qualified_type (tree, int);
211 static void set_nonaliased_component_on_array_type (tree);
212 static void set_reverse_storage_order_on_array_type (tree);
213 static bool same_discriminant_p (Entity_Id, Entity_Id);
214 static bool array_type_has_nonaliased_component (tree, Entity_Id);
215 static bool compile_time_known_address_p (Node_Id);
216 static bool cannot_be_superflat (Node_Id);
217 static bool constructor_address_p (tree);
218 static bool allocatable_size_p (tree, bool);
219 static bool initial_value_needs_conversion (tree, tree);
220 static int compare_field_bitpos (const PTR, const PTR);
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, vec<subst_pair>,
229 vec<variant_desc>);
230 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
231 static void set_rm_size (Uint, tree, Entity_Id);
232 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
233 static void check_ok_for_atomic_type (tree, Entity_Id, bool);
234 static tree create_field_decl_from (tree, tree, tree, tree, tree,
235 vec<subst_pair>);
236 static tree create_rep_part (tree, tree, tree);
237 static tree get_rep_part (tree);
238 static tree create_variant_part_from (tree, vec<variant_desc>, tree,
239 tree, vec<subst_pair>, bool);
240 static void copy_and_substitute_in_size (tree, tree, vec<subst_pair>);
241 static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree,
242 vec<subst_pair>, bool);
243 static void associate_original_type_to_packed_array (tree, Entity_Id);
244 static const char *get_entity_char (Entity_Id);
246 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
247 to pass around calls performing profile compatibility checks. */
249 typedef struct {
250 Entity_Id gnat_entity; /* The Ada subprogram entity. */
251 tree ada_fntype; /* The corresponding GCC type node. */
252 tree btin_fntype; /* The GCC builtin function type node. */
253 } intrin_binding_t;
255 static bool intrin_profiles_compatible_p (intrin_binding_t *);
257 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
258 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
259 and associate the ..._DECL node with the input GNAT defining identifier.
261 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
262 initial value (in GCC tree form). This is optional for a variable. For
263 a renamed entity, GNU_EXPR gives the object being renamed.
265 DEFINITION is true if this call is intended for a definition. This is used
266 for separate compilation where it is necessary to know whether an external
267 declaration or a definition must be created if the GCC equivalent was not
268 created previously. */
270 tree
271 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
273 /* Contains the kind of the input GNAT node. */
274 const Entity_Kind kind = Ekind (gnat_entity);
275 /* True if this is a type. */
276 const bool is_type = IN (kind, Type_Kind);
277 /* True if this is an artificial entity. */
278 const bool artificial_p = !Comes_From_Source (gnat_entity);
279 /* True if debug info is requested for this entity. */
280 const bool debug_info_p = Needs_Debug_Info (gnat_entity);
281 /* True if this entity is to be considered as imported. */
282 const bool imported_p
283 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
284 /* For a type, contains the equivalent GNAT node to be used in gigi. */
285 Entity_Id gnat_equiv_type = Empty;
286 /* Temporary used to walk the GNAT tree. */
287 Entity_Id gnat_temp;
288 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
289 This node will be associated with the GNAT node by calling at the end
290 of the `switch' statement. */
291 tree gnu_decl = NULL_TREE;
292 /* Contains the GCC type to be used for the GCC node. */
293 tree gnu_type = NULL_TREE;
294 /* Contains the GCC size tree to be used for the GCC node. */
295 tree gnu_size = NULL_TREE;
296 /* Contains the GCC name to be used for the GCC node. */
297 tree gnu_entity_name;
298 /* True if we have already saved gnu_decl as a GNAT association. */
299 bool saved = false;
300 /* True if we incremented defer_incomplete_level. */
301 bool this_deferred = false;
302 /* True if we incremented force_global. */
303 bool this_global = false;
304 /* True if we should check to see if elaborated during processing. */
305 bool maybe_present = false;
306 /* True if we made GNU_DECL and its type here. */
307 bool this_made_decl = false;
308 /* Size and alignment of the GCC node, if meaningful. */
309 unsigned int esize = 0, align = 0;
310 /* Contains the list of attributes directly attached to the entity. */
311 struct attrib *attr_list = NULL;
313 /* Since a use of an Itype is a definition, process it as such if it is in
314 the main unit, except for E_Access_Subtype because it's actually a use
315 of its base type, see below. */
316 if (!definition
317 && is_type
318 && Is_Itype (gnat_entity)
319 && Ekind (gnat_entity) != E_Access_Subtype
320 && !present_gnu_tree (gnat_entity)
321 && In_Extended_Main_Code_Unit (gnat_entity))
323 /* Ensure that we are in a subprogram mentioned in the Scope chain of
324 this entity, our current scope is global, or we encountered a task
325 or entry (where we can't currently accurately check scoping). */
326 if (!current_function_decl
327 || DECL_ELABORATION_PROC_P (current_function_decl))
329 process_type (gnat_entity);
330 return get_gnu_tree (gnat_entity);
333 for (gnat_temp = Scope (gnat_entity);
334 Present (gnat_temp);
335 gnat_temp = Scope (gnat_temp))
337 if (Is_Type (gnat_temp))
338 gnat_temp = Underlying_Type (gnat_temp);
340 if (Ekind (gnat_temp) == E_Subprogram_Body)
341 gnat_temp
342 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
344 if (IN (Ekind (gnat_temp), Subprogram_Kind)
345 && Present (Protected_Body_Subprogram (gnat_temp)))
346 gnat_temp = Protected_Body_Subprogram (gnat_temp);
348 if (Ekind (gnat_temp) == E_Entry
349 || Ekind (gnat_temp) == E_Entry_Family
350 || Ekind (gnat_temp) == E_Task_Type
351 || (IN (Ekind (gnat_temp), Subprogram_Kind)
352 && present_gnu_tree (gnat_temp)
353 && (current_function_decl
354 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))))
356 process_type (gnat_entity);
357 return get_gnu_tree (gnat_entity);
361 /* This abort means the Itype has an incorrect scope, i.e. that its
362 scope does not correspond to the subprogram it is declared in. */
363 gcc_unreachable ();
366 /* If we've already processed this entity, return what we got last time.
367 If we are defining the node, we should not have already processed it.
368 In that case, we will abort below when we try to save a new GCC tree
369 for this object. We also need to handle the case of getting a dummy
370 type when a Full_View exists but be careful so as not to trigger its
371 premature elaboration. */
372 if ((!definition || (is_type && imported_p))
373 && present_gnu_tree (gnat_entity))
375 gnu_decl = get_gnu_tree (gnat_entity);
377 if (TREE_CODE (gnu_decl) == TYPE_DECL
378 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
379 && IN (kind, Incomplete_Or_Private_Kind)
380 && Present (Full_View (gnat_entity))
381 && (present_gnu_tree (Full_View (gnat_entity))
382 || No (Freeze_Node (Full_View (gnat_entity)))))
384 gnu_decl
385 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, false);
386 save_gnu_tree (gnat_entity, NULL_TREE, false);
387 save_gnu_tree (gnat_entity, gnu_decl, false);
390 return gnu_decl;
393 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
394 must be specified unless it was specified by the programmer. Exceptions
395 are for access-to-protected-subprogram types and all access subtypes, as
396 another GNAT type is used to lay out the GCC type for them. */
397 gcc_assert (!is_type
398 || Known_Esize (gnat_entity)
399 || Has_Size_Clause (gnat_entity)
400 || (!IN (kind, Numeric_Kind)
401 && !IN (kind, Enumeration_Kind)
402 && (!IN (kind, Access_Kind)
403 || kind == E_Access_Protected_Subprogram_Type
404 || kind == E_Anonymous_Access_Protected_Subprogram_Type
405 || kind == E_Access_Subtype
406 || type_annotate_only)));
408 /* The RM size must be specified for all discrete and fixed-point types. */
409 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
410 && Unknown_RM_Size (gnat_entity)));
412 /* If we get here, it means we have not yet done anything with this entity.
413 If we are not defining it, it must be a type or an entity that is defined
414 elsewhere or externally, otherwise we should have defined it already. */
415 gcc_assert (definition
416 || type_annotate_only
417 || is_type
418 || kind == E_Discriminant
419 || kind == E_Component
420 || kind == E_Label
421 || (kind == E_Constant && Present (Full_View (gnat_entity)))
422 || Is_Public (gnat_entity));
424 /* Get the name of the entity and set up the line number and filename of
425 the original definition for use in any decl we make. Make sure we do not
426 inherit another source location. */
427 gnu_entity_name = get_entity_name (gnat_entity);
428 if (Sloc (gnat_entity) != No_Location
429 && !renaming_from_generic_instantiation_p (gnat_entity))
430 Sloc_to_locus (Sloc (gnat_entity), &input_location);
432 /* For cases when we are not defining (i.e., we are referencing from
433 another compilation unit) public entities, show we are at global level
434 for the purpose of computing scopes. Don't do this for components or
435 discriminants since the relevant test is whether or not the record is
436 being defined. */
437 if (!definition
438 && kind != E_Component
439 && kind != E_Discriminant
440 && Is_Public (gnat_entity)
441 && !Is_Statically_Allocated (gnat_entity))
442 force_global++, this_global = true;
444 /* Handle any attributes directly attached to the entity. */
445 if (Has_Gigi_Rep_Item (gnat_entity))
446 prepend_attributes (&attr_list, gnat_entity);
448 /* Do some common processing for types. */
449 if (is_type)
451 /* Compute the equivalent type to be used in gigi. */
452 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
454 /* Machine_Attributes on types are expected to be propagated to
455 subtypes. The corresponding Gigi_Rep_Items are only attached
456 to the first subtype though, so we handle the propagation here. */
457 if (Base_Type (gnat_entity) != gnat_entity
458 && !Is_First_Subtype (gnat_entity)
459 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
460 prepend_attributes (&attr_list,
461 First_Subtype (Base_Type (gnat_entity)));
463 /* Compute a default value for the size of an elementary type. */
464 if (Known_Esize (gnat_entity) && Is_Elementary_Type (gnat_entity))
466 unsigned int max_esize;
468 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity)));
469 esize = UI_To_Int (Esize (gnat_entity));
471 if (IN (kind, Float_Kind))
472 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
473 else if (IN (kind, Access_Kind))
474 max_esize = POINTER_SIZE * 2;
475 else
476 max_esize = LONG_LONG_TYPE_SIZE;
478 if (esize > max_esize)
479 esize = max_esize;
483 switch (kind)
485 case E_Component:
486 case E_Discriminant:
488 /* The GNAT record where the component was defined. */
489 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
491 /* If the entity is a discriminant of an extended tagged type used to
492 rename a discriminant of the parent type, return the latter. */
493 if (kind == E_Discriminant
494 && Present (Corresponding_Discriminant (gnat_entity))
495 && Is_Tagged_Type (gnat_record))
497 gnu_decl
498 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
499 gnu_expr, definition);
500 saved = true;
501 break;
504 /* If the entity is an inherited component (in the case of extended
505 tagged record types), just return the original entity, which must
506 be a FIELD_DECL. Likewise for discriminants. If the entity is a
507 non-girder discriminant (in the case of derived untagged record
508 types), return the stored discriminant it renames. */
509 if (Present (Original_Record_Component (gnat_entity))
510 && Original_Record_Component (gnat_entity) != gnat_entity)
512 gnu_decl
513 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
514 gnu_expr, definition);
515 /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */
516 if (kind == E_Discriminant)
517 saved = true;
518 break;
521 /* Otherwise, if we are not defining this and we have no GCC type
522 for the containing record, make one for it. Then we should
523 have made our own equivalent. */
524 if (!definition && !present_gnu_tree (gnat_record))
526 /* ??? If this is in a record whose scope is a protected
527 type and we have an Original_Record_Component, use it.
528 This is a workaround for major problems in protected type
529 handling. */
530 Entity_Id Scop = Scope (Scope (gnat_entity));
531 if (Is_Protected_Type (Underlying_Type (Scop))
532 && Present (Original_Record_Component (gnat_entity)))
534 gnu_decl
535 = gnat_to_gnu_entity (Original_Record_Component
536 (gnat_entity),
537 gnu_expr, false);
539 else
541 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, false);
542 gnu_decl = get_gnu_tree (gnat_entity);
545 saved = true;
546 break;
549 /* Here we have no GCC type and this is a reference rather than a
550 definition. This should never happen. Most likely the cause is
551 reference before declaration in the GNAT tree for gnat_entity. */
552 gcc_unreachable ();
555 case E_Constant:
556 /* Ignore constant definitions already marked with the error node. See
557 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
558 if (definition
559 && present_gnu_tree (gnat_entity)
560 && get_gnu_tree (gnat_entity) == error_mark_node)
562 maybe_present = true;
563 break;
566 /* Ignore deferred constant definitions without address clause since
567 they are processed fully in the front-end. If No_Initialization
568 is set, this is not a deferred constant but a constant whose value
569 is built manually. And constants that are renamings are handled
570 like variables. */
571 if (definition
572 && !gnu_expr
573 && No (Address_Clause (gnat_entity))
574 && !No_Initialization (Declaration_Node (gnat_entity))
575 && No (Renamed_Object (gnat_entity)))
577 gnu_decl = error_mark_node;
578 saved = true;
579 break;
582 /* If this is a use of a deferred constant without address clause,
583 get its full definition. */
584 if (!definition
585 && No (Address_Clause (gnat_entity))
586 && Present (Full_View (gnat_entity)))
588 gnu_decl
589 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, false);
590 saved = true;
591 break;
594 /* If we have a constant that we are not defining, get the expression it
595 was defined to represent. This is necessary to avoid generating dumb
596 elaboration code in simple cases, but we may throw it away later if it
597 is not a constant. But do not retrieve it if it is an allocator since
598 the designated type might still be dummy at this point. */
599 if (!definition
600 && !No_Initialization (Declaration_Node (gnat_entity))
601 && Present (Expression (Declaration_Node (gnat_entity)))
602 && Nkind (Expression (Declaration_Node (gnat_entity)))
603 != N_Allocator)
604 /* The expression may contain N_Expression_With_Actions nodes and
605 thus object declarations from other units. Discard them. */
606 gnu_expr
607 = gnat_to_gnu_external (Expression (Declaration_Node (gnat_entity)));
609 /* ... fall through ... */
611 case E_Exception:
612 case E_Loop_Parameter:
613 case E_Out_Parameter:
614 case E_Variable:
616 const Entity_Id gnat_type = Etype (gnat_entity);
617 /* Always create a variable for volatile objects and variables seen
618 constant but with a Linker_Section pragma. */
619 bool const_flag
620 = ((kind == E_Constant || kind == E_Variable)
621 && Is_True_Constant (gnat_entity)
622 && !(kind == E_Variable
623 && Present (Linker_Section_Pragma (gnat_entity)))
624 && !Treat_As_Volatile (gnat_entity)
625 && (((Nkind (Declaration_Node (gnat_entity))
626 == N_Object_Declaration)
627 && Present (Expression (Declaration_Node (gnat_entity))))
628 || Present (Renamed_Object (gnat_entity))
629 || imported_p));
630 bool inner_const_flag = const_flag;
631 bool static_flag = Is_Statically_Allocated (gnat_entity);
632 /* We implement RM 13.3(19) for exported and imported (non-constant)
633 objects by making them volatile. */
634 bool volatile_flag
635 = (Treat_As_Volatile (gnat_entity)
636 || (!const_flag && (Is_Exported (gnat_entity) || imported_p)));
637 bool mutable_p = false;
638 bool used_by_ref = false;
639 tree gnu_ext_name = NULL_TREE;
640 tree renamed_obj = NULL_TREE;
641 tree gnu_object_size;
643 /* We need to translate the renamed object even though we are only
644 referencing the renaming. But it may contain a call for which
645 we'll generate a temporary to hold the return value and which
646 is part of the definition of the renaming, so discard it. */
647 if (Present (Renamed_Object (gnat_entity)) && !definition)
649 if (kind == E_Exception)
650 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
651 NULL_TREE, false);
652 else
653 gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
656 /* Get the type after elaborating the renamed object. */
657 if (Has_Foreign_Convention (gnat_entity)
658 && Is_Descendant_Of_Address (gnat_type))
659 gnu_type = ptr_type_node;
660 else
662 gnu_type = gnat_to_gnu_type (gnat_type);
664 /* If this is a standard exception definition, use the standard
665 exception type. This is necessary to make sure that imported
666 and exported views of exceptions are merged in LTO mode. */
667 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
668 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
669 gnu_type = except_type_node;
672 /* For a debug renaming declaration, build a debug-only entity. */
673 if (Present (Debug_Renaming_Link (gnat_entity)))
675 /* Force a non-null value to make sure the symbol is retained. */
676 tree value = build1 (INDIRECT_REF, gnu_type,
677 build1 (NOP_EXPR,
678 build_pointer_type (gnu_type),
679 integer_minus_one_node));
680 gnu_decl = build_decl (input_location,
681 VAR_DECL, gnu_entity_name, gnu_type);
682 SET_DECL_VALUE_EXPR (gnu_decl, value);
683 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
684 TREE_STATIC (gnu_decl) = global_bindings_p ();
685 gnat_pushdecl (gnu_decl, gnat_entity);
686 break;
689 /* If this is a loop variable, its type should be the base type.
690 This is because the code for processing a loop determines whether
691 a normal loop end test can be done by comparing the bounds of the
692 loop against those of the base type, which is presumed to be the
693 size used for computation. But this is not correct when the size
694 of the subtype is smaller than the type. */
695 if (kind == E_Loop_Parameter)
696 gnu_type = get_base_type (gnu_type);
698 /* Reject non-renamed objects whose type is an unconstrained array or
699 any object whose type is a dummy type or void. */
700 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
701 && No (Renamed_Object (gnat_entity)))
702 || TYPE_IS_DUMMY_P (gnu_type)
703 || TREE_CODE (gnu_type) == VOID_TYPE)
705 gcc_assert (type_annotate_only);
706 if (this_global)
707 force_global--;
708 return error_mark_node;
711 /* If an alignment is specified, use it if valid. Note that exceptions
712 are objects but don't have an alignment. We must do this before we
713 validate the size, since the alignment can affect the size. */
714 if (kind != E_Exception && Known_Alignment (gnat_entity))
716 gcc_assert (Present (Alignment (gnat_entity)));
718 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
719 TYPE_ALIGN (gnu_type));
721 /* No point in changing the type if there is an address clause
722 as the final type of the object will be a reference type. */
723 if (Present (Address_Clause (gnat_entity)))
724 align = 0;
725 else
727 tree orig_type = gnu_type;
729 gnu_type
730 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
731 false, false, definition, true);
733 /* If a padding record was made, declare it now since it will
734 never be declared otherwise. This is necessary to ensure
735 that its subtrees are properly marked. */
736 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
737 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
738 debug_info_p, gnat_entity);
742 /* If we are defining the object, see if it has a Size and validate it
743 if so. If we are not defining the object and a Size clause applies,
744 simply retrieve the value. We don't want to ignore the clause and
745 it is expected to have been validated already. Then get the new
746 type, if any. */
747 if (definition)
748 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
749 gnat_entity, VAR_DECL, false,
750 Has_Size_Clause (gnat_entity));
751 else if (Has_Size_Clause (gnat_entity))
752 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
754 if (gnu_size)
756 gnu_type
757 = make_type_from_size (gnu_type, gnu_size,
758 Has_Biased_Representation (gnat_entity));
760 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
761 gnu_size = NULL_TREE;
764 /* If this object has self-referential size, it must be a record with
765 a default discriminant. We are supposed to allocate an object of
766 the maximum size in this case, unless it is a constant with an
767 initializing expression, in which case we can get the size from
768 that. Note that the resulting size may still be a variable, so
769 this may end up with an indirect allocation. */
770 if (No (Renamed_Object (gnat_entity))
771 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
773 if (gnu_expr && kind == E_Constant)
775 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
776 if (CONTAINS_PLACEHOLDER_P (size))
778 /* If the initializing expression is itself a constant,
779 despite having a nominal type with self-referential
780 size, we can get the size directly from it. */
781 if (TREE_CODE (gnu_expr) == COMPONENT_REF
782 && TYPE_IS_PADDING_P
783 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
784 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
785 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
786 || DECL_READONLY_ONCE_ELAB
787 (TREE_OPERAND (gnu_expr, 0))))
788 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
789 else
790 gnu_size
791 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
793 else
794 gnu_size = size;
796 /* We may have no GNU_EXPR because No_Initialization is
797 set even though there's an Expression. */
798 else if (kind == E_Constant
799 && (Nkind (Declaration_Node (gnat_entity))
800 == N_Object_Declaration)
801 && Present (Expression (Declaration_Node (gnat_entity))))
802 gnu_size
803 = TYPE_SIZE (gnat_to_gnu_type
804 (Etype
805 (Expression (Declaration_Node (gnat_entity)))));
806 else
808 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
809 mutable_p = true;
812 /* If the size isn't constant and we are at global level, call
813 elaborate_expression_1 to make a variable for it rather than
814 calculating it each time. */
815 if (!TREE_CONSTANT (gnu_size) && global_bindings_p ())
816 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
817 "SIZE", definition, false);
820 /* If the size is zero byte, make it one byte since some linkers have
821 troubles with zero-sized objects. If the object will have a
822 template, that will make it nonzero so don't bother. Also avoid
823 doing that for an object renaming or an object with an address
824 clause, as we would lose useful information on the view size
825 (e.g. for null array slices) and we are not allocating the object
826 here anyway. */
827 if (((gnu_size
828 && integer_zerop (gnu_size)
829 && !TREE_OVERFLOW (gnu_size))
830 || (TYPE_SIZE (gnu_type)
831 && integer_zerop (TYPE_SIZE (gnu_type))
832 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
833 && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
834 && No (Renamed_Object (gnat_entity))
835 && No (Address_Clause (gnat_entity)))
836 gnu_size = bitsize_unit_node;
838 /* If this is an object with no specified size and alignment, and
839 if either it is atomic or we are not optimizing alignment for
840 space and it is composite and not an exception, an Out parameter
841 or a reference to another object, and the size of its type is a
842 constant, set the alignment to the smallest one which is not
843 smaller than the size, with an appropriate cap. */
844 if (!gnu_size && align == 0
845 && (Is_Atomic_Or_VFA (gnat_entity)
846 || (!Optimize_Alignment_Space (gnat_entity)
847 && kind != E_Exception
848 && kind != E_Out_Parameter
849 && Is_Composite_Type (gnat_type)
850 && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
851 && !Is_Exported (gnat_entity)
852 && !imported_p
853 && No (Renamed_Object (gnat_entity))
854 && No (Address_Clause (gnat_entity))))
855 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
857 unsigned int size_cap, align_cap;
859 /* No point in promoting the alignment if this doesn't prevent
860 BLKmode access to the object, in particular block copy, as
861 this will for example disable the NRV optimization for it.
862 No point in jumping through all the hoops needed in order
863 to support BIGGEST_ALIGNMENT if we don't really have to.
864 So we cap to the smallest alignment that corresponds to
865 a known efficient memory access pattern of the target. */
866 if (Is_Atomic_Or_VFA (gnat_entity))
868 size_cap = UINT_MAX;
869 align_cap = BIGGEST_ALIGNMENT;
871 else
873 size_cap = MAX_FIXED_MODE_SIZE;
874 align_cap = get_mode_alignment (ptr_mode);
877 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
878 || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
879 align = 0;
880 else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
881 align = align_cap;
882 else
883 align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
885 /* But make sure not to under-align the object. */
886 if (align <= TYPE_ALIGN (gnu_type))
887 align = 0;
889 /* And honor the minimum valid atomic alignment, if any. */
890 #ifdef MINIMUM_ATOMIC_ALIGNMENT
891 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
892 align = MINIMUM_ATOMIC_ALIGNMENT;
893 #endif
896 /* If the object is set to have atomic components, find the component
897 type and validate it.
899 ??? Note that we ignore Has_Volatile_Components on objects; it's
900 not at all clear what to do in that case. */
901 if (Has_Atomic_Components (gnat_entity))
903 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
904 ? TREE_TYPE (gnu_type) : gnu_type);
906 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
907 && TYPE_MULTI_ARRAY_P (gnu_inner))
908 gnu_inner = TREE_TYPE (gnu_inner);
910 check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
913 /* If this is an aliased object with an unconstrained array nominal
914 subtype, make a type that includes the template. We will either
915 allocate or create a variable of that type, see below. */
916 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
917 && Is_Array_Type (Underlying_Type (gnat_type))
918 && !type_annotate_only)
920 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
921 gnu_type
922 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
923 gnu_type,
924 concat_name (gnu_entity_name,
925 "UNC"),
926 debug_info_p);
929 /* ??? If this is an object of CW type initialized to a value, try to
930 ensure that the object is sufficient aligned for this value, but
931 without pessimizing the allocation. This is a kludge necessary
932 because we don't support dynamic alignment. */
933 if (align == 0
934 && Ekind (gnat_type) == E_Class_Wide_Subtype
935 && No (Renamed_Object (gnat_entity))
936 && No (Address_Clause (gnat_entity)))
937 align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
939 #ifdef MINIMUM_ATOMIC_ALIGNMENT
940 /* If the size is a constant and no alignment is specified, force
941 the alignment to be the minimum valid atomic alignment. The
942 restriction on constant size avoids problems with variable-size
943 temporaries; if the size is variable, there's no issue with
944 atomic access. Also don't do this for a constant, since it isn't
945 necessary and can interfere with constant replacement. Finally,
946 do not do it for Out parameters since that creates an
947 size inconsistency with In parameters. */
948 if (align == 0
949 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
950 && !FLOAT_TYPE_P (gnu_type)
951 && !const_flag && No (Renamed_Object (gnat_entity))
952 && !imported_p && No (Address_Clause (gnat_entity))
953 && kind != E_Out_Parameter
954 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
955 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
956 align = MINIMUM_ATOMIC_ALIGNMENT;
957 #endif
959 /* Make a new type with the desired size and alignment, if needed.
960 But do not take into account alignment promotions to compute the
961 size of the object. */
962 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
963 if (gnu_size || align > 0)
965 tree orig_type = gnu_type;
967 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
968 false, false, definition, true);
970 /* If a padding record was made, declare it now since it will
971 never be declared otherwise. This is necessary to ensure
972 that its subtrees are properly marked. */
973 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
974 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
975 debug_info_p, gnat_entity);
978 /* Now check if the type of the object allows atomic access. */
979 if (Is_Atomic_Or_VFA (gnat_entity))
980 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
982 /* If this is a renaming, avoid as much as possible to create a new
983 object. However, in some cases, creating it is required because
984 renaming can be applied to objects that are not names in Ada.
985 This processing needs to be applied to the raw expression so as
986 to make it more likely to rename the underlying object. */
987 if (Present (Renamed_Object (gnat_entity)))
989 /* If the renamed object had padding, strip off the reference to
990 the inner object and reset our type. */
991 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
992 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
993 /* Strip useless conversions around the object. */
994 || gnat_useless_type_conversion (gnu_expr))
996 gnu_expr = TREE_OPERAND (gnu_expr, 0);
997 gnu_type = TREE_TYPE (gnu_expr);
1000 /* Or else, if the renamed object has an unconstrained type with
1001 default discriminant, use the padded type. */
1002 else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
1003 gnu_type = TREE_TYPE (gnu_expr);
1005 /* Case 1: if this is a constant renaming stemming from a function
1006 call, treat it as a normal object whose initial value is what
1007 is being renamed. RM 3.3 says that the result of evaluating a
1008 function call is a constant object. Therefore, it can be the
1009 inner object of a constant renaming and the renaming must be
1010 fully instantiated, i.e. it cannot be a reference to (part of)
1011 an existing object. And treat other rvalues (addresses, null
1012 expressions, constructors and literals) the same way. */
1013 tree inner = gnu_expr;
1014 while (handled_component_p (inner) || CONVERT_EXPR_P (inner))
1015 inner = TREE_OPERAND (inner, 0);
1016 /* Expand_Dispatching_Call can prepend a comparison of the tags
1017 before the call to "=". */
1018 if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
1019 || TREE_CODE (inner) == COMPOUND_EXPR)
1020 inner = TREE_OPERAND (inner, 1);
1021 if ((TREE_CODE (inner) == CALL_EXPR
1022 && !call_is_atomic_load (inner))
1023 || TREE_CODE (inner) == ADDR_EXPR
1024 || TREE_CODE (inner) == NULL_EXPR
1025 || TREE_CODE (inner) == PLUS_EXPR
1026 || TREE_CODE (inner) == CONSTRUCTOR
1027 || CONSTANT_CLASS_P (inner)
1028 /* We need to detect the case where a temporary is created to
1029 hold the return value, since we cannot safely rename it at
1030 top level as it lives only in the elaboration routine. */
1031 || (TREE_CODE (inner) == VAR_DECL
1032 && DECL_RETURN_VALUE_P (inner))
1033 /* We also need to detect the case where the front-end creates
1034 a dangling 'reference to a function call at top level and
1035 substitutes it in the renaming, for example:
1037 q__b : boolean renames r__f.e (1);
1039 can be rewritten into:
1041 q__R1s : constant q__A2s := r__f'reference;
1042 [...]
1043 q__b : boolean renames q__R1s.all.e (1);
1045 We cannot safely rename the rewritten expression since the
1046 underlying object lives only in the elaboration routine. */
1047 || (TREE_CODE (inner) == INDIRECT_REF
1048 && (inner
1049 = remove_conversions (TREE_OPERAND (inner, 0), true))
1050 && TREE_CODE (inner) == VAR_DECL
1051 && DECL_RETURN_VALUE_P (inner)))
1054 /* Case 2: if the renaming entity need not be materialized, use
1055 the elaborated renamed expression for the renaming. But this
1056 means that the caller is responsible for evaluating the address
1057 of the renaming in the correct place for the definition case to
1058 instantiate the SAVE_EXPRs. */
1059 else if (!Materialize_Entity (gnat_entity))
1061 tree init = NULL_TREE;
1063 gnu_decl
1064 = elaborate_reference (gnu_expr, gnat_entity, definition,
1065 &init);
1067 /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
1068 correct place for this case. */
1069 gcc_assert (!init);
1071 /* No DECL_EXPR will be created so the expression needs to be
1072 marked manually because it will likely be shared. */
1073 if (global_bindings_p ())
1074 MARK_VISITED (gnu_decl);
1076 /* This assertion will fail if the renamed object isn't aligned
1077 enough as to make it possible to honor the alignment set on
1078 the renaming. */
1079 if (align)
1081 unsigned int ralign = DECL_P (gnu_decl)
1082 ? DECL_ALIGN (gnu_decl)
1083 : TYPE_ALIGN (TREE_TYPE (gnu_decl));
1084 gcc_assert (ralign >= align);
1087 /* The expression might not be a DECL so save it manually. */
1088 save_gnu_tree (gnat_entity, gnu_decl, true);
1089 saved = true;
1090 annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
1091 break;
1094 /* Case 3: otherwise, make a constant pointer to the object we
1095 are renaming and attach the object to the pointer after it is
1096 elaborated. The object will be referenced directly instead
1097 of indirectly via the pointer to avoid aliasing problems with
1098 non-addressable entities. The pointer is called a "renaming"
1099 pointer in this case. Note that we also need to preserve the
1100 volatility of the renamed object through the indirection. */
1101 else
1103 tree init = NULL_TREE;
1105 if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
1106 gnu_type
1107 = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1108 gnu_type = build_reference_type (gnu_type);
1109 used_by_ref = true;
1110 const_flag = true;
1111 volatile_flag = false;
1112 inner_const_flag = TREE_READONLY (gnu_expr);
1113 gnu_size = NULL_TREE;
1115 renamed_obj
1116 = elaborate_reference (gnu_expr, gnat_entity, definition,
1117 &init);
1119 /* The expression needs to be marked manually because it will
1120 likely be shared, even for a definition since the ADDR_EXPR
1121 built below can cause the first few nodes to be folded. */
1122 if (global_bindings_p ())
1123 MARK_VISITED (renamed_obj);
1125 if (type_annotate_only
1126 && TREE_CODE (renamed_obj) == ERROR_MARK)
1127 gnu_expr = NULL_TREE;
1128 else
1130 gnu_expr
1131 = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
1132 if (init)
1133 gnu_expr
1134 = build_compound_expr (TREE_TYPE (gnu_expr), init,
1135 gnu_expr);
1140 /* If we are defining an aliased object whose nominal subtype is
1141 unconstrained, the object is a record that contains both the
1142 template and the object. If there is an initializer, it will
1143 have already been converted to the right type, but we need to
1144 create the template if there is no initializer. */
1145 if (definition
1146 && !gnu_expr
1147 && TREE_CODE (gnu_type) == RECORD_TYPE
1148 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1149 /* Beware that padding might have been introduced above. */
1150 || (TYPE_PADDING_P (gnu_type)
1151 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1152 == RECORD_TYPE
1153 && TYPE_CONTAINS_TEMPLATE_P
1154 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1156 tree template_field
1157 = TYPE_PADDING_P (gnu_type)
1158 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1159 : TYPE_FIELDS (gnu_type);
1160 vec<constructor_elt, va_gc> *v;
1161 vec_alloc (v, 1);
1162 tree t = build_template (TREE_TYPE (template_field),
1163 TREE_TYPE (DECL_CHAIN (template_field)),
1164 NULL_TREE);
1165 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1166 gnu_expr = gnat_build_constructor (gnu_type, v);
1169 /* Convert the expression to the type of the object if need be. */
1170 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1171 gnu_expr = convert (gnu_type, gnu_expr);
1173 /* If this is a pointer that doesn't have an initializing expression,
1174 initialize it to NULL, unless the object is declared imported as
1175 per RM B.1(24). */
1176 if (definition
1177 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1178 && !gnu_expr
1179 && !Is_Imported (gnat_entity))
1180 gnu_expr = integer_zero_node;
1182 /* If we are defining the object and it has an Address clause, we must
1183 either get the address expression from the saved GCC tree for the
1184 object if it has a Freeze node, or elaborate the address expression
1185 here since the front-end has guaranteed that the elaboration has no
1186 effects in this case. */
1187 if (definition && Present (Address_Clause (gnat_entity)))
1189 const Node_Id gnat_clause = Address_Clause (gnat_entity);
1190 Node_Id gnat_address = Expression (gnat_clause);
1191 tree gnu_address
1192 = present_gnu_tree (gnat_entity)
1193 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_address);
1195 save_gnu_tree (gnat_entity, NULL_TREE, false);
1197 /* Convert the type of the object to a reference type that can
1198 alias everything as per RM 13.3(19). */
1199 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1200 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1201 gnu_type
1202 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1203 gnu_address = convert (gnu_type, gnu_address);
1204 used_by_ref = true;
1205 const_flag
1206 = (!Is_Public (gnat_entity)
1207 || compile_time_known_address_p (gnat_address));
1208 volatile_flag = false;
1209 gnu_size = NULL_TREE;
1211 /* If this is an aliased object with an unconstrained array nominal
1212 subtype, then it can overlay only another aliased object with an
1213 unconstrained array nominal subtype and compatible template. */
1214 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
1215 && Is_Array_Type (Underlying_Type (gnat_type))
1216 && !type_annotate_only)
1218 tree rec_type = TREE_TYPE (gnu_type);
1219 tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
1221 /* This is the pattern built for a regular object. */
1222 if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1223 && TREE_OPERAND (gnu_address, 1) == off)
1224 gnu_address = TREE_OPERAND (gnu_address, 0);
1225 /* This is the pattern built for an overaligned object. */
1226 else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1227 && TREE_CODE (TREE_OPERAND (gnu_address, 1))
1228 == PLUS_EXPR
1229 && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
1230 == off)
1231 gnu_address
1232 = build2 (POINTER_PLUS_EXPR, gnu_type,
1233 TREE_OPERAND (gnu_address, 0),
1234 TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
1235 else
1237 post_error_ne ("aliased object& with unconstrained array "
1238 "nominal subtype", gnat_clause,
1239 gnat_entity);
1240 post_error ("\\can overlay only aliased object with "
1241 "compatible subtype", gnat_clause);
1245 /* If we don't have an initializing expression for the underlying
1246 variable, the initializing expression for the pointer is the
1247 specified address. Otherwise, we have to make a COMPOUND_EXPR
1248 to assign both the address and the initial value. */
1249 if (!gnu_expr)
1250 gnu_expr = gnu_address;
1251 else
1252 gnu_expr
1253 = build2 (COMPOUND_EXPR, gnu_type,
1254 build_binary_op (INIT_EXPR, NULL_TREE,
1255 build_unary_op (INDIRECT_REF,
1256 NULL_TREE,
1257 gnu_address),
1258 gnu_expr),
1259 gnu_address);
1262 /* If it has an address clause and we are not defining it, mark it
1263 as an indirect object. Likewise for Stdcall objects that are
1264 imported. */
1265 if ((!definition && Present (Address_Clause (gnat_entity)))
1266 || (imported_p && Has_Stdcall_Convention (gnat_entity)))
1268 /* Convert the type of the object to a reference type that can
1269 alias everything as per RM 13.3(19). */
1270 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1271 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1272 gnu_type
1273 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1274 used_by_ref = true;
1275 const_flag = false;
1276 volatile_flag = false;
1277 gnu_size = NULL_TREE;
1279 /* No point in taking the address of an initializing expression
1280 that isn't going to be used. */
1281 gnu_expr = NULL_TREE;
1283 /* If it has an address clause whose value is known at compile
1284 time, make the object a CONST_DECL. This will avoid a
1285 useless dereference. */
1286 if (Present (Address_Clause (gnat_entity)))
1288 Node_Id gnat_address
1289 = Expression (Address_Clause (gnat_entity));
1291 if (compile_time_known_address_p (gnat_address))
1293 gnu_expr = gnat_to_gnu (gnat_address);
1294 const_flag = true;
1299 /* If we are at top level and this object is of variable size,
1300 make the actual type a hidden pointer to the real type and
1301 make the initializer be a memory allocation and initialization.
1302 Likewise for objects we aren't defining (presumed to be
1303 external references from other packages), but there we do
1304 not set up an initialization.
1306 If the object's size overflows, make an allocator too, so that
1307 Storage_Error gets raised. Note that we will never free
1308 such memory, so we presume it never will get allocated. */
1309 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1310 global_bindings_p ()
1311 || !definition
1312 || static_flag)
1313 || (gnu_size
1314 && !allocatable_size_p (convert (sizetype,
1315 size_binop
1316 (CEIL_DIV_EXPR, gnu_size,
1317 bitsize_unit_node)),
1318 global_bindings_p ()
1319 || !definition
1320 || static_flag)))
1322 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1323 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1324 gnu_type = build_reference_type (gnu_type);
1325 used_by_ref = true;
1326 const_flag = true;
1327 volatile_flag = false;
1328 gnu_size = NULL_TREE;
1330 /* In case this was a aliased object whose nominal subtype is
1331 unconstrained, the pointer above will be a thin pointer and
1332 build_allocator will automatically make the template.
1334 If we have a template initializer only (that we made above),
1335 pretend there is none and rely on what build_allocator creates
1336 again anyway. Otherwise (if we have a full initializer), get
1337 the data part and feed that to build_allocator.
1339 If we are elaborating a mutable object, tell build_allocator to
1340 ignore a possibly simpler size from the initializer, if any, as
1341 we must allocate the maximum possible size in this case. */
1342 if (definition && !imported_p)
1344 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1346 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1347 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1349 gnu_alloc_type
1350 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1352 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1353 && CONSTRUCTOR_NELTS (gnu_expr) == 1)
1354 gnu_expr = NULL_TREE;
1355 else
1356 gnu_expr
1357 = build_component_ref
1358 (gnu_expr,
1359 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1360 false);
1363 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1364 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
1365 post_error ("?`Storage_Error` will be raised at run time!",
1366 gnat_entity);
1368 gnu_expr
1369 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1370 Empty, Empty, gnat_entity, mutable_p);
1372 else
1373 gnu_expr = NULL_TREE;
1376 /* If this object would go into the stack and has an alignment larger
1377 than the largest stack alignment the back-end can honor, resort to
1378 a variable of "aligning type". */
1379 if (definition
1380 && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT
1381 && !imported_p
1382 && !static_flag
1383 && !global_bindings_p ())
1385 /* Create the new variable. No need for extra room before the
1386 aligned field as this is in automatic storage. */
1387 tree gnu_new_type
1388 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1389 TYPE_SIZE_UNIT (gnu_type),
1390 BIGGEST_ALIGNMENT, 0, gnat_entity);
1391 tree gnu_new_var
1392 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1393 NULL_TREE, gnu_new_type, NULL_TREE,
1394 false, false, false, false, false,
1395 true, debug_info_p && definition, NULL,
1396 gnat_entity);
1398 /* Initialize the aligned field if we have an initializer. */
1399 if (gnu_expr)
1400 add_stmt_with_node
1401 (build_binary_op (INIT_EXPR, NULL_TREE,
1402 build_component_ref
1403 (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1404 false),
1405 gnu_expr),
1406 gnat_entity);
1408 /* And setup this entity as a reference to the aligned field. */
1409 gnu_type = build_reference_type (gnu_type);
1410 gnu_expr
1411 = build_unary_op
1412 (ADDR_EXPR, NULL_TREE,
1413 build_component_ref (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1414 false));
1415 TREE_CONSTANT (gnu_expr) = 1;
1417 used_by_ref = true;
1418 const_flag = true;
1419 volatile_flag = false;
1420 gnu_size = NULL_TREE;
1423 /* If this is an aliased object with an unconstrained array nominal
1424 subtype, we make its type a thin reference, i.e. the reference
1425 counterpart of a thin pointer, so it points to the array part.
1426 This is aimed to make it easier for the debugger to decode the
1427 object. Note that we have to do it this late because of the
1428 couple of allocation adjustments that might be made above. */
1429 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
1430 && Is_Array_Type (Underlying_Type (gnat_type))
1431 && !type_annotate_only)
1433 /* In case the object with the template has already been allocated
1434 just above, we have nothing to do here. */
1435 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1437 /* This variable is a GNAT encoding used by Workbench: let it
1438 go through the debugging information but mark it as
1439 artificial: users are not interested in it. */
1440 tree gnu_unc_var
1441 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1442 NULL_TREE, gnu_type, gnu_expr,
1443 const_flag, Is_Public (gnat_entity),
1444 imported_p || !definition, static_flag,
1445 volatile_flag, true,
1446 debug_info_p && definition,
1447 NULL, gnat_entity);
1448 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1449 TREE_CONSTANT (gnu_expr) = 1;
1451 used_by_ref = true;
1452 const_flag = true;
1453 volatile_flag = false;
1454 inner_const_flag = TREE_READONLY (gnu_unc_var);
1455 gnu_size = NULL_TREE;
1458 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
1459 gnu_type
1460 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1463 /* Convert the expression to the type of the object if need be. */
1464 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1465 gnu_expr = convert (gnu_type, gnu_expr);
1467 /* If this name is external or a name was specified, use it, but don't
1468 use the Interface_Name with an address clause (see cd30005). */
1469 if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity))
1470 || (Present (Interface_Name (gnat_entity))
1471 && No (Address_Clause (gnat_entity))))
1472 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1474 /* If this is an aggregate constant initialized to a constant, force it
1475 to be statically allocated. This saves an initialization copy. */
1476 if (!static_flag
1477 && const_flag
1478 && gnu_expr && TREE_CONSTANT (gnu_expr)
1479 && AGGREGATE_TYPE_P (gnu_type)
1480 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
1481 && !(TYPE_IS_PADDING_P (gnu_type)
1482 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1483 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1484 static_flag = true;
1486 /* Deal with a pragma Linker_Section on a constant or variable. */
1487 if ((kind == E_Constant || kind == E_Variable)
1488 && Present (Linker_Section_Pragma (gnat_entity)))
1489 prepend_one_attribute_pragma (&attr_list,
1490 Linker_Section_Pragma (gnat_entity));
1492 /* Now create the variable or the constant and set various flags. */
1493 gnu_decl
1494 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1495 gnu_expr, const_flag, Is_Public (gnat_entity),
1496 imported_p || !definition, static_flag,
1497 volatile_flag, artificial_p,
1498 debug_info_p && definition, attr_list,
1499 gnat_entity, !renamed_obj);
1500 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1501 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1502 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1504 /* If we are defining an Out parameter and optimization isn't enabled,
1505 create a fake PARM_DECL for debugging purposes and make it point to
1506 the VAR_DECL. Suppress debug info for the latter but make sure it
1507 will live in memory so that it can be accessed from within the
1508 debugger through the PARM_DECL. */
1509 if (kind == E_Out_Parameter
1510 && definition
1511 && debug_info_p
1512 && !optimize
1513 && !flag_generate_lto)
1515 tree param = create_param_decl (gnu_entity_name, gnu_type);
1516 gnat_pushdecl (param, gnat_entity);
1517 SET_DECL_VALUE_EXPR (param, gnu_decl);
1518 DECL_HAS_VALUE_EXPR_P (param) = 1;
1519 DECL_IGNORED_P (gnu_decl) = 1;
1520 TREE_ADDRESSABLE (gnu_decl) = 1;
1523 /* If this is a loop parameter, set the corresponding flag. */
1524 else if (kind == E_Loop_Parameter)
1525 DECL_LOOP_PARM_P (gnu_decl) = 1;
1527 /* If this is a renaming pointer, attach the renamed object to it. */
1528 if (renamed_obj)
1529 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1531 /* If this is a constant and we are defining it or it generates a real
1532 symbol at the object level and we are referencing it, we may want
1533 or need to have a true variable to represent it:
1534 - if optimization isn't enabled, for debugging purposes,
1535 - if the constant is public and not overlaid on something else,
1536 - if its address is taken,
1537 - if either itself or its type is aliased. */
1538 if (TREE_CODE (gnu_decl) == CONST_DECL
1539 && (definition || Sloc (gnat_entity) > Standard_Location)
1540 && ((!optimize && debug_info_p)
1541 || (Is_Public (gnat_entity)
1542 && No (Address_Clause (gnat_entity)))
1543 || Address_Taken (gnat_entity)
1544 || Is_Aliased (gnat_entity)
1545 || Is_Aliased (gnat_type)))
1547 tree gnu_corr_var
1548 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1549 gnu_expr, true, Is_Public (gnat_entity),
1550 !definition, static_flag, volatile_flag,
1551 artificial_p, debug_info_p && definition,
1552 attr_list, gnat_entity, false);
1554 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1557 /* If this is a constant, even if we don't need a true variable, we
1558 may need to avoid returning the initializer in every case. That
1559 can happen for the address of a (constant) constructor because,
1560 upon dereferencing it, the constructor will be reinjected in the
1561 tree, which may not be valid in every case; see lvalue_required_p
1562 for more details. */
1563 if (TREE_CODE (gnu_decl) == CONST_DECL)
1564 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1566 /* If this object is declared in a block that contains a block with an
1567 exception handler, and we aren't using the GCC exception mechanism,
1568 we must force this variable in memory in order to avoid an invalid
1569 optimization. */
1570 if (Front_End_Exceptions ()
1571 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1572 TREE_ADDRESSABLE (gnu_decl) = 1;
1574 /* If this is a local variable with non-BLKmode and aggregate type,
1575 and optimization isn't enabled, then force it in memory so that
1576 a register won't be allocated to it with possible subparts left
1577 uninitialized and reaching the register allocator. */
1578 else if (TREE_CODE (gnu_decl) == VAR_DECL
1579 && !DECL_EXTERNAL (gnu_decl)
1580 && !TREE_STATIC (gnu_decl)
1581 && DECL_MODE (gnu_decl) != BLKmode
1582 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl))
1583 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl))
1584 && !optimize)
1585 TREE_ADDRESSABLE (gnu_decl) = 1;
1587 /* If we are defining an object with variable size or an object with
1588 fixed size that will be dynamically allocated, and we are using the
1589 front-end setjmp/longjmp exception mechanism, update the setjmp
1590 buffer. */
1591 if (definition
1592 && Exception_Mechanism == Front_End_SJLJ
1593 && get_block_jmpbuf_decl ()
1594 && DECL_SIZE_UNIT (gnu_decl)
1595 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1596 || (flag_stack_check == GENERIC_STACK_CHECK
1597 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1598 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1599 add_stmt_with_node (build_call_n_expr
1600 (update_setjmp_buf_decl, 1,
1601 build_unary_op (ADDR_EXPR, NULL_TREE,
1602 get_block_jmpbuf_decl ())),
1603 gnat_entity);
1605 /* Back-annotate Esize and Alignment of the object if not already
1606 known. Note that we pick the values of the type, not those of
1607 the object, to shield ourselves from low-level platform-dependent
1608 adjustments like alignment promotion. This is both consistent with
1609 all the treatment above, where alignment and size are set on the
1610 type of the object and not on the object directly, and makes it
1611 possible to support all confirming representation clauses. */
1612 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1613 used_by_ref);
1615 break;
1617 case E_Void:
1618 /* Return a TYPE_DECL for "void" that we previously made. */
1619 gnu_decl = TYPE_NAME (void_type_node);
1620 break;
1622 case E_Enumeration_Type:
1623 /* A special case: for the types Character and Wide_Character in
1624 Standard, we do not list all the literals. So if the literals
1625 are not specified, make this an integer type. */
1626 if (No (First_Literal (gnat_entity)))
1628 if (esize == CHAR_TYPE_SIZE && flag_signed_char)
1629 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1630 else
1631 gnu_type = make_unsigned_type (esize);
1632 TYPE_NAME (gnu_type) = gnu_entity_name;
1634 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1635 This is needed by the DWARF-2 back-end to distinguish between
1636 unsigned integer types and character types. */
1637 TYPE_STRING_FLAG (gnu_type) = 1;
1639 /* This flag is needed by the call just below. */
1640 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1642 finish_character_type (gnu_type);
1644 else
1646 /* We have a list of enumeral constants in First_Literal. We make a
1647 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1648 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1649 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1650 value of the literal. But when we have a regular boolean type, we
1651 simplify this a little by using a BOOLEAN_TYPE. */
1652 const bool is_boolean = Is_Boolean_Type (gnat_entity)
1653 && !Has_Non_Standard_Rep (gnat_entity);
1654 const bool is_unsigned = Is_Unsigned_Type (gnat_entity);
1655 tree gnu_list = NULL_TREE;
1656 Entity_Id gnat_literal;
1658 gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1659 TYPE_PRECISION (gnu_type) = esize;
1660 TYPE_UNSIGNED (gnu_type) = is_unsigned;
1661 set_min_and_max_values_for_integral_type (gnu_type, esize,
1662 TYPE_SIGN (gnu_type));
1663 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
1664 layout_type (gnu_type);
1666 for (gnat_literal = First_Literal (gnat_entity);
1667 Present (gnat_literal);
1668 gnat_literal = Next_Literal (gnat_literal))
1670 tree gnu_value
1671 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1672 /* Do not generate debug info for individual enumerators. */
1673 tree gnu_literal
1674 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1675 gnu_type, gnu_value, true, false, false,
1676 false, false, artificial_p, false,
1677 NULL, gnat_literal);
1678 save_gnu_tree (gnat_literal, gnu_literal, false);
1679 gnu_list
1680 = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list);
1683 if (!is_boolean)
1684 TYPE_VALUES (gnu_type) = nreverse (gnu_list);
1686 /* Note that the bounds are updated at the end of this function
1687 to avoid an infinite recursion since they refer to the type. */
1688 goto discrete_type;
1690 break;
1692 case E_Signed_Integer_Type:
1693 /* For integer types, just make a signed type the appropriate number
1694 of bits. */
1695 gnu_type = make_signed_type (esize);
1696 goto discrete_type;
1698 case E_Ordinary_Fixed_Point_Type:
1699 case E_Decimal_Fixed_Point_Type:
1701 /* Small_Value is the scale factor. */
1702 const Ureal gnat_small_value = Small_Value (gnat_entity);
1703 tree scale_factor = NULL_TREE;
1705 gnu_type = make_signed_type (esize);
1707 /* Try to decode the scale factor and to save it for the fixed-point
1708 types debug hook. */
1710 /* There are various ways to describe the scale factor, however there
1711 are cases where back-end internals cannot hold it. In such cases,
1712 we output invalid scale factor for such cases (i.e. the 0/0
1713 rational constant) but we expect GNAT to output GNAT encodings,
1714 then. Thus, keep this in sync with
1715 Exp_Dbug.Is_Handled_Scale_Factor. */
1717 /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
1718 binary or decimal scale: it is easier to read for humans. */
1719 if (UI_Eq (Numerator (gnat_small_value), Uint_1)
1720 && (Rbase (gnat_small_value) == 2
1721 || Rbase (gnat_small_value) == 10))
1723 /* Given RM restrictions on 'Small values, we assume here that
1724 the denominator fits in an int. */
1725 const tree base = build_int_cst (integer_type_node,
1726 Rbase (gnat_small_value));
1727 const tree exponent
1728 = build_int_cst (integer_type_node,
1729 UI_To_Int (Denominator (gnat_small_value)));
1730 scale_factor
1731 = build2 (RDIV_EXPR, integer_type_node,
1732 integer_one_node,
1733 build2 (POWER_EXPR, integer_type_node,
1734 base, exponent));
1737 /* Default to arbitrary scale factors descriptions. */
1738 else
1740 const Uint num = Norm_Num (gnat_small_value);
1741 const Uint den = Norm_Den (gnat_small_value);
1743 if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
1745 const tree gnu_num
1746 = build_int_cst (integer_type_node,
1747 UI_To_Int (Norm_Num (gnat_small_value)));
1748 const tree gnu_den
1749 = build_int_cst (integer_type_node,
1750 UI_To_Int (Norm_Den (gnat_small_value)));
1751 scale_factor = build2 (RDIV_EXPR, integer_type_node,
1752 gnu_num, gnu_den);
1754 else
1755 /* If compiler internals cannot represent arbitrary scale
1756 factors, output an invalid scale factor so that debugger
1757 don't try to handle them but so that we still have a type
1758 in the output. Note that GNAT */
1759 scale_factor = integer_zero_node;
1762 TYPE_FIXED_POINT_P (gnu_type) = 1;
1763 SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor);
1765 goto discrete_type;
1767 case E_Modular_Integer_Type:
1769 /* For modular types, make the unsigned type of the proper number
1770 of bits and then set up the modulus, if required. */
1771 tree gnu_modulus, gnu_high = NULL_TREE;
1773 /* Packed Array Impl. Types are supposed to be subtypes only. */
1774 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity));
1776 gnu_type = make_unsigned_type (esize);
1778 /* Get the modulus in this type. If it overflows, assume it is because
1779 it is equal to 2**Esize. Note that there is no overflow checking
1780 done on unsigned type, so we detect the overflow by looking for
1781 a modulus of zero, which is otherwise invalid. */
1782 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1784 if (!integer_zerop (gnu_modulus))
1786 TYPE_MODULAR_P (gnu_type) = 1;
1787 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1788 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1789 build_int_cst (gnu_type, 1));
1792 /* If the upper bound is not maximal, make an extra subtype. */
1793 if (gnu_high
1794 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1796 tree gnu_subtype = make_unsigned_type (esize);
1797 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1798 TREE_TYPE (gnu_subtype) = gnu_type;
1799 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1800 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1801 gnu_type = gnu_subtype;
1804 goto discrete_type;
1806 case E_Signed_Integer_Subtype:
1807 case E_Enumeration_Subtype:
1808 case E_Modular_Integer_Subtype:
1809 case E_Ordinary_Fixed_Point_Subtype:
1810 case E_Decimal_Fixed_Point_Subtype:
1812 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1813 not want to call create_range_type since we would like each subtype
1814 node to be distinct. ??? Historically this was in preparation for
1815 when memory aliasing is implemented, but that's obsolete now given
1816 the call to relate_alias_sets below.
1818 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1819 this fact is used by the arithmetic conversion functions.
1821 We elaborate the Ancestor_Subtype if it is not in the current unit
1822 and one of our bounds is non-static. We do this to ensure consistent
1823 naming in the case where several subtypes share the same bounds, by
1824 elaborating the first such subtype first, thus using its name. */
1826 if (!definition
1827 && Present (Ancestor_Subtype (gnat_entity))
1828 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1829 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1830 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1831 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
1833 /* Set the precision to the Esize except for bit-packed arrays. */
1834 if (Is_Packed_Array_Impl_Type (gnat_entity)
1835 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1836 esize = UI_To_Int (RM_Size (gnat_entity));
1838 /* First subtypes of Character are treated as Character; otherwise
1839 this should be an unsigned type if the base type is unsigned or
1840 if the lower bound is constant and non-negative or if the type
1841 is biased. However, even if the lower bound is constant and
1842 non-negative, we use a signed type for a subtype with the same
1843 size as its signed base type, because this eliminates useless
1844 conversions to it and gives more leeway to the optimizer; but
1845 this means that we will need to explicitly test for this case
1846 when we change the representation based on the RM size. */
1847 if (kind == E_Enumeration_Subtype
1848 && No (First_Literal (Etype (gnat_entity)))
1849 && Esize (gnat_entity) == RM_Size (gnat_entity)
1850 && esize == CHAR_TYPE_SIZE
1851 && flag_signed_char)
1852 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1853 else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity)))
1854 || (Esize (Etype (gnat_entity)) != Esize (gnat_entity)
1855 && Is_Unsigned_Type (gnat_entity))
1856 || Has_Biased_Representation (gnat_entity))
1857 gnu_type = make_unsigned_type (esize);
1858 else
1859 gnu_type = make_signed_type (esize);
1860 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1862 SET_TYPE_RM_MIN_VALUE
1863 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
1864 gnat_entity, "L", definition, true,
1865 debug_info_p));
1867 SET_TYPE_RM_MAX_VALUE
1868 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
1869 gnat_entity, "U", definition, true,
1870 debug_info_p));
1872 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1873 = Has_Biased_Representation (gnat_entity);
1875 /* Do the same processing for Character subtypes as for types. */
1876 if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
1878 TYPE_NAME (gnu_type) = gnu_entity_name;
1879 TYPE_STRING_FLAG (gnu_type) = 1;
1880 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1881 finish_character_type (gnu_type);
1884 /* Inherit our alias set from what we're a subtype of. Subtypes
1885 are not different types and a pointer can designate any instance
1886 within a subtype hierarchy. */
1887 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1889 /* One of the above calls might have caused us to be elaborated,
1890 so don't blow up if so. */
1891 if (present_gnu_tree (gnat_entity))
1893 maybe_present = true;
1894 break;
1897 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1898 TYPE_STUB_DECL (gnu_type)
1899 = create_type_stub_decl (gnu_entity_name, gnu_type);
1901 /* For a packed array, make the original array type a parallel/debug
1902 type. */
1903 if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
1904 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1906 discrete_type:
1908 /* We have to handle clauses that under-align the type specially. */
1909 if ((Present (Alignment_Clause (gnat_entity))
1910 || (Is_Packed_Array_Impl_Type (gnat_entity)
1911 && Present
1912 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1913 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1915 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1916 if (align >= TYPE_ALIGN (gnu_type))
1917 align = 0;
1920 /* If the type we are dealing with represents a bit-packed array,
1921 we need to have the bits left justified on big-endian targets
1922 and right justified on little-endian targets. We also need to
1923 ensure that when the value is read (e.g. for comparison of two
1924 such values), we only get the good bits, since the unused bits
1925 are uninitialized. Both goals are accomplished by wrapping up
1926 the modular type in an enclosing record type. */
1927 if (Is_Packed_Array_Impl_Type (gnat_entity)
1928 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1930 tree gnu_field_type, gnu_field;
1932 /* Set the RM size before wrapping up the original type. */
1933 SET_TYPE_RM_SIZE (gnu_type,
1934 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1935 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1937 /* Strip the ___XP suffix for standard DWARF. */
1938 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1939 gnu_entity_name = TYPE_NAME (gnu_type);
1941 /* Create a stripped-down declaration, mainly for debugging. */
1942 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1943 gnat_entity);
1945 /* Now save it and build the enclosing record type. */
1946 gnu_field_type = gnu_type;
1948 gnu_type = make_node (RECORD_TYPE);
1949 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1950 TYPE_PACKED (gnu_type) = 1;
1951 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1952 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1953 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1955 /* Propagate the alignment of the modular type to the record type,
1956 unless there is an alignment clause that under-aligns the type.
1957 This means that bit-packed arrays are given "ceil" alignment for
1958 their size by default, which may seem counter-intuitive but makes
1959 it possible to overlay them on modular types easily. */
1960 SET_TYPE_ALIGN (gnu_type,
1961 align > 0 ? align : TYPE_ALIGN (gnu_field_type));
1963 /* Propagate the reverse storage order flag to the record type so
1964 that the required byte swapping is performed when retrieving the
1965 enclosed modular value. */
1966 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
1967 = Reverse_Storage_Order (Original_Array_Type (gnat_entity));
1969 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1971 /* Don't declare the field as addressable since we won't be taking
1972 its address and this would prevent create_field_decl from making
1973 a bitfield. */
1974 gnu_field
1975 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1976 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1978 /* We will output additional debug info manually below. */
1979 finish_record_type (gnu_type, gnu_field, 2, false);
1980 compute_record_mode (gnu_type);
1981 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1983 if (debug_info_p)
1985 /* Make the original array type a parallel/debug type. */
1986 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1988 /* Since GNU_TYPE is a padding type around the packed array
1989 implementation type, the padded type is its debug type. */
1990 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1991 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
1995 /* If the type we are dealing with has got a smaller alignment than the
1996 natural one, we need to wrap it up in a record type and misalign the
1997 latter; we reuse the padding machinery for this purpose. */
1998 else if (align > 0)
2000 tree gnu_size = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
2002 /* Set the RM size before wrapping the type. */
2003 SET_TYPE_RM_SIZE (gnu_type, gnu_size);
2005 gnu_type
2006 = maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
2007 gnat_entity, false, true, definition, false);
2009 TYPE_PACKED (gnu_type) = 1;
2010 SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
2013 break;
2015 case E_Floating_Point_Type:
2016 /* The type of the Low and High bounds can be our type if this is
2017 a type from Standard, so set them at the end of the function. */
2018 gnu_type = make_node (REAL_TYPE);
2019 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
2020 layout_type (gnu_type);
2021 break;
2023 case E_Floating_Point_Subtype:
2024 /* See the E_Signed_Integer_Subtype case for the rationale. */
2025 if (!definition
2026 && Present (Ancestor_Subtype (gnat_entity))
2027 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
2028 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
2029 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
2030 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
2032 gnu_type = make_node (REAL_TYPE);
2033 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
2034 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
2035 TYPE_GCC_MIN_VALUE (gnu_type)
2036 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
2037 TYPE_GCC_MAX_VALUE (gnu_type)
2038 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
2039 layout_type (gnu_type);
2041 SET_TYPE_RM_MIN_VALUE
2042 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
2043 gnat_entity, "L", definition, true,
2044 debug_info_p));
2046 SET_TYPE_RM_MAX_VALUE
2047 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
2048 gnat_entity, "U", definition, true,
2049 debug_info_p));
2051 /* Inherit our alias set from what we're a subtype of, as for
2052 integer subtypes. */
2053 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
2055 /* One of the above calls might have caused us to be elaborated,
2056 so don't blow up if so. */
2057 maybe_present = true;
2058 break;
2060 /* Array Types and Subtypes
2062 Unconstrained array types are represented by E_Array_Type and
2063 constrained array types are represented by E_Array_Subtype. There
2064 are no actual objects of an unconstrained array type; all we have
2065 are pointers to that type.
2067 The following fields are defined on array types and subtypes:
2069 Component_Type Component type of the array.
2070 Number_Dimensions Number of dimensions (an int).
2071 First_Index Type of first index. */
2073 case E_Array_Type:
2075 const bool convention_fortran_p
2076 = (Convention (gnat_entity) == Convention_Fortran);
2077 const int ndim = Number_Dimensions (gnat_entity);
2078 tree gnu_template_type;
2079 tree gnu_ptr_template;
2080 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
2081 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2082 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2083 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
2084 Entity_Id gnat_index, gnat_name;
2085 int index;
2086 tree comp_type;
2088 /* Create the type for the component now, as it simplifies breaking
2089 type reference loops. */
2090 comp_type
2091 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2092 if (present_gnu_tree (gnat_entity))
2094 /* As a side effect, the type may have been translated. */
2095 maybe_present = true;
2096 break;
2099 /* We complete an existing dummy fat pointer type in place. This both
2100 avoids further complex adjustments in update_pointer_to and yields
2101 better debugging information in DWARF by leveraging the support for
2102 incomplete declarations of "tagged" types in the DWARF back-end. */
2103 gnu_type = get_dummy_type (gnat_entity);
2104 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2106 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2107 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2108 /* Save the contents of the dummy type for update_pointer_to. */
2109 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2110 gnu_ptr_template =
2111 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2112 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2114 else
2116 gnu_fat_type = make_node (RECORD_TYPE);
2117 gnu_template_type = make_node (RECORD_TYPE);
2118 gnu_ptr_template = build_pointer_type (gnu_template_type);
2121 /* Make a node for the array. If we are not defining the array
2122 suppress expanding incomplete types. */
2123 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2125 if (!definition)
2127 defer_incomplete_level++;
2128 this_deferred = true;
2131 /* Build the fat pointer type. Use a "void *" object instead of
2132 a pointer to the array type since we don't have the array type
2133 yet (it will reference the fat pointer via the bounds). */
2135 = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node,
2136 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2137 DECL_CHAIN (tem)
2138 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
2139 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
2141 if (COMPLETE_TYPE_P (gnu_fat_type))
2143 /* We are going to lay it out again so reset the alias set. */
2144 alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
2145 TYPE_ALIAS_SET (gnu_fat_type) = -1;
2146 finish_fat_pointer_type (gnu_fat_type, tem);
2147 TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
2148 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2150 TYPE_FIELDS (t) = tem;
2151 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2154 else
2156 finish_fat_pointer_type (gnu_fat_type, tem);
2157 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2160 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2161 is the fat pointer. This will be used to access the individual
2162 fields once we build them. */
2163 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2164 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2165 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
2166 gnu_template_reference
2167 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2168 TREE_READONLY (gnu_template_reference) = 1;
2169 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2171 /* Now create the GCC type for each index and add the fields for that
2172 index to the template. */
2173 for (index = (convention_fortran_p ? ndim - 1 : 0),
2174 gnat_index = First_Index (gnat_entity);
2175 0 <= index && index < ndim;
2176 index += (convention_fortran_p ? - 1 : 1),
2177 gnat_index = Next_Index (gnat_index))
2179 char field_name[16];
2180 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2181 tree gnu_index_base_type
2182 = maybe_character_type (get_base_type (gnu_index_type));
2183 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2184 tree gnu_min, gnu_max, gnu_high;
2186 /* Make the FIELD_DECLs for the low and high bounds of this
2187 type and then make extractions of these fields from the
2188 template. */
2189 sprintf (field_name, "LB%d", index);
2190 gnu_lb_field = create_field_decl (get_identifier (field_name),
2191 gnu_index_base_type,
2192 gnu_template_type, NULL_TREE,
2193 NULL_TREE, 0, 0);
2194 Sloc_to_locus (Sloc (gnat_entity),
2195 &DECL_SOURCE_LOCATION (gnu_lb_field));
2197 field_name[0] = 'U';
2198 gnu_hb_field = create_field_decl (get_identifier (field_name),
2199 gnu_index_base_type,
2200 gnu_template_type, NULL_TREE,
2201 NULL_TREE, 0, 0);
2202 Sloc_to_locus (Sloc (gnat_entity),
2203 &DECL_SOURCE_LOCATION (gnu_hb_field));
2205 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2207 /* We can't use build_component_ref here since the template type
2208 isn't complete yet. */
2209 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2210 gnu_template_reference, gnu_lb_field,
2211 NULL_TREE);
2212 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2213 gnu_template_reference, gnu_hb_field,
2214 NULL_TREE);
2215 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2217 gnu_min = convert (sizetype, gnu_orig_min);
2218 gnu_max = convert (sizetype, gnu_orig_max);
2220 /* Compute the size of this dimension. See the E_Array_Subtype
2221 case below for the rationale. */
2222 gnu_high
2223 = build3 (COND_EXPR, sizetype,
2224 build2 (GE_EXPR, boolean_type_node,
2225 gnu_orig_max, gnu_orig_min),
2226 gnu_max,
2227 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2229 /* Make a range type with the new range in the Ada base type.
2230 Then make an index type with the size range in sizetype. */
2231 gnu_index_types[index]
2232 = create_index_type (gnu_min, gnu_high,
2233 create_range_type (gnu_index_base_type,
2234 gnu_orig_min,
2235 gnu_orig_max),
2236 gnat_entity);
2238 /* Update the maximum size of the array in elements. */
2239 if (gnu_max_size)
2241 tree gnu_min
2242 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2243 tree gnu_max
2244 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2245 tree gnu_this_max
2246 = size_binop (PLUS_EXPR, size_one_node,
2247 size_binop (MINUS_EXPR, gnu_max, gnu_min));
2249 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2250 && TREE_OVERFLOW (gnu_this_max))
2251 gnu_max_size = NULL_TREE;
2252 else
2253 gnu_max_size
2254 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2257 TYPE_NAME (gnu_index_types[index])
2258 = create_concat_name (gnat_entity, field_name);
2261 /* Install all the fields into the template. */
2262 TYPE_NAME (gnu_template_type)
2263 = create_concat_name (gnat_entity, "XUB");
2264 gnu_template_fields = NULL_TREE;
2265 for (index = 0; index < ndim; index++)
2266 gnu_template_fields
2267 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2268 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2269 debug_info_p);
2270 TYPE_READONLY (gnu_template_type) = 1;
2272 /* If Component_Size is not already specified, annotate it with the
2273 size of the component. */
2274 if (Unknown_Component_Size (gnat_entity))
2275 Set_Component_Size (gnat_entity,
2276 annotate_value (TYPE_SIZE (comp_type)));
2278 /* Compute the maximum size of the array in units and bits. */
2279 if (gnu_max_size)
2281 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2282 TYPE_SIZE_UNIT (comp_type));
2283 gnu_max_size = size_binop (MULT_EXPR,
2284 convert (bitsizetype, gnu_max_size),
2285 TYPE_SIZE (comp_type));
2287 else
2288 gnu_max_size_unit = NULL_TREE;
2290 /* Now build the array type. */
2291 tem = comp_type;
2292 for (index = ndim - 1; index >= 0; index--)
2294 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2295 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2296 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2297 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2298 set_reverse_storage_order_on_array_type (tem);
2299 if (array_type_has_nonaliased_component (tem, gnat_entity))
2300 set_nonaliased_component_on_array_type (tem);
2303 /* If an alignment is specified, use it if valid. But ignore it
2304 for the original type of packed array types. If the alignment
2305 was requested with an explicit alignment clause, state so. */
2306 if (No (Packed_Array_Impl_Type (gnat_entity))
2307 && Known_Alignment (gnat_entity))
2309 SET_TYPE_ALIGN (tem,
2310 validate_alignment (Alignment (gnat_entity),
2311 gnat_entity,
2312 TYPE_ALIGN (tem)));
2313 if (Present (Alignment_Clause (gnat_entity)))
2314 TYPE_USER_ALIGN (tem) = 1;
2317 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2318 implementation types as such so that the debug information back-end
2319 can output the appropriate description for them. */
2320 TYPE_PACKED (tem)
2321 = (Is_Packed (gnat_entity)
2322 || Is_Packed_Array_Impl_Type (gnat_entity));
2324 if (Treat_As_Volatile (gnat_entity))
2325 tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
2327 /* Adjust the type of the pointer-to-array field of the fat pointer
2328 and record the aliasing relationships if necessary. */
2329 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2330 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2331 record_component_aliases (gnu_fat_type);
2333 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2334 corresponding fat pointer. */
2335 TREE_TYPE (gnu_type) = gnu_fat_type;
2336 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2337 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2338 SET_TYPE_MODE (gnu_type, BLKmode);
2339 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
2341 /* If the maximum size doesn't overflow, use it. */
2342 if (gnu_max_size
2343 && TREE_CODE (gnu_max_size) == INTEGER_CST
2344 && !TREE_OVERFLOW (gnu_max_size)
2345 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2346 && !TREE_OVERFLOW (gnu_max_size_unit))
2348 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2349 TYPE_SIZE (tem));
2350 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2351 TYPE_SIZE_UNIT (tem));
2354 create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
2355 artificial_p, debug_info_p, gnat_entity);
2357 /* If told to generate GNAT encodings for them (GDB rely on them at the
2358 moment): give the fat pointer type a name. If this is a packed
2359 array, tell the debugger how to interpret the underlying bits. */
2360 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2361 gnat_name = Packed_Array_Impl_Type (gnat_entity);
2362 else
2363 gnat_name = gnat_entity;
2364 tree xup_name
2365 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2366 ? get_entity_name (gnat_name)
2367 : create_concat_name (gnat_name, "XUP");
2368 create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
2369 gnat_entity);
2371 /* Create the type to be designated by thin pointers: a record type for
2372 the array and its template. We used to shift the fields to have the
2373 template at a negative offset, but this was somewhat of a kludge; we
2374 now shift thin pointer values explicitly but only those which have a
2375 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
2376 Note that GDB can handle standard DWARF information for them, so we
2377 don't have to name them as a GNAT encoding, except if specifically
2378 asked to. */
2379 tree xut_name
2380 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2381 ? get_entity_name (gnat_name)
2382 : create_concat_name (gnat_name, "XUT");
2383 tem = build_unc_object_type (gnu_template_type, tem, xut_name,
2384 debug_info_p);
2386 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2387 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2389 break;
2391 case E_Array_Subtype:
2393 /* This is the actual data type for array variables. Multidimensional
2394 arrays are implemented as arrays of arrays. Note that arrays which
2395 have sparse enumeration subtypes as index components create sparse
2396 arrays, which is obviously space inefficient but so much easier to
2397 code for now.
2399 Also note that the subtype never refers to the unconstrained array
2400 type, which is somewhat at variance with Ada semantics.
2402 First check to see if this is simply a renaming of the array type.
2403 If so, the result is the array type. */
2405 gnu_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity)));
2406 if (!Is_Constrained (gnat_entity))
2408 else
2410 Entity_Id gnat_index, gnat_base_index;
2411 const bool convention_fortran_p
2412 = (Convention (gnat_entity) == Convention_Fortran);
2413 const int ndim = Number_Dimensions (gnat_entity);
2414 tree gnu_base_type = gnu_type;
2415 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2416 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2417 bool need_index_type_struct = false;
2418 int index;
2420 /* First create the GCC type for each index and find out whether
2421 special types are needed for debugging information. */
2422 for (index = (convention_fortran_p ? ndim - 1 : 0),
2423 gnat_index = First_Index (gnat_entity),
2424 gnat_base_index
2425 = First_Index (Implementation_Base_Type (gnat_entity));
2426 0 <= index && index < ndim;
2427 index += (convention_fortran_p ? - 1 : 1),
2428 gnat_index = Next_Index (gnat_index),
2429 gnat_base_index = Next_Index (gnat_base_index))
2431 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2432 tree gnu_index_base_type
2433 = maybe_character_type (get_base_type (gnu_index_type));
2434 tree gnu_orig_min
2435 = convert (gnu_index_base_type,
2436 TYPE_MIN_VALUE (gnu_index_type));
2437 tree gnu_orig_max
2438 = convert (gnu_index_base_type,
2439 TYPE_MAX_VALUE (gnu_index_type));
2440 tree gnu_min = convert (sizetype, gnu_orig_min);
2441 tree gnu_max = convert (sizetype, gnu_orig_max);
2442 tree gnu_base_index_type
2443 = get_unpadded_type (Etype (gnat_base_index));
2444 tree gnu_base_index_base_type
2445 = maybe_character_type (get_base_type (gnu_base_index_type));
2446 tree gnu_base_orig_min
2447 = convert (gnu_base_index_base_type,
2448 TYPE_MIN_VALUE (gnu_base_index_type));
2449 tree gnu_base_orig_max
2450 = convert (gnu_base_index_base_type,
2451 TYPE_MAX_VALUE (gnu_base_index_type));
2452 tree gnu_high;
2454 /* See if the base array type is already flat. If it is, we
2455 are probably compiling an ACATS test but it will cause the
2456 code below to malfunction if we don't handle it specially. */
2457 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2458 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2459 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2461 gnu_min = size_one_node;
2462 gnu_max = size_zero_node;
2463 gnu_high = gnu_max;
2466 /* Similarly, if one of the values overflows in sizetype and the
2467 range is null, use 1..0 for the sizetype bounds. */
2468 else if (TREE_CODE (gnu_min) == INTEGER_CST
2469 && TREE_CODE (gnu_max) == INTEGER_CST
2470 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2471 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2473 gnu_min = size_one_node;
2474 gnu_max = size_zero_node;
2475 gnu_high = gnu_max;
2478 /* If the minimum and maximum values both overflow in sizetype,
2479 but the difference in the original type does not overflow in
2480 sizetype, ignore the overflow indication. */
2481 else if (TREE_CODE (gnu_min) == INTEGER_CST
2482 && TREE_CODE (gnu_max) == INTEGER_CST
2483 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2484 && !TREE_OVERFLOW
2485 (convert (sizetype,
2486 fold_build2 (MINUS_EXPR, gnu_index_type,
2487 gnu_orig_max,
2488 gnu_orig_min))))
2490 TREE_OVERFLOW (gnu_min) = 0;
2491 TREE_OVERFLOW (gnu_max) = 0;
2492 gnu_high = gnu_max;
2495 /* Compute the size of this dimension in the general case. We
2496 need to provide GCC with an upper bound to use but have to
2497 deal with the "superflat" case. There are three ways to do
2498 this. If we can prove that the array can never be superflat,
2499 we can just use the high bound of the index type. */
2500 else if ((Nkind (gnat_index) == N_Range
2501 && cannot_be_superflat (gnat_index))
2502 /* Bit-Packed Array Impl. Types are never superflat. */
2503 || (Is_Packed_Array_Impl_Type (gnat_entity)
2504 && Is_Bit_Packed_Array
2505 (Original_Array_Type (gnat_entity))))
2506 gnu_high = gnu_max;
2508 /* Otherwise, if the high bound is constant but the low bound is
2509 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2510 lower bound. Note that the comparison must be done in the
2511 original type to avoid any overflow during the conversion. */
2512 else if (TREE_CODE (gnu_max) == INTEGER_CST
2513 && TREE_CODE (gnu_min) != INTEGER_CST)
2515 gnu_high = gnu_max;
2516 gnu_min
2517 = build_cond_expr (sizetype,
2518 build_binary_op (GE_EXPR,
2519 boolean_type_node,
2520 gnu_orig_max,
2521 gnu_orig_min),
2522 gnu_min,
2523 int_const_binop (PLUS_EXPR, gnu_max,
2524 size_one_node));
2527 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2528 in all the other cases. Note that, here as well as above,
2529 the condition used in the comparison must be equivalent to
2530 the condition (length != 0). This is relied upon in order
2531 to optimize array comparisons in compare_arrays. Moreover
2532 we use int_const_binop for the shift by 1 if the bound is
2533 constant to avoid any unwanted overflow. */
2534 else
2535 gnu_high
2536 = build_cond_expr (sizetype,
2537 build_binary_op (GE_EXPR,
2538 boolean_type_node,
2539 gnu_orig_max,
2540 gnu_orig_min),
2541 gnu_max,
2542 TREE_CODE (gnu_min) == INTEGER_CST
2543 ? int_const_binop (MINUS_EXPR, gnu_min,
2544 size_one_node)
2545 : size_binop (MINUS_EXPR, gnu_min,
2546 size_one_node));
2548 /* Reuse the index type for the range type. Then make an index
2549 type with the size range in sizetype. */
2550 gnu_index_types[index]
2551 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2552 gnat_entity);
2554 /* Update the maximum size of the array in elements. Here we
2555 see if any constraint on the index type of the base type
2556 can be used in the case of self-referential bound on the
2557 index type of the subtype. We look for a non-"infinite"
2558 and non-self-referential bound from any type involved and
2559 handle each bound separately. */
2560 if (gnu_max_size)
2562 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2563 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2564 tree gnu_base_base_min
2565 = convert (sizetype,
2566 TYPE_MIN_VALUE (gnu_base_index_base_type));
2567 tree gnu_base_base_max
2568 = convert (sizetype,
2569 TYPE_MAX_VALUE (gnu_base_index_base_type));
2571 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2572 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2573 && !TREE_OVERFLOW (gnu_base_min)))
2574 gnu_base_min = gnu_min;
2576 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2577 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2578 && !TREE_OVERFLOW (gnu_base_max)))
2579 gnu_base_max = gnu_max;
2581 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2582 && TREE_OVERFLOW (gnu_base_min))
2583 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2584 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2585 && TREE_OVERFLOW (gnu_base_max))
2586 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2587 gnu_max_size = NULL_TREE;
2588 else
2590 tree gnu_this_max;
2592 /* Use int_const_binop if the bounds are constant to
2593 avoid any unwanted overflow. */
2594 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2595 && TREE_CODE (gnu_base_max) == INTEGER_CST)
2596 gnu_this_max
2597 = int_const_binop (PLUS_EXPR, size_one_node,
2598 int_const_binop (MINUS_EXPR,
2599 gnu_base_max,
2600 gnu_base_min));
2601 else
2602 gnu_this_max
2603 = size_binop (PLUS_EXPR, size_one_node,
2604 size_binop (MINUS_EXPR,
2605 gnu_base_max,
2606 gnu_base_min));
2608 gnu_max_size
2609 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2613 /* We need special types for debugging information to point to
2614 the index types if they have variable bounds, are not integer
2615 types, are biased or are wider than sizetype. These are GNAT
2616 encodings, so we have to include them only when all encodings
2617 are requested. */
2618 if ((TREE_CODE (gnu_orig_min) != INTEGER_CST
2619 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2620 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2621 || (TREE_TYPE (gnu_index_type)
2622 && TREE_CODE (TREE_TYPE (gnu_index_type))
2623 != INTEGER_TYPE)
2624 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
2625 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2626 need_index_type_struct = true;
2629 /* Then flatten: create the array of arrays. For an array type
2630 used to implement a packed array, get the component type from
2631 the original array type since the representation clauses that
2632 can affect it are on the latter. */
2633 if (Is_Packed_Array_Impl_Type (gnat_entity)
2634 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2636 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2637 for (index = ndim - 1; index >= 0; index--)
2638 gnu_type = TREE_TYPE (gnu_type);
2640 /* One of the above calls might have caused us to be elaborated,
2641 so don't blow up if so. */
2642 if (present_gnu_tree (gnat_entity))
2644 maybe_present = true;
2645 break;
2648 else
2650 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2651 debug_info_p);
2653 /* One of the above calls might have caused us to be elaborated,
2654 so don't blow up if so. */
2655 if (present_gnu_tree (gnat_entity))
2657 maybe_present = true;
2658 break;
2662 /* Compute the maximum size of the array in units and bits. */
2663 if (gnu_max_size)
2665 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2666 TYPE_SIZE_UNIT (gnu_type));
2667 gnu_max_size = size_binop (MULT_EXPR,
2668 convert (bitsizetype, gnu_max_size),
2669 TYPE_SIZE (gnu_type));
2671 else
2672 gnu_max_size_unit = NULL_TREE;
2674 /* Now build the array type. */
2675 for (index = ndim - 1; index >= 0; index --)
2677 gnu_type = build_nonshared_array_type (gnu_type,
2678 gnu_index_types[index]);
2679 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2680 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2681 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2682 set_reverse_storage_order_on_array_type (gnu_type);
2683 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2684 set_nonaliased_component_on_array_type (gnu_type);
2687 /* Strip the ___XP suffix for standard DWARF. */
2688 if (Is_Packed_Array_Impl_Type (gnat_entity)
2689 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2691 Entity_Id gnat_original_array_type
2692 = Underlying_Type (Original_Array_Type (gnat_entity));
2694 gnu_entity_name
2695 = get_entity_name (gnat_original_array_type);
2698 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2699 TYPE_STUB_DECL (gnu_type)
2700 = create_type_stub_decl (gnu_entity_name, gnu_type);
2702 /* If this is a multi-dimensional array and we are at global level,
2703 we need to make a variable corresponding to the stride of the
2704 inner dimensions. */
2705 if (ndim > 1 && global_bindings_p ())
2707 tree gnu_arr_type;
2709 for (gnu_arr_type = TREE_TYPE (gnu_type), index = 1;
2710 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2711 gnu_arr_type = TREE_TYPE (gnu_arr_type), index++)
2713 tree eltype = TREE_TYPE (gnu_arr_type);
2714 char stride_name[32];
2716 sprintf (stride_name, "ST%d", index);
2717 TYPE_SIZE (gnu_arr_type)
2718 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2719 gnat_entity, stride_name,
2720 definition, false);
2722 /* ??? For now, store the size as a multiple of the
2723 alignment of the element type in bytes so that we
2724 can see the alignment from the tree. */
2725 sprintf (stride_name, "ST%d_A_UNIT", index);
2726 TYPE_SIZE_UNIT (gnu_arr_type)
2727 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2728 gnat_entity, stride_name,
2729 definition, false,
2730 TYPE_ALIGN (eltype));
2732 /* ??? create_type_decl is not invoked on the inner types so
2733 the MULT_EXPR node built above will never be marked. */
2734 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2738 /* If we need to write out a record type giving the names of the
2739 bounds for debugging purposes, do it now and make the record
2740 type a parallel type. This is not needed for a packed array
2741 since the bounds are conveyed by the original array type. */
2742 if (need_index_type_struct
2743 && debug_info_p
2744 && !Is_Packed_Array_Impl_Type (gnat_entity))
2746 tree gnu_bound_rec = make_node (RECORD_TYPE);
2747 tree gnu_field_list = NULL_TREE;
2748 tree gnu_field;
2750 TYPE_NAME (gnu_bound_rec)
2751 = create_concat_name (gnat_entity, "XA");
2753 for (index = ndim - 1; index >= 0; index--)
2755 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2756 tree gnu_index_name = TYPE_IDENTIFIER (gnu_index);
2758 /* Make sure to reference the types themselves, and not just
2759 their names, as the debugger may fall back on them. */
2760 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2761 gnu_bound_rec, NULL_TREE,
2762 NULL_TREE, 0, 0);
2763 DECL_CHAIN (gnu_field) = gnu_field_list;
2764 gnu_field_list = gnu_field;
2767 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2768 add_parallel_type (gnu_type, gnu_bound_rec);
2771 /* If this is a packed array type, make the original array type a
2772 parallel/debug type. Otherwise, if such GNAT encodings are
2773 required, do it for the base array type if it isn't artificial to
2774 make sure it is kept in the debug info. */
2775 if (debug_info_p)
2777 if (Is_Packed_Array_Impl_Type (gnat_entity))
2778 associate_original_type_to_packed_array (gnu_type,
2779 gnat_entity);
2780 else
2782 tree gnu_base_decl
2783 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
2784 false);
2785 if (!DECL_ARTIFICIAL (gnu_base_decl)
2786 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2787 add_parallel_type (gnu_type,
2788 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2792 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2793 = (Is_Packed_Array_Impl_Type (gnat_entity)
2794 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2796 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2797 implementation types as such so that the debug information back-end
2798 can output the appropriate description for them. */
2799 TYPE_PACKED (gnu_type)
2800 = (Is_Packed (gnat_entity)
2801 || Is_Packed_Array_Impl_Type (gnat_entity));
2803 /* If the size is self-referential and the maximum size doesn't
2804 overflow, use it. */
2805 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2806 && gnu_max_size
2807 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2808 && TREE_OVERFLOW (gnu_max_size))
2809 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2810 && TREE_OVERFLOW (gnu_max_size_unit)))
2812 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2813 TYPE_SIZE (gnu_type));
2814 TYPE_SIZE_UNIT (gnu_type)
2815 = size_binop (MIN_EXPR, gnu_max_size_unit,
2816 TYPE_SIZE_UNIT (gnu_type));
2819 /* Set our alias set to that of our base type. This gives all
2820 array subtypes the same alias set. */
2821 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2823 /* If this is a packed type, make this type the same as the packed
2824 array type, but do some adjusting in the type first. */
2825 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2827 Entity_Id gnat_index;
2828 tree gnu_inner;
2830 /* First finish the type we had been making so that we output
2831 debugging information for it. */
2832 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
2833 if (Treat_As_Volatile (gnat_entity))
2835 const int quals
2836 = TYPE_QUAL_VOLATILE
2837 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
2838 gnu_type = change_qualified_type (gnu_type, quals);
2840 /* Make it artificial only if the base type was artificial too.
2841 That's sort of "morally" true and will make it possible for
2842 the debugger to look it up by name in DWARF, which is needed
2843 in order to decode the packed array type. */
2844 gnu_decl
2845 = create_type_decl (gnu_entity_name, gnu_type,
2846 !Comes_From_Source (Etype (gnat_entity))
2847 && artificial_p, debug_info_p,
2848 gnat_entity);
2850 /* Save it as our equivalent in case the call below elaborates
2851 this type again. */
2852 save_gnu_tree (gnat_entity, gnu_decl, false);
2854 gnu_decl
2855 = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
2856 NULL_TREE, false);
2857 this_made_decl = true;
2858 gnu_type = TREE_TYPE (gnu_decl);
2859 save_gnu_tree (gnat_entity, NULL_TREE, false);
2860 save_gnu_tree (gnat_entity, gnu_decl, false);
2861 saved = true;
2863 gnu_inner = gnu_type;
2864 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2865 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2866 || TYPE_PADDING_P (gnu_inner)))
2867 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2869 /* We need to attach the index type to the type we just made so
2870 that the actual bounds can later be put into a template. */
2871 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2872 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2873 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2874 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2876 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2878 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2879 TYPE_MODULUS for modular types so we make an extra
2880 subtype if necessary. */
2881 if (TYPE_MODULAR_P (gnu_inner))
2883 tree gnu_subtype
2884 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2885 TREE_TYPE (gnu_subtype) = gnu_inner;
2886 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2887 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2888 TYPE_MIN_VALUE (gnu_inner));
2889 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2890 TYPE_MAX_VALUE (gnu_inner));
2891 gnu_inner = gnu_subtype;
2894 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2896 /* Check for other cases of overloading. */
2897 gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2900 for (gnat_index = First_Index (gnat_entity);
2901 Present (gnat_index);
2902 gnat_index = Next_Index (gnat_index))
2903 SET_TYPE_ACTUAL_BOUNDS
2904 (gnu_inner,
2905 tree_cons (NULL_TREE,
2906 get_unpadded_type (Etype (gnat_index)),
2907 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2909 if (Convention (gnat_entity) != Convention_Fortran)
2910 SET_TYPE_ACTUAL_BOUNDS
2911 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2913 if (TREE_CODE (gnu_type) == RECORD_TYPE
2914 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2915 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2919 break;
2921 case E_String_Literal_Subtype:
2922 /* Create the type for a string literal. */
2924 Entity_Id gnat_full_type
2925 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2926 && Present (Full_View (Etype (gnat_entity)))
2927 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2928 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2929 tree gnu_string_array_type
2930 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2931 tree gnu_string_index_type
2932 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2933 (TYPE_DOMAIN (gnu_string_array_type))));
2934 tree gnu_lower_bound
2935 = convert (gnu_string_index_type,
2936 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2937 tree gnu_length
2938 = UI_To_gnu (String_Literal_Length (gnat_entity),
2939 gnu_string_index_type);
2940 tree gnu_upper_bound
2941 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2942 gnu_lower_bound,
2943 int_const_binop (MINUS_EXPR, gnu_length,
2944 convert (gnu_string_index_type,
2945 integer_one_node)));
2946 tree gnu_index_type
2947 = create_index_type (convert (sizetype, gnu_lower_bound),
2948 convert (sizetype, gnu_upper_bound),
2949 create_range_type (gnu_string_index_type,
2950 gnu_lower_bound,
2951 gnu_upper_bound),
2952 gnat_entity);
2954 gnu_type
2955 = build_nonshared_array_type (gnat_to_gnu_type
2956 (Component_Type (gnat_entity)),
2957 gnu_index_type);
2958 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2959 set_nonaliased_component_on_array_type (gnu_type);
2960 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2962 break;
2964 /* Record Types and Subtypes
2966 The following fields are defined on record types:
2968 Has_Discriminants True if the record has discriminants
2969 First_Discriminant Points to head of list of discriminants
2970 First_Entity Points to head of list of fields
2971 Is_Tagged_Type True if the record is tagged
2973 Implementation of Ada records and discriminated records:
2975 A record type definition is transformed into the equivalent of a C
2976 struct definition. The fields that are the discriminants which are
2977 found in the Full_Type_Declaration node and the elements of the
2978 Component_List found in the Record_Type_Definition node. The
2979 Component_List can be a recursive structure since each Variant of
2980 the Variant_Part of the Component_List has a Component_List.
2982 Processing of a record type definition comprises starting the list of
2983 field declarations here from the discriminants and the calling the
2984 function components_to_record to add the rest of the fields from the
2985 component list and return the gnu type node. The function
2986 components_to_record will call itself recursively as it traverses
2987 the tree. */
2989 case E_Record_Type:
2990 if (Has_Complex_Representation (gnat_entity))
2992 gnu_type
2993 = build_complex_type
2994 (get_unpadded_type
2995 (Etype (Defining_Entity
2996 (First (Component_Items
2997 (Component_List
2998 (Type_Definition
2999 (Declaration_Node (gnat_entity)))))))));
3001 break;
3005 Node_Id full_definition = Declaration_Node (gnat_entity);
3006 Node_Id record_definition = Type_Definition (full_definition);
3007 Node_Id gnat_constr;
3008 Entity_Id gnat_field, gnat_parent_type;
3009 tree gnu_field, gnu_field_list = NULL_TREE;
3010 tree gnu_get_parent;
3011 /* Set PACKED in keeping with gnat_to_gnu_field. */
3012 const int packed
3013 = Is_Packed (gnat_entity)
3015 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
3016 ? -1
3017 : 0;
3018 const bool has_align = Known_Alignment (gnat_entity);
3019 const bool has_discr = Has_Discriminants (gnat_entity);
3020 const bool has_rep = Has_Specified_Layout (gnat_entity);
3021 const bool is_extension
3022 = (Is_Tagged_Type (gnat_entity)
3023 && Nkind (record_definition) == N_Derived_Type_Definition);
3024 const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
3025 bool all_rep = has_rep;
3027 /* See if all fields have a rep clause. Stop when we find one
3028 that doesn't. */
3029 if (all_rep)
3030 for (gnat_field = First_Entity (gnat_entity);
3031 Present (gnat_field);
3032 gnat_field = Next_Entity (gnat_field))
3033 if ((Ekind (gnat_field) == E_Component
3034 || Ekind (gnat_field) == E_Discriminant)
3035 && No (Component_Clause (gnat_field)))
3037 all_rep = false;
3038 break;
3041 /* If this is a record extension, go a level further to find the
3042 record definition. Also, verify we have a Parent_Subtype. */
3043 if (is_extension)
3045 if (!type_annotate_only
3046 || Present (Record_Extension_Part (record_definition)))
3047 record_definition = Record_Extension_Part (record_definition);
3049 gcc_assert (type_annotate_only
3050 || Present (Parent_Subtype (gnat_entity)));
3053 /* Make a node for the record. If we are not defining the record,
3054 suppress expanding incomplete types. */
3055 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
3056 TYPE_NAME (gnu_type) = gnu_entity_name;
3057 TYPE_PACKED (gnu_type) = (packed != 0) || has_align || has_rep;
3058 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3059 = Reverse_Storage_Order (gnat_entity);
3060 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3062 if (!definition)
3064 defer_incomplete_level++;
3065 this_deferred = true;
3068 /* If both a size and rep clause were specified, put the size on
3069 the record type now so that it can get the proper layout. */
3070 if (has_rep && Known_RM_Size (gnat_entity))
3071 TYPE_SIZE (gnu_type)
3072 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
3074 /* Always set the alignment on the record type here so that it can
3075 get the proper layout. */
3076 if (has_align)
3077 SET_TYPE_ALIGN (gnu_type,
3078 validate_alignment (Alignment (gnat_entity),
3079 gnat_entity, 0));
3080 else
3082 SET_TYPE_ALIGN (gnu_type, 0);
3084 /* If a type needs strict alignment, the minimum size will be the
3085 type size instead of the RM size (see validate_size). Cap the
3086 alignment lest it causes this type size to become too large. */
3087 if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity))
3089 unsigned int max_size = UI_To_Int (RM_Size (gnat_entity));
3090 unsigned int max_align = max_size & -max_size;
3091 if (max_align < BIGGEST_ALIGNMENT)
3092 TYPE_MAX_ALIGN (gnu_type) = max_align;
3096 /* If we have a Parent_Subtype, make a field for the parent. If
3097 this record has rep clauses, force the position to zero. */
3098 if (Present (Parent_Subtype (gnat_entity)))
3100 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
3101 tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
3102 tree gnu_parent;
3103 int parent_packed = 0;
3105 /* A major complexity here is that the parent subtype will
3106 reference our discriminants in its Stored_Constraint list.
3107 But those must reference the parent component of this record
3108 which is precisely of the parent subtype we have not built yet!
3109 To break the circle we first build a dummy COMPONENT_REF which
3110 represents the "get to the parent" operation and initialize
3111 each of those discriminants to a COMPONENT_REF of the above
3112 dummy parent referencing the corresponding discriminant of the
3113 base type of the parent subtype. */
3114 gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type,
3115 build0 (PLACEHOLDER_EXPR, gnu_type),
3116 build_decl (input_location,
3117 FIELD_DECL, NULL_TREE,
3118 gnu_dummy_parent_type),
3119 NULL_TREE);
3121 if (has_discr)
3122 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3123 Present (gnat_field);
3124 gnat_field = Next_Stored_Discriminant (gnat_field))
3125 if (Present (Corresponding_Discriminant (gnat_field)))
3127 tree gnu_field
3128 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3129 (gnat_field));
3130 save_gnu_tree
3131 (gnat_field,
3132 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3133 gnu_get_parent, gnu_field, NULL_TREE),
3134 true);
3137 /* Then we build the parent subtype. If it has discriminants but
3138 the type itself has unknown discriminants, this means that it
3139 doesn't contain information about how the discriminants are
3140 derived from those of the ancestor type, so it cannot be used
3141 directly. Instead it is built by cloning the parent subtype
3142 of the underlying record view of the type, for which the above
3143 derivation of discriminants has been made explicit. */
3144 if (Has_Discriminants (gnat_parent)
3145 && Has_Unknown_Discriminants (gnat_entity))
3147 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3149 /* If we are defining the type, the underlying record
3150 view must already have been elaborated at this point.
3151 Otherwise do it now as its parent subtype cannot be
3152 technically elaborated on its own. */
3153 if (definition)
3154 gcc_assert (present_gnu_tree (gnat_uview));
3155 else
3156 gnat_to_gnu_entity (gnat_uview, NULL_TREE, false);
3158 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3160 /* Substitute the "get to the parent" of the type for that
3161 of its underlying record view in the cloned type. */
3162 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3163 Present (gnat_field);
3164 gnat_field = Next_Stored_Discriminant (gnat_field))
3165 if (Present (Corresponding_Discriminant (gnat_field)))
3167 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3168 tree gnu_ref
3169 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3170 gnu_get_parent, gnu_field, NULL_TREE);
3171 gnu_parent
3172 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3175 else
3176 gnu_parent = gnat_to_gnu_type (gnat_parent);
3178 /* The parent field needs strict alignment so, if it is to
3179 be created with a component clause below, then we need
3180 to apply the same adjustment as in gnat_to_gnu_field. */
3181 if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
3183 /* ??? For historical reasons, we do it on strict-alignment
3184 platforms only, where it is really required. This means
3185 that a confirming representation clause will change the
3186 behavior of the compiler on the other platforms. */
3187 if (STRICT_ALIGNMENT)
3188 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
3189 else
3190 parent_packed
3191 = adjust_packed (gnu_parent, gnu_type, parent_packed);
3194 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3195 initially built. The discriminants must reference the fields
3196 of the parent subtype and not those of its base type for the
3197 placeholder machinery to properly work. */
3198 if (has_discr)
3200 /* The actual parent subtype is the full view. */
3201 if (IN (Ekind (gnat_parent), Private_Kind))
3203 if (Present (Full_View (gnat_parent)))
3204 gnat_parent = Full_View (gnat_parent);
3205 else
3206 gnat_parent = Underlying_Full_View (gnat_parent);
3209 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3210 Present (gnat_field);
3211 gnat_field = Next_Stored_Discriminant (gnat_field))
3212 if (Present (Corresponding_Discriminant (gnat_field)))
3214 Entity_Id field;
3215 for (field = First_Stored_Discriminant (gnat_parent);
3216 Present (field);
3217 field = Next_Stored_Discriminant (field))
3218 if (same_discriminant_p (gnat_field, field))
3219 break;
3220 gcc_assert (Present (field));
3221 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3222 = gnat_to_gnu_field_decl (field);
3226 /* The "get to the parent" COMPONENT_REF must be given its
3227 proper type... */
3228 TREE_TYPE (gnu_get_parent) = gnu_parent;
3230 /* ...and reference the _Parent field of this record. */
3231 gnu_field
3232 = create_field_decl (parent_name_id,
3233 gnu_parent, gnu_type,
3234 has_rep
3235 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3236 has_rep
3237 ? bitsize_zero_node : NULL_TREE,
3238 parent_packed, 1);
3239 DECL_INTERNAL_P (gnu_field) = 1;
3240 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3241 TYPE_FIELDS (gnu_type) = gnu_field;
3244 /* Make the fields for the discriminants and put them into the record
3245 unless it's an Unchecked_Union. */
3246 if (has_discr)
3247 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3248 Present (gnat_field);
3249 gnat_field = Next_Stored_Discriminant (gnat_field))
3251 /* If this is a record extension and this discriminant is the
3252 renaming of another discriminant, we've handled it above. */
3253 if (is_extension
3254 && Present (Corresponding_Discriminant (gnat_field)))
3255 continue;
3257 gnu_field
3258 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3259 debug_info_p);
3261 /* Make an expression using a PLACEHOLDER_EXPR from the
3262 FIELD_DECL node just created and link that with the
3263 corresponding GNAT defining identifier. */
3264 save_gnu_tree (gnat_field,
3265 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3266 build0 (PLACEHOLDER_EXPR, gnu_type),
3267 gnu_field, NULL_TREE),
3268 true);
3270 if (!is_unchecked_union)
3272 DECL_CHAIN (gnu_field) = gnu_field_list;
3273 gnu_field_list = gnu_field;
3277 /* If we have a derived untagged type that renames discriminants in
3278 the parent type, the (stored) discriminants are just a copy of the
3279 discriminants of the parent type. This means that any constraints
3280 added by the renaming in the derivation are disregarded as far as
3281 the layout of the derived type is concerned. To rescue them, we
3282 change the type of the (stored) discriminants to a subtype with
3283 the bounds of the type of the visible discriminants. */
3284 if (has_discr
3285 && !is_extension
3286 && Stored_Constraint (gnat_entity) != No_Elist)
3287 for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
3288 gnat_constr != No_Elmt;
3289 gnat_constr = Next_Elmt (gnat_constr))
3290 if (Nkind (Node (gnat_constr)) == N_Identifier
3291 /* Ignore access discriminants. */
3292 && !Is_Access_Type (Etype (Node (gnat_constr)))
3293 && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
3295 Entity_Id gnat_discr = Entity (Node (gnat_constr));
3296 tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
3297 tree gnu_ref
3298 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
3299 NULL_TREE, false);
3301 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3302 just above for one of the stored discriminants. */
3303 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
3305 if (gnu_discr_type != TREE_TYPE (gnu_ref))
3307 const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref));
3308 tree gnu_subtype
3309 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref))
3310 ? make_unsigned_type (prec) : make_signed_type (prec);
3311 TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref);
3312 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
3313 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
3314 TYPE_MIN_VALUE (gnu_discr_type));
3315 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
3316 TYPE_MAX_VALUE (gnu_discr_type));
3317 TREE_TYPE (gnu_ref)
3318 = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype;
3322 /* If this is a derived type with discriminants and these discriminants
3323 affect the initial shape it has inherited, factor them in. But for
3324 an Unchecked_Union (it must be an Itype), just process the type. */
3325 if (has_discr
3326 && !is_extension
3327 && !Has_Record_Rep_Clause (gnat_entity)
3328 && Stored_Constraint (gnat_entity) != No_Elist
3329 && (gnat_parent_type = Underlying_Type (Etype (gnat_entity)))
3330 && Is_Record_Type (gnat_parent_type)
3331 && !Is_Unchecked_Union (gnat_parent_type))
3333 tree gnu_parent_type
3334 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type));
3336 if (TYPE_IS_PADDING_P (gnu_parent_type))
3337 gnu_parent_type = TREE_TYPE (TYPE_FIELDS (gnu_parent_type));
3339 vec<subst_pair> gnu_subst_list
3340 = build_subst_list (gnat_entity, gnat_parent_type, definition);
3342 /* Set the layout of the type to match that of the parent type,
3343 doing required substitutions. */
3344 copy_and_substitute_in_layout (gnat_entity, gnat_parent_type,
3345 gnu_type, gnu_parent_type,
3346 gnu_subst_list, debug_info_p);
3348 else
3350 /* Add the fields into the record type and finish it up. */
3351 components_to_record (Component_List (record_definition),
3352 gnat_entity, gnu_field_list, gnu_type,
3353 packed, definition, false, all_rep,
3354 is_unchecked_union, artificial_p,
3355 debug_info_p, false,
3356 all_rep ? NULL_TREE : bitsize_zero_node,
3357 NULL);
3359 /* If there are entities in the chain corresponding to components
3360 that we did not elaborate, ensure we elaborate their types if
3361 they are Itypes. */
3362 for (gnat_temp = First_Entity (gnat_entity);
3363 Present (gnat_temp);
3364 gnat_temp = Next_Entity (gnat_temp))
3365 if ((Ekind (gnat_temp) == E_Component
3366 || Ekind (gnat_temp) == E_Discriminant)
3367 && Is_Itype (Etype (gnat_temp))
3368 && !present_gnu_tree (gnat_temp))
3369 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
3372 /* Fill in locations of fields. */
3373 annotate_rep (gnat_entity, gnu_type);
3375 /* If this is a record type associated with an exception definition,
3376 equate its fields to those of the standard exception type. This
3377 will make it possible to convert between them. */
3378 if (gnu_entity_name == exception_data_name_id)
3380 tree gnu_std_field;
3381 for (gnu_field = TYPE_FIELDS (gnu_type),
3382 gnu_std_field = TYPE_FIELDS (except_type_node);
3383 gnu_field;
3384 gnu_field = DECL_CHAIN (gnu_field),
3385 gnu_std_field = DECL_CHAIN (gnu_std_field))
3386 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3387 gcc_assert (!gnu_std_field);
3390 break;
3392 case E_Class_Wide_Subtype:
3393 /* If an equivalent type is present, that is what we should use.
3394 Otherwise, fall through to handle this like a record subtype
3395 since it may have constraints. */
3396 if (gnat_equiv_type != gnat_entity)
3398 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
3399 maybe_present = true;
3400 break;
3403 /* ... fall through ... */
3405 case E_Record_Subtype:
3406 /* If Cloned_Subtype is Present it means this record subtype has
3407 identical layout to that type or subtype and we should use
3408 that GCC type for this one. The front end guarantees that
3409 the component list is shared. */
3410 if (Present (Cloned_Subtype (gnat_entity)))
3412 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3413 NULL_TREE, false);
3414 maybe_present = true;
3415 break;
3418 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3419 changing the type, make a new type with each field having the type of
3420 the field in the new subtype but the position computed by transforming
3421 every discriminant reference according to the constraints. We don't
3422 see any difference between private and non-private type here since
3423 derivations from types should have been deferred until the completion
3424 of the private type. */
3425 else
3427 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3429 if (!definition)
3431 defer_incomplete_level++;
3432 this_deferred = true;
3435 tree gnu_base_type
3436 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type));
3438 if (present_gnu_tree (gnat_entity))
3440 maybe_present = true;
3441 break;
3444 /* If this is a record subtype associated with a dispatch table,
3445 strip the suffix. This is necessary to make sure 2 different
3446 subtypes associated with the imported and exported views of a
3447 dispatch table are properly merged in LTO mode. */
3448 if (Is_Dispatch_Table_Entity (gnat_entity))
3450 char *p;
3451 Get_Encoded_Name (gnat_entity);
3452 p = strchr (Name_Buffer, '_');
3453 gcc_assert (p);
3454 strcpy (p+2, "dtS");
3455 gnu_entity_name = get_identifier (Name_Buffer);
3458 /* When the subtype has discriminants and these discriminants affect
3459 the initial shape it has inherited, factor them in. But for an
3460 Unchecked_Union (it must be an Itype), just return the type. */
3461 if (Has_Discriminants (gnat_entity)
3462 && Stored_Constraint (gnat_entity) != No_Elist
3463 && !Is_For_Access_Subtype (gnat_entity)
3464 && Is_Record_Type (gnat_base_type)
3465 && !Is_Unchecked_Union (gnat_base_type))
3467 vec<subst_pair> gnu_subst_list
3468 = build_subst_list (gnat_entity, gnat_base_type, definition);
3469 tree gnu_unpad_base_type;
3471 gnu_type = make_node (RECORD_TYPE);
3472 TYPE_NAME (gnu_type) = gnu_entity_name;
3473 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
3474 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_base_type);
3475 TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
3476 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3477 = Reverse_Storage_Order (gnat_entity);
3478 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3480 /* Set the size, alignment and alias set of the type to match
3481 those of the base type, doing required substitutions. */
3482 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3483 gnu_subst_list);
3485 if (TYPE_IS_PADDING_P (gnu_base_type))
3486 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3487 else
3488 gnu_unpad_base_type = gnu_base_type;
3490 /* Set the layout of the type to match that of the base type,
3491 doing required substitutions. We will output debug info
3492 manually below so pass false as last argument. */
3493 copy_and_substitute_in_layout (gnat_entity, gnat_base_type,
3494 gnu_type, gnu_unpad_base_type,
3495 gnu_subst_list, false);
3497 /* Fill in locations of fields. */
3498 annotate_rep (gnat_entity, gnu_type);
3500 /* If debugging information is being written for the type and if
3501 we are asked to output such encodings, write a record that
3502 shows what we are a subtype of and also make a variable that
3503 indicates our size, if still variable. */
3504 if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
3506 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3507 tree gnu_unpad_base_name
3508 = TYPE_IDENTIFIER (gnu_unpad_base_type);
3509 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3511 TYPE_NAME (gnu_subtype_marker)
3512 = create_concat_name (gnat_entity, "XVS");
3513 finish_record_type (gnu_subtype_marker,
3514 create_field_decl (gnu_unpad_base_name,
3515 build_reference_type
3516 (gnu_unpad_base_type),
3517 gnu_subtype_marker,
3518 NULL_TREE, NULL_TREE,
3519 0, 0),
3520 0, true);
3522 add_parallel_type (gnu_type, gnu_subtype_marker);
3524 if (definition
3525 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3526 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3527 TYPE_SIZE_UNIT (gnu_subtype_marker)
3528 = create_var_decl (create_concat_name (gnat_entity,
3529 "XVZ"),
3530 NULL_TREE, sizetype, gnu_size_unit,
3531 false, false, false, false, false,
3532 true, debug_info_p,
3533 NULL, gnat_entity);
3537 /* Otherwise, go down all the components in the new type and make
3538 them equivalent to those in the base type. */
3539 else
3541 gnu_type = gnu_base_type;
3543 for (gnat_temp = First_Entity (gnat_entity);
3544 Present (gnat_temp);
3545 gnat_temp = Next_Entity (gnat_temp))
3546 if ((Ekind (gnat_temp) == E_Discriminant
3547 && !Is_Unchecked_Union (gnat_base_type))
3548 || Ekind (gnat_temp) == E_Component)
3549 save_gnu_tree (gnat_temp,
3550 gnat_to_gnu_field_decl
3551 (Original_Record_Component (gnat_temp)),
3552 false);
3555 break;
3557 case E_Access_Subprogram_Type:
3558 case E_Anonymous_Access_Subprogram_Type:
3559 /* Use the special descriptor type for dispatch tables if needed,
3560 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3561 Note that we are only required to do so for static tables in
3562 order to be compatible with the C++ ABI, but Ada 2005 allows
3563 to extend library level tagged types at the local level so
3564 we do it in the non-static case as well. */
3565 if (TARGET_VTABLE_USES_DESCRIPTORS
3566 && Is_Dispatch_Table_Entity (gnat_entity))
3568 gnu_type = fdesc_type_node;
3569 gnu_size = TYPE_SIZE (gnu_type);
3570 break;
3573 /* ... fall through ... */
3575 case E_Allocator_Type:
3576 case E_Access_Type:
3577 case E_Access_Attribute_Type:
3578 case E_Anonymous_Access_Type:
3579 case E_General_Access_Type:
3581 /* The designated type and its equivalent type for gigi. */
3582 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3583 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3584 /* Whether it comes from a limited with. */
3585 const bool is_from_limited_with
3586 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3587 && From_Limited_With (gnat_desig_equiv));
3588 /* Whether it is a completed Taft Amendment type. Such a type is to
3589 be treated as coming from a limited with clause if it is not in
3590 the main unit, i.e. we break potential circularities here in case
3591 the body of an external unit is loaded for inter-unit inlining. */
3592 const bool is_completed_taft_type
3593 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3594 && Has_Completion_In_Body (gnat_desig_equiv)
3595 && Present (Full_View (gnat_desig_equiv)));
3596 /* The "full view" of the designated type. If this is an incomplete
3597 entity from a limited with, treat its non-limited view as the full
3598 view. Otherwise, if this is an incomplete or private type, use the
3599 full view. In the former case, we might point to a private type,
3600 in which case, we need its full view. Also, we want to look at the
3601 actual type used for the representation, so this takes a total of
3602 three steps. */
3603 Entity_Id gnat_desig_full_direct_first
3604 = (is_from_limited_with
3605 ? Non_Limited_View (gnat_desig_equiv)
3606 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3607 ? Full_View (gnat_desig_equiv) : Empty));
3608 Entity_Id gnat_desig_full_direct
3609 = ((is_from_limited_with
3610 && Present (gnat_desig_full_direct_first)
3611 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3612 ? Full_View (gnat_desig_full_direct_first)
3613 : gnat_desig_full_direct_first);
3614 Entity_Id gnat_desig_full
3615 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3616 /* The type actually used to represent the designated type, either
3617 gnat_desig_full or gnat_desig_equiv. */
3618 Entity_Id gnat_desig_rep;
3619 /* We want to know if we'll be seeing the freeze node for any
3620 incomplete type we may be pointing to. */
3621 const bool in_main_unit
3622 = (Present (gnat_desig_full)
3623 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3624 : In_Extended_Main_Code_Unit (gnat_desig_type));
3625 /* True if we make a dummy type here. */
3626 bool made_dummy = false;
3627 /* The mode to be used for the pointer type. */
3628 scalar_int_mode p_mode;
3629 /* The GCC type used for the designated type. */
3630 tree gnu_desig_type = NULL_TREE;
3632 if (!int_mode_for_size (esize, 0).exists (&p_mode)
3633 || !targetm.valid_pointer_mode (p_mode))
3634 p_mode = ptr_mode;
3636 /* If either the designated type or its full view is an unconstrained
3637 array subtype, replace it with the type it's a subtype of. This
3638 avoids problems with multiple copies of unconstrained array types.
3639 Likewise, if the designated type is a subtype of an incomplete
3640 record type, use the parent type to avoid order of elaboration
3641 issues. This can lose some code efficiency, but there is no
3642 alternative. */
3643 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3644 && !Is_Constrained (gnat_desig_equiv))
3645 gnat_desig_equiv = Etype (gnat_desig_equiv);
3646 if (Present (gnat_desig_full)
3647 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3648 && !Is_Constrained (gnat_desig_full))
3649 || (Ekind (gnat_desig_full) == E_Record_Subtype
3650 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3651 gnat_desig_full = Etype (gnat_desig_full);
3653 /* Set the type that's the representation of the designated type. */
3654 gnat_desig_rep
3655 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3657 /* If we already know what the full type is, use it. */
3658 if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full))
3659 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3661 /* Get the type of the thing we are to point to and build a pointer to
3662 it. If it is a reference to an incomplete or private type with a
3663 full view that is a record, an array or an access, make a dummy type
3664 and get the actual type later when we have verified it is safe. */
3665 else if ((!in_main_unit
3666 && !present_gnu_tree (gnat_desig_equiv)
3667 && Present (gnat_desig_full)
3668 && (Is_Record_Type (gnat_desig_full)
3669 || Is_Array_Type (gnat_desig_full)
3670 || Is_Access_Type (gnat_desig_full)))
3671 /* Likewise if this is a reference to a record, an array or a
3672 subprogram type and we are to defer elaborating incomplete
3673 types. We do this because this access type may be the full
3674 view of a private type. */
3675 || ((!in_main_unit || imported_p)
3676 && defer_incomplete_level != 0
3677 && !present_gnu_tree (gnat_desig_equiv)
3678 && (Is_Record_Type (gnat_desig_rep)
3679 || Is_Array_Type (gnat_desig_rep)
3680 || Ekind (gnat_desig_rep) == E_Subprogram_Type))
3681 /* If this is a reference from a limited_with type back to our
3682 main unit and there's a freeze node for it, either we have
3683 already processed the declaration and made the dummy type,
3684 in which case we just reuse the latter, or we have not yet,
3685 in which case we make the dummy type and it will be reused
3686 when the declaration is finally processed. In both cases,
3687 the pointer eventually created below will be automatically
3688 adjusted when the freeze node is processed. */
3689 || (in_main_unit
3690 && is_from_limited_with
3691 && Present (Freeze_Node (gnat_desig_rep))))
3693 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3694 made_dummy = true;
3697 /* Otherwise handle the case of a pointer to itself. */
3698 else if (gnat_desig_equiv == gnat_entity)
3700 gnu_type
3701 = build_pointer_type_for_mode (void_type_node, p_mode,
3702 No_Strict_Aliasing (gnat_entity));
3703 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3706 /* If expansion is disabled, the equivalent type of a concurrent type
3707 is absent, so we use the void pointer type. */
3708 else if (type_annotate_only && No (gnat_desig_equiv))
3709 gnu_type = ptr_type_node;
3711 /* If the ultimately designated type is an incomplete type with no full
3712 view, we use the void pointer type in LTO mode to avoid emitting a
3713 dummy type in the GIMPLE IR. We cannot do that in regular mode as
3714 the name of the dummy type in used by GDB for a global lookup. */
3715 else if (Ekind (gnat_desig_rep) == E_Incomplete_Type
3716 && No (Full_View (gnat_desig_rep))
3717 && flag_generate_lto)
3718 gnu_type = ptr_type_node;
3720 /* Finally, handle the default case where we can just elaborate our
3721 designated type. */
3722 else
3723 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3725 /* It is possible that a call to gnat_to_gnu_type above resolved our
3726 type. If so, just return it. */
3727 if (present_gnu_tree (gnat_entity))
3729 maybe_present = true;
3730 break;
3733 /* Access-to-unconstrained-array types need a special treatment. */
3734 if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
3736 /* If the processing above got something that has a pointer, then
3737 we are done. This could have happened either because the type
3738 was elaborated or because somebody else executed the code. */
3739 if (!TYPE_POINTER_TO (gnu_desig_type))
3740 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3742 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3745 /* If we haven't done it yet, build the pointer type the usual way. */
3746 else if (!gnu_type)
3748 /* Modify the designated type if we are pointing only to constant
3749 objects, but don't do it for a dummy type. */
3750 if (Is_Access_Constant (gnat_entity)
3751 && !TYPE_IS_DUMMY_P (gnu_desig_type))
3752 gnu_desig_type
3753 = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
3755 gnu_type
3756 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3757 No_Strict_Aliasing (gnat_entity));
3760 /* If the designated type is not declared in the main unit and we made
3761 a dummy node for it, save our definition, elaborate the actual type
3762 and replace the dummy type we made with the actual one. But if we
3763 are to defer actually looking up the actual type, make an entry in
3764 the deferred list instead. If this is from a limited with, we may
3765 have to defer until the end of the current unit. */
3766 if (!in_main_unit && made_dummy)
3768 if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
3769 gnu_type
3770 = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
3772 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
3773 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3774 artificial_p, debug_info_p,
3775 gnat_entity);
3776 this_made_decl = true;
3777 gnu_type = TREE_TYPE (gnu_decl);
3778 save_gnu_tree (gnat_entity, gnu_decl, false);
3779 saved = true;
3781 if (defer_incomplete_level == 0
3782 && !is_from_limited_with
3783 && !is_completed_taft_type)
3785 update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
3786 gnat_to_gnu_type (gnat_desig_equiv));
3788 else
3790 struct incomplete *p = XNEW (struct incomplete);
3791 struct incomplete **head
3792 = (is_from_limited_with || is_completed_taft_type
3793 ? &defer_limited_with_list : &defer_incomplete_list);
3795 p->old_type = gnu_desig_type;
3796 p->full_type = gnat_desig_equiv;
3797 p->next = *head;
3798 *head = p;
3802 break;
3804 case E_Access_Protected_Subprogram_Type:
3805 case E_Anonymous_Access_Protected_Subprogram_Type:
3806 /* If we are just annotating types and have no equivalent record type,
3807 just use the void pointer type. */
3808 if (type_annotate_only && gnat_equiv_type == gnat_entity)
3809 gnu_type = ptr_type_node;
3811 /* The run-time representation is the equivalent type. */
3812 else
3814 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3815 maybe_present = true;
3818 /* The designated subtype must be elaborated as well, if it does
3819 not have its own freeze node. */
3820 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3821 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3822 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3823 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3824 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3825 NULL_TREE, false);
3827 break;
3829 case E_Access_Subtype:
3830 /* We treat this as identical to its base type; any constraint is
3831 meaningful only to the front-end. */
3832 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
3833 saved = true;
3835 /* The designated subtype must be elaborated as well, if it does
3836 not have its own freeze node. But designated subtypes created
3837 for constrained components of records with discriminants are
3838 not frozen by the front-end and not elaborated here, because
3839 their use may appear before the base type is frozen and it is
3840 not clear that they are needed in gigi. With the current model,
3841 there is no correct place where they could be elaborated. */
3842 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3843 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3844 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3845 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3847 /* If we are to defer elaborating incomplete types, make a dummy
3848 type node and elaborate it later. */
3849 if (defer_incomplete_level != 0)
3851 struct incomplete *p = XNEW (struct incomplete);
3853 p->old_type
3854 = make_dummy_type (Directly_Designated_Type (gnat_entity));
3855 p->full_type = Directly_Designated_Type (gnat_entity);
3856 p->next = defer_incomplete_list;
3857 defer_incomplete_list = p;
3859 else if (!IN (Ekind (Base_Type
3860 (Directly_Designated_Type (gnat_entity))),
3861 Incomplete_Or_Private_Kind))
3862 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3863 NULL_TREE, false);
3865 break;
3867 /* Subprogram Entities
3869 The following access functions are defined for subprograms:
3871 Etype Return type or Standard_Void_Type.
3872 First_Formal The first formal parameter.
3873 Is_Imported Indicates that the subprogram has appeared in
3874 an INTERFACE or IMPORT pragma. For now we
3875 assume that the external language is C.
3876 Is_Exported Likewise but for an EXPORT pragma.
3877 Is_Inlined True if the subprogram is to be inlined.
3879 Each parameter is first checked by calling must_pass_by_ref on its
3880 type to determine if it is passed by reference. For parameters which
3881 are copied in, if they are Ada In Out or Out parameters, their return
3882 value becomes part of a record which becomes the return type of the
3883 function (C function - note that this applies only to Ada procedures
3884 so there is no Ada return type). Additional code to store back the
3885 parameters will be generated on the caller side. This transformation
3886 is done here, not in the front-end.
3888 The intended result of the transformation can be seen from the
3889 equivalent source rewritings that follow:
3891 struct temp {int a,b};
3892 procedure P (A,B: In Out ...) is temp P (int A,B)
3893 begin {
3894 .. ..
3895 end P; return {A,B};
3898 temp t;
3899 P(X,Y); t = P(X,Y);
3900 X = t.a , Y = t.b;
3902 For subprogram types we need to perform mainly the same conversions to
3903 GCC form that are needed for procedures and function declarations. The
3904 only difference is that at the end, we make a type declaration instead
3905 of a function declaration. */
3907 case E_Subprogram_Type:
3908 case E_Function:
3909 case E_Procedure:
3911 tree gnu_ext_name
3912 = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name);
3913 enum inline_status_t inline_status
3914 = Has_Pragma_No_Inline (gnat_entity)
3915 ? is_suppressed
3916 : Has_Pragma_Inline_Always (gnat_entity)
3917 ? is_required
3918 : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled);
3919 bool public_flag = Is_Public (gnat_entity) || imported_p;
3920 /* Subprograms marked both Intrinsic and Always_Inline need not
3921 have a body of their own. */
3922 bool extern_flag
3923 = ((Is_Public (gnat_entity) && !definition)
3924 || imported_p
3925 || (Convention (gnat_entity) == Convention_Intrinsic
3926 && Has_Pragma_Inline_Always (gnat_entity)));
3927 tree gnu_param_list;
3929 /* A parameter may refer to this type, so defer completion of any
3930 incomplete types. */
3931 if (kind == E_Subprogram_Type && !definition)
3933 defer_incomplete_level++;
3934 this_deferred = true;
3937 /* If the subprogram has an alias, it is probably inherited, so
3938 we can use the original one. If the original "subprogram"
3939 is actually an enumeration literal, it may be the first use
3940 of its type, so we must elaborate that type now. */
3941 if (Present (Alias (gnat_entity)))
3943 const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
3945 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3946 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
3947 false);
3949 gnu_decl
3950 = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
3952 /* Elaborate any Itypes in the parameters of this entity. */
3953 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3954 Present (gnat_temp);
3955 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3956 if (Is_Itype (Etype (gnat_temp)))
3957 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
3959 /* Materialize renamed subprograms in the debugging information
3960 when the renamed object is compile time known. We can consider
3961 such renamings as imported declarations.
3963 Because the parameters in generics instantiation are generally
3964 materialized as renamings, we ofter end up having both the
3965 renamed subprogram and the renaming in the same context and with
3966 the same name: in this case, renaming is both useless debug-wise
3967 and potentially harmful as name resolution in the debugger could
3968 return twice the same entity! So avoid this case. */
3969 if (debug_info_p && !artificial_p
3970 && !(get_debug_scope (gnat_entity, NULL)
3971 == get_debug_scope (gnat_renamed, NULL)
3972 && Name_Equals (Chars (gnat_entity),
3973 Chars (gnat_renamed)))
3974 && Present (gnat_renamed)
3975 && (Ekind (gnat_renamed) == E_Function
3976 || Ekind (gnat_renamed) == E_Procedure)
3977 && gnu_decl
3978 && TREE_CODE (gnu_decl) == FUNCTION_DECL)
3980 tree decl = build_decl (input_location, IMPORTED_DECL,
3981 gnu_entity_name, void_type_node);
3982 IMPORTED_DECL_ASSOCIATED_DECL (decl) = gnu_decl;
3983 gnat_pushdecl (decl, gnat_entity);
3986 break;
3989 /* Get the GCC tree for the (underlying) subprogram type. If the
3990 entity is an actual subprogram, also get the parameter list. */
3991 gnu_type
3992 = gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
3993 &gnu_param_list);
3994 if (DECL_P (gnu_type))
3996 gnu_decl = gnu_type;
3997 gnu_type = TREE_TYPE (gnu_decl);
3998 break;
4001 /* Deal with platform-specific calling conventions. */
4002 if (Has_Stdcall_Convention (gnat_entity))
4003 prepend_one_attribute
4004 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4005 get_identifier ("stdcall"), NULL_TREE,
4006 gnat_entity);
4007 else if (Has_Thiscall_Convention (gnat_entity))
4008 prepend_one_attribute
4009 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4010 get_identifier ("thiscall"), NULL_TREE,
4011 gnat_entity);
4013 /* If we should request stack realignment for a foreign convention
4014 subprogram, do so. Note that this applies to task entry points
4015 in particular. */
4016 if (FOREIGN_FORCE_REALIGN_STACK
4017 && Has_Foreign_Convention (gnat_entity))
4018 prepend_one_attribute
4019 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4020 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4021 gnat_entity);
4023 /* Deal with a pragma Linker_Section on a subprogram. */
4024 if ((kind == E_Function || kind == E_Procedure)
4025 && Present (Linker_Section_Pragma (gnat_entity)))
4026 prepend_one_attribute_pragma (&attr_list,
4027 Linker_Section_Pragma (gnat_entity));
4029 /* If we are defining the subprogram and it has an Address clause
4030 we must get the address expression from the saved GCC tree for the
4031 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4032 the address expression here since the front-end has guaranteed
4033 in that case that the elaboration has no effects. If there is
4034 an Address clause and we are not defining the object, just
4035 make it a constant. */
4036 if (Present (Address_Clause (gnat_entity)))
4038 tree gnu_address = NULL_TREE;
4040 if (definition)
4041 gnu_address
4042 = (present_gnu_tree (gnat_entity)
4043 ? get_gnu_tree (gnat_entity)
4044 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4046 save_gnu_tree (gnat_entity, NULL_TREE, false);
4048 /* Convert the type of the object to a reference type that can
4049 alias everything as per RM 13.3(19). */
4050 gnu_type
4051 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4052 if (gnu_address)
4053 gnu_address = convert (gnu_type, gnu_address);
4055 gnu_decl
4056 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4057 gnu_address, false, Is_Public (gnat_entity),
4058 extern_flag, false, false, artificial_p,
4059 debug_info_p, NULL, gnat_entity);
4060 DECL_BY_REF_P (gnu_decl) = 1;
4063 /* If this is a mere subprogram type, just create the declaration. */
4064 else if (kind == E_Subprogram_Type)
4066 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4068 gnu_decl
4069 = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4070 debug_info_p, gnat_entity);
4073 /* Otherwise create the subprogram declaration with the external name,
4074 the type and the parameter list. However, if this a reference to
4075 the allocation routines, reuse the canonical declaration nodes as
4076 they come with special properties. */
4077 else
4079 if (extern_flag && gnu_ext_name == DECL_NAME (malloc_decl))
4080 gnu_decl = malloc_decl;
4081 else if (extern_flag && gnu_ext_name == DECL_NAME (realloc_decl))
4082 gnu_decl = realloc_decl;
4083 else
4085 gnu_decl
4086 = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4087 gnu_type, gnu_param_list,
4088 inline_status, public_flag,
4089 extern_flag, artificial_p,
4090 debug_info_p,
4091 definition && imported_p, attr_list,
4092 gnat_entity);
4094 DECL_STUBBED_P (gnu_decl)
4095 = (Convention (gnat_entity) == Convention_Stubbed);
4099 break;
4101 case E_Incomplete_Type:
4102 case E_Incomplete_Subtype:
4103 case E_Private_Type:
4104 case E_Private_Subtype:
4105 case E_Limited_Private_Type:
4106 case E_Limited_Private_Subtype:
4107 case E_Record_Type_With_Private:
4108 case E_Record_Subtype_With_Private:
4110 const bool is_from_limited_with
4111 = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
4112 /* Get the "full view" of this entity. If this is an incomplete
4113 entity from a limited with, treat its non-limited view as the
4114 full view. Otherwise, use either the full view or the underlying
4115 full view, whichever is present. This is used in all the tests
4116 below. */
4117 const Entity_Id full_view
4118 = is_from_limited_with
4119 ? Non_Limited_View (gnat_entity)
4120 : Present (Full_View (gnat_entity))
4121 ? Full_View (gnat_entity)
4122 : IN (kind, Private_Kind)
4123 ? Underlying_Full_View (gnat_entity)
4124 : Empty;
4126 /* If this is an incomplete type with no full view, it must be a Taft
4127 Amendment type or an incomplete type coming from a limited context,
4128 in which cases we return a dummy type. Otherwise, we just get the
4129 type from its Etype. */
4130 if (No (full_view))
4132 if (kind == E_Incomplete_Type)
4134 gnu_type = make_dummy_type (gnat_entity);
4135 gnu_decl = TYPE_STUB_DECL (gnu_type);
4137 else
4139 gnu_decl
4140 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
4141 maybe_present = true;
4145 /* Or else, if we already made a type for the full view, reuse it. */
4146 else if (present_gnu_tree (full_view))
4147 gnu_decl = get_gnu_tree (full_view);
4149 /* Or else, if we are not defining the type or there is no freeze
4150 node on it, get the type for the full view. Likewise if this is
4151 a limited_with'ed type not declared in the main unit, which can
4152 happen for incomplete formal types instantiated on a type coming
4153 from a limited_with clause. */
4154 else if (!definition
4155 || No (Freeze_Node (full_view))
4156 || (is_from_limited_with
4157 && !In_Extended_Main_Code_Unit (full_view)))
4159 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
4160 maybe_present = true;
4163 /* Otherwise, make a dummy type entry which will be replaced later.
4164 Save it as the full declaration's type so we can do any needed
4165 updates when we see it. */
4166 else
4168 gnu_type = make_dummy_type (gnat_entity);
4169 gnu_decl = TYPE_STUB_DECL (gnu_type);
4170 if (Has_Completion_In_Body (gnat_entity))
4171 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4172 save_gnu_tree (full_view, gnu_decl, false);
4175 break;
4177 case E_Class_Wide_Type:
4178 /* Class-wide types are always transformed into their root type. */
4179 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4180 maybe_present = true;
4181 break;
4183 case E_Protected_Type:
4184 case E_Protected_Subtype:
4185 case E_Task_Type:
4186 case E_Task_Subtype:
4187 /* If we are just annotating types and have no equivalent record type,
4188 just return void_type, except for root types that have discriminants
4189 because the discriminants will very likely be used in the declarative
4190 part of the associated body so they need to be translated. */
4191 if (type_annotate_only && gnat_equiv_type == gnat_entity)
4193 if (Has_Discriminants (gnat_entity)
4194 && Root_Type (gnat_entity) == gnat_entity)
4196 tree gnu_field_list = NULL_TREE;
4197 Entity_Id gnat_field;
4199 /* This is a minimal version of the E_Record_Type handling. */
4200 gnu_type = make_node (RECORD_TYPE);
4201 TYPE_NAME (gnu_type) = gnu_entity_name;
4203 for (gnat_field = First_Stored_Discriminant (gnat_entity);
4204 Present (gnat_field);
4205 gnat_field = Next_Stored_Discriminant (gnat_field))
4207 tree gnu_field
4208 = gnat_to_gnu_field (gnat_field, gnu_type, false,
4209 definition, debug_info_p);
4211 save_gnu_tree (gnat_field,
4212 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
4213 build0 (PLACEHOLDER_EXPR, gnu_type),
4214 gnu_field, NULL_TREE),
4215 true);
4217 DECL_CHAIN (gnu_field) = gnu_field_list;
4218 gnu_field_list = gnu_field;
4221 finish_record_type (gnu_type, nreverse (gnu_field_list), 0,
4222 false);
4224 else
4225 gnu_type = void_type_node;
4228 /* Concurrent types are always transformed into their record type. */
4229 else
4230 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4231 maybe_present = true;
4232 break;
4234 case E_Label:
4235 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4236 break;
4238 case E_Block:
4239 case E_Loop:
4240 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4241 we've already saved it, so we don't try to. */
4242 gnu_decl = error_mark_node;
4243 saved = true;
4244 break;
4246 case E_Abstract_State:
4247 /* This is a SPARK annotation that only reaches here when compiling in
4248 ASIS mode. */
4249 gcc_assert (type_annotate_only);
4250 gnu_decl = error_mark_node;
4251 saved = true;
4252 break;
4254 default:
4255 gcc_unreachable ();
4258 /* If we had a case where we evaluated another type and it might have
4259 defined this one, handle it here. */
4260 if (maybe_present && present_gnu_tree (gnat_entity))
4262 gnu_decl = get_gnu_tree (gnat_entity);
4263 saved = true;
4266 /* If we are processing a type and there is either no decl for it or
4267 we just made one, do some common processing for the type, such as
4268 handling alignment and possible padding. */
4269 if (is_type && (!gnu_decl || this_made_decl))
4271 gcc_assert (!TYPE_IS_DUMMY_P (gnu_type));
4273 /* Process the attributes, if not already done. Note that the type is
4274 already defined so we cannot pass true for IN_PLACE here. */
4275 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4277 /* Tell the middle-end that objects of tagged types are guaranteed to
4278 be properly aligned. This is necessary because conversions to the
4279 class-wide type are translated into conversions to the root type,
4280 which can be less aligned than some of its derived types. */
4281 if (Is_Tagged_Type (gnat_entity)
4282 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4283 TYPE_ALIGN_OK (gnu_type) = 1;
4285 /* Record whether the type is passed by reference. */
4286 if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4287 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4289 /* ??? Don't set the size for a String_Literal since it is either
4290 confirming or we don't handle it properly (if the low bound is
4291 non-constant). */
4292 if (!gnu_size && kind != E_String_Literal_Subtype)
4294 Uint gnat_size = Known_Esize (gnat_entity)
4295 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4296 gnu_size
4297 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4298 false, Has_Size_Clause (gnat_entity));
4301 /* If a size was specified, see if we can make a new type of that size
4302 by rearranging the type, for example from a fat to a thin pointer. */
4303 if (gnu_size)
4305 gnu_type
4306 = make_type_from_size (gnu_type, gnu_size,
4307 Has_Biased_Representation (gnat_entity));
4309 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4310 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4311 gnu_size = NULL_TREE;
4314 /* If the alignment has not already been processed and this is not
4315 an unconstrained array type, see if an alignment is specified.
4316 If not, we pick a default alignment for atomic objects. */
4317 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4319 else if (Known_Alignment (gnat_entity))
4321 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4322 TYPE_ALIGN (gnu_type));
4324 /* Warn on suspiciously large alignments. This should catch
4325 errors about the (alignment,byte)/(size,bit) discrepancy. */
4326 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4328 tree size;
4330 /* If a size was specified, take it into account. Otherwise
4331 use the RM size for records or unions as the type size has
4332 already been adjusted to the alignment. */
4333 if (gnu_size)
4334 size = gnu_size;
4335 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
4336 && !TYPE_FAT_POINTER_P (gnu_type))
4337 size = rm_size (gnu_type);
4338 else
4339 size = TYPE_SIZE (gnu_type);
4341 /* Consider an alignment as suspicious if the alignment/size
4342 ratio is greater or equal to the byte/bit ratio. */
4343 if (tree_fits_uhwi_p (size)
4344 && align >= tree_to_uhwi (size) * BITS_PER_UNIT)
4345 post_error_ne ("?suspiciously large alignment specified for&",
4346 Expression (Alignment_Clause (gnat_entity)),
4347 gnat_entity);
4350 else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size
4351 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
4352 && integer_pow2p (TYPE_SIZE (gnu_type)))
4353 align = MIN (BIGGEST_ALIGNMENT,
4354 tree_to_uhwi (TYPE_SIZE (gnu_type)));
4355 else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size
4356 && tree_fits_uhwi_p (gnu_size)
4357 && integer_pow2p (gnu_size))
4358 align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
4360 /* See if we need to pad the type. If we did, and made a record,
4361 the name of the new type may be changed. So get it back for
4362 us when we make the new TYPE_DECL below. */
4363 if (gnu_size || align > 0)
4364 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4365 false, !gnu_decl, definition, false);
4367 if (TYPE_IS_PADDING_P (gnu_type))
4368 gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
4370 /* Now set the RM size of the type. We cannot do it before padding
4371 because we need to accept arbitrary RM sizes on integral types. */
4372 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4374 /* If we are at global level, GCC will have applied variable_size to
4375 the type, but that won't have done anything. So, if it's not
4376 a constant or self-referential, call elaborate_expression_1 to
4377 make a variable for the size rather than calculating it each time.
4378 Handle both the RM size and the actual size. */
4379 if (TYPE_SIZE (gnu_type)
4380 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4381 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
4382 && global_bindings_p ())
4384 tree size = TYPE_SIZE (gnu_type);
4386 TYPE_SIZE (gnu_type)
4387 = elaborate_expression_1 (size, gnat_entity, "SIZE", definition,
4388 false);
4390 /* ??? For now, store the size as a multiple of the alignment in
4391 bytes so that we can see the alignment from the tree. */
4392 TYPE_SIZE_UNIT (gnu_type)
4393 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4394 "SIZE_A_UNIT", definition, false,
4395 TYPE_ALIGN (gnu_type));
4397 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4398 may not be marked by the call to create_type_decl below. */
4399 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4401 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4403 tree variant_part = get_variant_part (gnu_type);
4404 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4406 if (variant_part)
4408 tree union_type = TREE_TYPE (variant_part);
4409 tree offset = DECL_FIELD_OFFSET (variant_part);
4411 /* If the position of the variant part is constant, subtract
4412 it from the size of the type of the parent to get the new
4413 size. This manual CSE reduces the data size. */
4414 if (TREE_CODE (offset) == INTEGER_CST)
4416 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4417 TYPE_SIZE (union_type)
4418 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4419 bit_from_pos (offset, bitpos));
4420 TYPE_SIZE_UNIT (union_type)
4421 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4422 byte_from_pos (offset, bitpos));
4424 else
4426 TYPE_SIZE (union_type)
4427 = elaborate_expression_1 (TYPE_SIZE (union_type),
4428 gnat_entity, "VSIZE",
4429 definition, false);
4431 /* ??? For now, store the size as a multiple of the
4432 alignment in bytes so that we can see the alignment
4433 from the tree. */
4434 TYPE_SIZE_UNIT (union_type)
4435 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4436 gnat_entity, "VSIZE_A_UNIT",
4437 definition, false,
4438 TYPE_ALIGN (union_type));
4440 /* ??? For now, store the offset as a multiple of the
4441 alignment in bytes so that we can see the alignment
4442 from the tree. */
4443 DECL_FIELD_OFFSET (variant_part)
4444 = elaborate_expression_2 (offset, gnat_entity,
4445 "VOFFSET", definition, false,
4446 DECL_OFFSET_ALIGN
4447 (variant_part));
4450 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4451 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4454 if (operand_equal_p (ada_size, size, 0))
4455 ada_size = TYPE_SIZE (gnu_type);
4456 else
4457 ada_size
4458 = elaborate_expression_1 (ada_size, gnat_entity, "RM_SIZE",
4459 definition, false);
4460 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4464 /* Similarly, if this is a record type or subtype at global level, call
4465 elaborate_expression_2 on any field position. Skip any fields that
4466 we haven't made trees for to avoid problems with class-wide types. */
4467 if (IN (kind, Record_Kind) && global_bindings_p ())
4468 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4469 gnat_temp = Next_Entity (gnat_temp))
4470 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4472 tree gnu_field = get_gnu_tree (gnat_temp);
4474 /* ??? For now, store the offset as a multiple of the alignment
4475 in bytes so that we can see the alignment from the tree. */
4476 if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field))
4477 && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4479 DECL_FIELD_OFFSET (gnu_field)
4480 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4481 gnat_temp, "OFFSET", definition,
4482 false,
4483 DECL_OFFSET_ALIGN (gnu_field));
4485 /* ??? The context of gnu_field is not necessarily gnu_type
4486 so the MULT_EXPR node built above may not be marked by
4487 the call to create_type_decl below. */
4488 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4492 if (Is_Atomic_Or_VFA (gnat_entity))
4493 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
4495 /* If this is not an unconstrained array type, set some flags. */
4496 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4498 if (Present (Alignment_Clause (gnat_entity)))
4499 TYPE_USER_ALIGN (gnu_type) = 1;
4501 if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
4502 TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
4504 /* If it is passed by reference, force BLKmode to ensure that
4505 objects of this type will always be put in memory. */
4506 if (TYPE_MODE (gnu_type) != BLKmode
4507 && AGGREGATE_TYPE_P (gnu_type)
4508 && TYPE_BY_REFERENCE_P (gnu_type))
4509 SET_TYPE_MODE (gnu_type, BLKmode);
4512 /* If this is a derived type, relate its alias set to that of its parent
4513 to avoid troubles when a call to an inherited primitive is inlined in
4514 a context where a derived object is accessed. The inlined code works
4515 on the parent view so the resulting code may access the same object
4516 using both the parent and the derived alias sets, which thus have to
4517 conflict. As the same issue arises with component references, the
4518 parent alias set also has to conflict with composite types enclosing
4519 derived components. For instance, if we have:
4521 type D is new T;
4522 type R is record
4523 Component : D;
4524 end record;
4526 we want T to conflict with both D and R, in addition to R being a
4527 superset of D by record/component construction.
4529 One way to achieve this is to perform an alias set copy from the
4530 parent to the derived type. This is not quite appropriate, though,
4531 as we don't want separate derived types to conflict with each other:
4533 type I1 is new Integer;
4534 type I2 is new Integer;
4536 We want I1 and I2 to both conflict with Integer but we do not want
4537 I1 to conflict with I2, and an alias set copy on derivation would
4538 have that effect.
4540 The option chosen is to make the alias set of the derived type a
4541 superset of that of its parent type. It trivially fulfills the
4542 simple requirement for the Integer derivation example above, and
4543 the component case as well by superset transitivity:
4545 superset superset
4546 R ----------> D ----------> T
4548 However, for composite types, conversions between derived types are
4549 translated into VIEW_CONVERT_EXPRs so a sequence like:
4551 type Comp1 is new Comp;
4552 type Comp2 is new Comp;
4553 procedure Proc (C : Comp1);
4555 C : Comp2;
4556 Proc (Comp1 (C));
4558 is translated into:
4560 C : Comp2;
4561 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4563 and gimplified into:
4565 C : Comp2;
4566 Comp1 *C.0;
4567 C.0 = (Comp1 *) &C;
4568 Proc (C.0);
4570 i.e. generates code involving type punning. Therefore, Comp1 needs
4571 to conflict with Comp2 and an alias set copy is required.
4573 The language rules ensure the parent type is already frozen here. */
4574 if (kind != E_Subprogram_Type
4575 && Is_Derived_Type (gnat_entity)
4576 && !type_annotate_only)
4578 Entity_Id gnat_parent_type = Underlying_Type (Etype (gnat_entity));
4579 /* For constrained packed array subtypes, the implementation type is
4580 used instead of the nominal type. */
4581 if (kind == E_Array_Subtype
4582 && Is_Constrained (gnat_entity)
4583 && Present (Packed_Array_Impl_Type (gnat_parent_type)))
4584 gnat_parent_type = Packed_Array_Impl_Type (gnat_parent_type);
4585 relate_alias_sets (gnu_type, gnat_to_gnu_type (gnat_parent_type),
4586 Is_Composite_Type (gnat_entity)
4587 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4590 if (Treat_As_Volatile (gnat_entity))
4592 const int quals
4593 = TYPE_QUAL_VOLATILE
4594 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
4595 gnu_type = change_qualified_type (gnu_type, quals);
4598 if (!gnu_decl)
4599 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
4600 artificial_p, debug_info_p,
4601 gnat_entity);
4602 else
4604 TREE_TYPE (gnu_decl) = gnu_type;
4605 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4609 /* If we got a type that is not dummy, back-annotate the alignment of the
4610 type if not already in the tree. Likewise for the size, if any. */
4611 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4613 gnu_type = TREE_TYPE (gnu_decl);
4615 if (Unknown_Alignment (gnat_entity))
4617 unsigned int double_align, align;
4618 bool is_capped_double, align_clause;
4620 /* If the default alignment of "double" or larger scalar types is
4621 specifically capped and this is not an array with an alignment
4622 clause on the component type, return the cap. */
4623 if ((double_align = double_float_alignment) > 0)
4624 is_capped_double
4625 = is_double_float_or_array (gnat_entity, &align_clause);
4626 else if ((double_align = double_scalar_alignment) > 0)
4627 is_capped_double
4628 = is_double_scalar_or_array (gnat_entity, &align_clause);
4629 else
4630 is_capped_double = align_clause = false;
4632 if (is_capped_double && !align_clause)
4633 align = double_align;
4634 else
4635 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4637 Set_Alignment (gnat_entity, UI_From_Int (align));
4640 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4642 tree gnu_size = TYPE_SIZE (gnu_type);
4644 /* If the size is self-referential, annotate the maximum value. */
4645 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4646 gnu_size = max_size (gnu_size, true);
4648 /* If we are just annotating types and the type is tagged, the tag
4649 and the parent components are not generated by the front-end so
4650 alignment and sizes must be adjusted if there is no rep clause. */
4651 if (type_annotate_only
4652 && Is_Tagged_Type (gnat_entity)
4653 && Unknown_RM_Size (gnat_entity)
4654 && !VOID_TYPE_P (gnu_type)
4655 && (!TYPE_FIELDS (gnu_type)
4656 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
4658 tree offset;
4660 if (Is_Derived_Type (gnat_entity))
4662 Entity_Id gnat_parent = Etype (Base_Type (gnat_entity));
4663 offset = UI_To_gnu (Esize (gnat_parent), bitsizetype);
4664 Set_Alignment (gnat_entity, Alignment (gnat_parent));
4666 else
4668 unsigned int align
4669 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
4670 offset = bitsize_int (POINTER_SIZE);
4671 Set_Alignment (gnat_entity, UI_From_Int (align));
4674 if (TYPE_FIELDS (gnu_type))
4675 offset
4676 = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type)));
4678 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4679 gnu_size = round_up (gnu_size, POINTER_SIZE);
4680 Uint uint_size = annotate_value (gnu_size);
4681 Set_RM_Size (gnat_entity, uint_size);
4682 Set_Esize (gnat_entity, uint_size);
4685 /* If there is a rep clause, only adjust alignment and Esize. */
4686 else if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4688 unsigned int align
4689 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
4690 Set_Alignment (gnat_entity, UI_From_Int (align));
4691 gnu_size = round_up (gnu_size, POINTER_SIZE);
4692 Set_Esize (gnat_entity, annotate_value (gnu_size));
4695 /* Otherwise no adjustment is needed. */
4696 else
4697 Set_Esize (gnat_entity, annotate_value (gnu_size));
4700 if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
4701 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4704 /* If we haven't already, associate the ..._DECL node that we just made with
4705 the input GNAT entity node. */
4706 if (!saved)
4707 save_gnu_tree (gnat_entity, gnu_decl, false);
4709 /* Now we are sure gnat_entity has a corresponding ..._DECL node,
4710 eliminate as many deferred computations as possible. */
4711 process_deferred_decl_context (false);
4713 /* If this is an enumeration or floating-point type, we were not able to set
4714 the bounds since they refer to the type. These are always static. */
4715 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4716 || (kind == E_Floating_Point_Type))
4718 tree gnu_scalar_type = gnu_type;
4719 tree gnu_low_bound, gnu_high_bound;
4721 /* If this is a padded type, we need to use the underlying type. */
4722 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4723 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4725 /* If this is a floating point type and we haven't set a floating
4726 point type yet, use this in the evaluation of the bounds. */
4727 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4728 longest_float_type_node = gnu_scalar_type;
4730 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4731 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4733 if (kind == E_Enumeration_Type)
4735 /* Enumeration types have specific RM bounds. */
4736 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4737 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4739 else
4741 /* Floating-point types don't have specific RM bounds. */
4742 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4743 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4747 /* If we deferred processing of incomplete types, re-enable it. If there
4748 were no other disables and we have deferred types to process, do so. */
4749 if (this_deferred
4750 && --defer_incomplete_level == 0
4751 && defer_incomplete_list)
4753 struct incomplete *p, *next;
4755 /* We are back to level 0 for the deferring of incomplete types.
4756 But processing these incomplete types below may itself require
4757 deferring, so preserve what we have and restart from scratch. */
4758 p = defer_incomplete_list;
4759 defer_incomplete_list = NULL;
4761 for (; p; p = next)
4763 next = p->next;
4765 if (p->old_type)
4766 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4767 gnat_to_gnu_type (p->full_type));
4768 free (p);
4772 /* If we are not defining this type, see if it's on one of the lists of
4773 incomplete types. If so, handle the list entry now. */
4774 if (is_type && !definition)
4776 struct incomplete *p;
4778 for (p = defer_incomplete_list; p; p = p->next)
4779 if (p->old_type && p->full_type == gnat_entity)
4781 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4782 TREE_TYPE (gnu_decl));
4783 p->old_type = NULL_TREE;
4786 for (p = defer_limited_with_list; p; p = p->next)
4787 if (p->old_type
4788 && (Non_Limited_View (p->full_type) == gnat_entity
4789 || Full_View (p->full_type) == gnat_entity))
4791 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4792 TREE_TYPE (gnu_decl));
4793 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
4794 update_profiles_with (p->old_type);
4795 p->old_type = NULL_TREE;
4799 if (this_global)
4800 force_global--;
4802 /* If this is a packed array type whose original array type is itself
4803 an Itype without freeze node, make sure the latter is processed. */
4804 if (Is_Packed_Array_Impl_Type (gnat_entity)
4805 && Is_Itype (Original_Array_Type (gnat_entity))
4806 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4807 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4808 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, false);
4810 return gnu_decl;
4813 /* Similar, but if the returned value is a COMPONENT_REF, return the
4814 FIELD_DECL. */
4816 tree
4817 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4819 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
4821 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4822 gnu_field = TREE_OPERAND (gnu_field, 1);
4824 return gnu_field;
4827 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4828 the GCC type corresponding to that entity. */
4830 tree
4831 gnat_to_gnu_type (Entity_Id gnat_entity)
4833 tree gnu_decl;
4835 /* The back end never attempts to annotate generic types. */
4836 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4837 return void_type_node;
4839 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
4840 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4842 return TREE_TYPE (gnu_decl);
4845 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4846 the unpadded version of the GCC type corresponding to that entity. */
4848 tree
4849 get_unpadded_type (Entity_Id gnat_entity)
4851 tree type = gnat_to_gnu_type (gnat_entity);
4853 if (TYPE_IS_PADDING_P (type))
4854 type = TREE_TYPE (TYPE_FIELDS (type));
4856 return type;
4859 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
4860 a C++ imported method or equivalent.
4862 We use the predicate on 32-bit x86/Windows to find out whether we need to
4863 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
4864 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
4866 bool
4867 is_cplusplus_method (Entity_Id gnat_entity)
4869 /* A constructor is a method on the C++ side. We deal with it now because
4870 it is declared without the 'this' parameter in the sources and, although
4871 the front-end will create a version with the 'this' parameter for code
4872 generation purposes, we want to return true for both versions. */
4873 if (Is_Constructor (gnat_entity))
4874 return true;
4876 /* Check that the subprogram has C++ convention. */
4877 if (Convention (gnat_entity) != Convention_CPP)
4878 return false;
4880 /* And that the type of the first parameter (indirectly) has it too. */
4881 Entity_Id gnat_first = First_Formal (gnat_entity);
4882 if (No (gnat_first))
4883 return false;
4885 Entity_Id gnat_type = Etype (gnat_first);
4886 if (Is_Access_Type (gnat_type))
4887 gnat_type = Directly_Designated_Type (gnat_type);
4888 if (Convention (gnat_type) != Convention_CPP)
4889 return false;
4891 /* This is the main case: a C++ virtual method imported as a primitive
4892 operation of a tagged type. */
4893 if (Is_Dispatching_Operation (gnat_entity))
4894 return true;
4896 /* This is set on the E_Subprogram_Type built for a dispatching call. */
4897 if (Is_Dispatch_Table_Entity (gnat_entity))
4898 return true;
4900 /* A thunk needs to be handled like its associated primitive operation. */
4901 if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
4902 return true;
4904 /* Now on to the annoying case: a C++ non-virtual method, imported either
4905 as a non-primitive operation of a tagged type or as a primitive operation
4906 of an untagged type. We cannot reliably differentiate these cases from
4907 their static member or regular function equivalents in Ada, so we ask
4908 the C++ side through the mangled name of the function, as the implicit
4909 'this' parameter is not encoded in the mangled name of a method. */
4910 if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
4912 String_Pointer sp = { NULL, NULL };
4913 Get_External_Name (gnat_entity, false, sp);
4915 void *mem;
4916 struct demangle_component *cmp
4917 = cplus_demangle_v3_components (Name_Buffer,
4918 DMGL_GNU_V3
4919 | DMGL_TYPES
4920 | DMGL_PARAMS
4921 | DMGL_RET_DROP,
4922 &mem);
4923 if (!cmp)
4924 return false;
4926 /* We need to release MEM once we have a successful demangling. */
4927 bool ret = false;
4929 if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
4930 && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
4931 && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
4932 && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
4934 /* Make sure there is at least one parameter in C++ too. */
4935 if (cmp->u.s_binary.left)
4937 unsigned int n_ada_args = 0;
4938 do {
4939 n_ada_args++;
4940 gnat_first = Next_Formal (gnat_first);
4941 } while (Present (gnat_first));
4943 unsigned int n_cpp_args = 0;
4944 do {
4945 n_cpp_args++;
4946 cmp = cmp->u.s_binary.right;
4947 } while (cmp);
4949 if (n_cpp_args < n_ada_args)
4950 ret = true;
4952 else
4953 ret = true;
4956 free (mem);
4958 return ret;
4961 return false;
4964 /* Finalize the processing of From_Limited_With incomplete types. */
4966 void
4967 finalize_from_limited_with (void)
4969 struct incomplete *p, *next;
4971 p = defer_limited_with_list;
4972 defer_limited_with_list = NULL;
4974 for (; p; p = next)
4976 next = p->next;
4978 if (p->old_type)
4980 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4981 gnat_to_gnu_type (p->full_type));
4982 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
4983 update_profiles_with (p->old_type);
4986 free (p);
4990 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind
4991 of type (such E_Task_Type) that has a different type which Gigi uses
4992 for its representation. If the type does not have a special type for
4993 its representation, return GNAT_ENTITY. */
4995 Entity_Id
4996 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4998 Entity_Id gnat_equiv = gnat_entity;
5000 if (No (gnat_entity))
5001 return gnat_entity;
5003 switch (Ekind (gnat_entity))
5005 case E_Class_Wide_Subtype:
5006 if (Present (Equivalent_Type (gnat_entity)))
5007 gnat_equiv = Equivalent_Type (gnat_entity);
5008 break;
5010 case E_Access_Protected_Subprogram_Type:
5011 case E_Anonymous_Access_Protected_Subprogram_Type:
5012 if (Present (Equivalent_Type (gnat_entity)))
5013 gnat_equiv = Equivalent_Type (gnat_entity);
5014 break;
5016 case E_Class_Wide_Type:
5017 gnat_equiv = Root_Type (gnat_entity);
5018 break;
5020 case E_Protected_Type:
5021 case E_Protected_Subtype:
5022 case E_Task_Type:
5023 case E_Task_Subtype:
5024 if (Present (Corresponding_Record_Type (gnat_entity)))
5025 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5026 break;
5028 default:
5029 break;
5032 return gnat_equiv;
5035 /* Return a GCC tree for a type corresponding to the component type of the
5036 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5037 is for an array being defined. DEBUG_INFO_P is true if we need to write
5038 debug information for other types that we may create in the process. */
5040 static tree
5041 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5042 bool debug_info_p)
5044 const Entity_Id gnat_type = Component_Type (gnat_array);
5045 tree gnu_type = gnat_to_gnu_type (gnat_type);
5046 tree gnu_comp_size;
5047 unsigned int max_align;
5049 /* If an alignment is specified, use it as a cap on the component type
5050 so that it can be honored for the whole type. But ignore it for the
5051 original type of packed array types. */
5052 if (No (Packed_Array_Impl_Type (gnat_array))
5053 && Known_Alignment (gnat_array))
5054 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5055 else
5056 max_align = 0;
5058 /* Try to get a smaller form of the component if needed. */
5059 if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
5060 && !Is_Bit_Packed_Array (gnat_array)
5061 && !Has_Aliased_Components (gnat_array)
5062 && !Strict_Alignment (gnat_type)
5063 && RECORD_OR_UNION_TYPE_P (gnu_type)
5064 && !TYPE_FAT_POINTER_P (gnu_type)
5065 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
5066 gnu_type = make_packable_type (gnu_type, false, max_align);
5068 if (Has_Atomic_Components (gnat_array))
5069 check_ok_for_atomic_type (gnu_type, gnat_array, true);
5071 /* Get and validate any specified Component_Size. */
5072 gnu_comp_size
5073 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5074 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5075 true, Has_Component_Size_Clause (gnat_array));
5077 /* If the array has aliased components and the component size can be zero,
5078 force at least unit size to ensure that the components have distinct
5079 addresses. */
5080 if (!gnu_comp_size
5081 && Has_Aliased_Components (gnat_array)
5082 && (integer_zerop (TYPE_SIZE (gnu_type))
5083 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5084 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5085 gnu_comp_size
5086 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5088 /* If the component type is a RECORD_TYPE that has a self-referential size,
5089 then use the maximum size for the component size. */
5090 if (!gnu_comp_size
5091 && TREE_CODE (gnu_type) == RECORD_TYPE
5092 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5093 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5095 /* Honor the component size. This is not needed for bit-packed arrays. */
5096 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5098 tree orig_type = gnu_type;
5100 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5101 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5102 gnu_type = orig_type;
5103 else
5104 orig_type = gnu_type;
5106 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5107 true, false, definition, true);
5109 /* If a padding record was made, declare it now since it will never be
5110 declared otherwise. This is necessary to ensure that its subtrees
5111 are properly marked. */
5112 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5113 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5114 gnat_array);
5117 /* If the component type is a padded type made for a non-bit-packed array
5118 of scalars with reverse storage order, we need to propagate the reverse
5119 storage order to the padding type since it is the innermost enclosing
5120 aggregate type around the scalar. */
5121 if (TYPE_IS_PADDING_P (gnu_type)
5122 && Reverse_Storage_Order (gnat_array)
5123 && !Is_Bit_Packed_Array (gnat_array)
5124 && Is_Scalar_Type (gnat_type))
5125 gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
5127 if (Has_Volatile_Components (gnat_array))
5129 const int quals
5130 = TYPE_QUAL_VOLATILE
5131 | (Has_Atomic_Components (gnat_array) ? TYPE_QUAL_ATOMIC : 0);
5132 gnu_type = change_qualified_type (gnu_type, quals);
5135 return gnu_type;
5138 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
5139 in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
5140 the type of the parameter. FIRST is true if this is the first parameter in
5141 the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
5142 the copy-in copy-out implementation mechanism.
5144 The returned tree is a PARM_DECL, except for the cases where no parameter
5145 needs to be actually passed to the subprogram; the type of this "shadow"
5146 parameter is then returned instead. */
5148 static tree
5149 gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
5150 Entity_Id gnat_subprog, bool *cico)
5152 Entity_Id gnat_param_type = Etype (gnat_param);
5153 Mechanism_Type mech = Mechanism (gnat_param);
5154 tree gnu_param_name = get_entity_name (gnat_param);
5155 bool foreign = Has_Foreign_Convention (gnat_subprog);
5156 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5157 /* The parameter can be indirectly modified if its address is taken. */
5158 bool ro_param = in_param && !Address_Taken (gnat_param);
5159 bool by_return = false, by_component_ptr = false;
5160 bool by_ref = false;
5161 bool restricted_aliasing_p = false;
5162 location_t saved_location = input_location;
5163 tree gnu_param;
5165 /* Make sure to use the proper SLOC for vector ABI warnings. */
5166 if (VECTOR_TYPE_P (gnu_param_type))
5167 Sloc_to_locus (Sloc (gnat_subprog), &input_location);
5169 /* Builtins are expanded inline and there is no real call sequence involved.
5170 So the type expected by the underlying expander is always the type of the
5171 argument "as is". */
5172 if (Convention (gnat_subprog) == Convention_Intrinsic
5173 && Present (Interface_Name (gnat_subprog)))
5174 mech = By_Copy;
5176 /* Handle the first parameter of a valued procedure specially: it's a copy
5177 mechanism for which the parameter is never allocated. */
5178 else if (first && Is_Valued_Procedure (gnat_subprog))
5180 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5181 mech = By_Copy;
5182 by_return = true;
5185 /* Or else, see if a Mechanism was supplied that forced this parameter
5186 to be passed one way or another. */
5187 else if (mech == Default || mech == By_Copy || mech == By_Reference)
5190 /* Positive mechanism means by copy for sufficiently small parameters. */
5191 else if (mech > 0)
5193 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
5194 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
5195 || compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
5196 mech = By_Reference;
5197 else
5198 mech = By_Copy;
5201 /* Otherwise, it's an unsupported mechanism so error out. */
5202 else
5204 post_error ("unsupported mechanism for&", gnat_param);
5205 mech = Default;
5208 /* If this is either a foreign function or if the underlying type won't
5209 be passed by reference and is as aligned as the original type, strip
5210 off possible padding type. */
5211 if (TYPE_IS_PADDING_P (gnu_param_type))
5213 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5215 if (foreign
5216 || (!must_pass_by_ref (unpadded_type)
5217 && mech != By_Reference
5218 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))
5219 && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
5220 gnu_param_type = unpadded_type;
5223 /* If this is a read-only parameter, make a variant of the type that is
5224 read-only. ??? However, if this is a self-referential type, the type
5225 can be very complex, so skip it for now. */
5226 if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5227 gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5229 /* For foreign conventions, pass arrays as pointers to the element type.
5230 First check for unconstrained array and get the underlying array. */
5231 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5232 gnu_param_type
5233 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5235 /* Arrays are passed as pointers to element type for foreign conventions. */
5236 if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5238 /* Strip off any multi-dimensional entries, then strip
5239 off the last array to get the component type. */
5240 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5241 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5242 gnu_param_type = TREE_TYPE (gnu_param_type);
5244 by_component_ptr = true;
5245 gnu_param_type = TREE_TYPE (gnu_param_type);
5247 if (ro_param)
5248 gnu_param_type
5249 = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5251 gnu_param_type = build_pointer_type (gnu_param_type);
5254 /* Fat pointers are passed as thin pointers for foreign conventions. */
5255 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5256 gnu_param_type
5257 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5259 /* If we were requested or muss pass by reference, do so.
5260 If we were requested to pass by copy, do so.
5261 Otherwise, for foreign conventions, pass In Out or Out parameters
5262 or aggregates by reference. For COBOL and Fortran, pass all
5263 integer and FP types that way too. For Convention Ada, use
5264 the standard Ada default. */
5265 else if (mech == By_Reference
5266 || must_pass_by_ref (gnu_param_type)
5267 || (mech != By_Copy
5268 && ((foreign
5269 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5270 || (foreign
5271 && (Convention (gnat_subprog) == Convention_Fortran
5272 || Convention (gnat_subprog) == Convention_COBOL)
5273 && (INTEGRAL_TYPE_P (gnu_param_type)
5274 || FLOAT_TYPE_P (gnu_param_type)))
5275 || (!foreign
5276 && default_pass_by_ref (gnu_param_type)))))
5278 /* We take advantage of 6.2(12) by considering that references built for
5279 parameters whose type isn't by-ref and for which the mechanism hasn't
5280 been forced to by-ref allow only a restricted form of aliasing. */
5281 restricted_aliasing_p
5282 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5283 gnu_param_type = build_reference_type (gnu_param_type);
5284 by_ref = true;
5287 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5288 else if (!in_param)
5289 *cico = true;
5291 input_location = saved_location;
5293 if (mech == By_Copy && (by_ref || by_component_ptr))
5294 post_error ("?cannot pass & by copy", gnat_param);
5296 /* If this is an Out parameter that isn't passed by reference and isn't
5297 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5298 it will be a VAR_DECL created when we process the procedure, so just
5299 return its type. For the special parameter of a valued procedure,
5300 never pass it in.
5302 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5303 Out parameters with discriminants or implicit initial values to be
5304 handled like In Out parameters. These type are normally built as
5305 aggregates, hence passed by reference, except for some packed arrays
5306 which end up encoded in special integer types. Note that scalars can
5307 be given implicit initial values using the Default_Value aspect.
5309 The exception we need to make is then for packed arrays of records
5310 with discriminants or implicit initial values. We have no light/easy
5311 way to check for the latter case, so we merely check for packed arrays
5312 of records. This may lead to useless copy-in operations, but in very
5313 rare cases only, as these would be exceptions in a set of already
5314 exceptional situations. */
5315 if (Ekind (gnat_param) == E_Out_Parameter
5316 && !by_ref
5317 && (by_return
5318 || (!POINTER_TYPE_P (gnu_param_type)
5319 && !AGGREGATE_TYPE_P (gnu_param_type)
5320 && !Has_Default_Aspect (gnat_param_type)))
5321 && !(Is_Array_Type (gnat_param_type)
5322 && Is_Packed (gnat_param_type)
5323 && Is_Composite_Type (Component_Type (gnat_param_type))))
5324 return gnu_param_type;
5326 gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
5327 TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
5328 DECL_BY_REF_P (gnu_param) = by_ref;
5329 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5330 DECL_POINTS_TO_READONLY_P (gnu_param)
5331 = (ro_param && (by_ref || by_component_ptr));
5332 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5333 DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
5334 Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
5336 /* If no Mechanism was specified, indicate what we're using, then
5337 back-annotate it. */
5338 if (mech == Default)
5339 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5341 Set_Mechanism (gnat_param, mech);
5342 return gnu_param;
5345 /* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
5346 GNAT_SUBPROG is updated when GNU_TYPE is completed.
5348 Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
5349 the corresponding profile, which means that, by the time the freeze node
5350 of the subprogram is encountered, types involved in its profile may still
5351 be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
5352 the freeze node of types involved in its profile, either types of formal
5353 parameters or the return type. */
5355 static void
5356 associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
5358 gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
5360 struct tree_entity_vec_map in;
5361 in.base.from = gnu_type;
5362 struct tree_entity_vec_map **slot
5363 = dummy_to_subprog_map->find_slot (&in, INSERT);
5364 if (!*slot)
5366 tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
5367 e->base.from = gnu_type;
5368 e->to = NULL;
5369 *slot = e;
5372 /* Even if there is already a slot for GNU_TYPE, we need to set the flag
5373 because the vector might have been just emptied by update_profiles_with.
5374 This can happen when there are 2 freeze nodes associated with different
5375 views of the same type; the type will be really complete only after the
5376 second freeze node is encountered. */
5377 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
5379 vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
5381 /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
5382 since this would mean updating twice its profile. */
5383 if (v)
5385 const unsigned len = v->length ();
5386 unsigned int l = 0, u = len;
5388 /* Entity_Id is a simple integer so we can implement a stable order on
5389 the vector with an ordered insertion scheme and binary search. */
5390 while (l < u)
5392 unsigned int m = (l + u) / 2;
5393 int diff = (int) (*v)[m] - (int) gnat_subprog;
5394 if (diff > 0)
5395 u = m;
5396 else if (diff < 0)
5397 l = m + 1;
5398 else
5399 return;
5402 /* l == u and therefore is the insertion point. */
5403 vec_safe_insert (v, l, gnat_subprog);
5405 else
5406 vec_safe_push (v, gnat_subprog);
5408 (*slot)->to = v;
5411 /* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
5413 static void
5414 update_profile (Entity_Id gnat_subprog)
5416 tree gnu_param_list;
5417 tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
5418 Needs_Debug_Info (gnat_subprog),
5419 &gnu_param_list);
5420 if (DECL_P (gnu_type))
5422 /* Builtins cannot have their address taken so we can reset them. */
5423 gcc_assert (DECL_BUILT_IN (gnu_type));
5424 save_gnu_tree (gnat_subprog, NULL_TREE, false);
5425 save_gnu_tree (gnat_subprog, gnu_type, false);
5426 return;
5429 tree gnu_subprog = get_gnu_tree (gnat_subprog);
5431 TREE_TYPE (gnu_subprog) = gnu_type;
5433 /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
5434 and needs to be adjusted too. */
5435 if (Ekind (gnat_subprog) != E_Subprogram_Type)
5437 tree gnu_entity_name = get_entity_name (gnat_subprog);
5438 tree gnu_ext_name
5439 = gnu_ext_name_for_subprog (gnat_subprog, gnu_entity_name);
5441 DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
5442 finish_subprog_decl (gnu_subprog, gnu_ext_name, gnu_type);
5446 /* Update the GCC trees previously built for the profiles involving GNU_TYPE,
5447 a dummy type which appears in profiles. */
5449 void
5450 update_profiles_with (tree gnu_type)
5452 struct tree_entity_vec_map in;
5453 in.base.from = gnu_type;
5454 struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
5455 gcc_assert (e);
5456 vec<Entity_Id, va_gc_atomic> *v = e->to;
5457 e->to = NULL;
5459 /* The flag needs to be reset before calling update_profile, in case
5460 associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
5461 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
5463 unsigned int i;
5464 Entity_Id *iter;
5465 FOR_EACH_VEC_ELT (*v, i, iter)
5466 update_profile (*iter);
5468 vec_free (v);
5471 /* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
5473 Ada 2012 (AI05-0151) says that incomplete types coming from a limited
5474 context may now appear as parameter and result types. As a consequence,
5475 we may need to defer their translation until after a freeze node is seen
5476 or to the end of the current unit. We also aim at handling temporarily
5477 incomplete types created by the usual delayed elaboration scheme. */
5479 static tree
5480 gnat_to_gnu_profile_type (Entity_Id gnat_type)
5482 /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
5483 so the rationale is exposed in that place. These processings probably
5484 ought to be merged at some point. */
5485 Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
5486 const bool is_from_limited_with
5487 = (IN (Ekind (gnat_equiv), Incomplete_Kind)
5488 && From_Limited_With (gnat_equiv));
5489 Entity_Id gnat_full_direct_first
5490 = (is_from_limited_with
5491 ? Non_Limited_View (gnat_equiv)
5492 : (IN (Ekind (gnat_equiv), Incomplete_Or_Private_Kind)
5493 ? Full_View (gnat_equiv) : Empty));
5494 Entity_Id gnat_full_direct
5495 = ((is_from_limited_with
5496 && Present (gnat_full_direct_first)
5497 && IN (Ekind (gnat_full_direct_first), Private_Kind))
5498 ? Full_View (gnat_full_direct_first)
5499 : gnat_full_direct_first);
5500 Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
5501 Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
5502 const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
5503 tree gnu_type;
5505 if (Present (gnat_full) && present_gnu_tree (gnat_full))
5506 gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
5508 else if (is_from_limited_with
5509 && ((!in_main_unit
5510 && !present_gnu_tree (gnat_equiv)
5511 && Present (gnat_full)
5512 && (Is_Record_Type (gnat_full)
5513 || Is_Array_Type (gnat_full)
5514 || Is_Access_Type (gnat_full)))
5515 || (in_main_unit && Present (Freeze_Node (gnat_rep)))))
5517 gnu_type = make_dummy_type (gnat_equiv);
5519 if (!in_main_unit)
5521 struct incomplete *p = XNEW (struct incomplete);
5523 p->old_type = gnu_type;
5524 p->full_type = gnat_equiv;
5525 p->next = defer_limited_with_list;
5526 defer_limited_with_list = p;
5530 else if (type_annotate_only && No (gnat_equiv))
5531 gnu_type = void_type_node;
5533 else
5534 gnu_type = gnat_to_gnu_type (gnat_equiv);
5536 /* Access-to-unconstrained-array types need a special treatment. */
5537 if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
5539 if (!TYPE_POINTER_TO (gnu_type))
5540 build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
5543 return gnu_type;
5546 /* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
5547 DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
5548 is true if we need to write debug information for other types that we may
5549 create in the process. Also set PARAM_LIST to the list of parameters.
5550 If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
5551 directly instead of its type. */
5553 static tree
5554 gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
5555 bool debug_info_p, tree *param_list)
5557 const Entity_Kind kind = Ekind (gnat_subprog);
5558 Entity_Id gnat_return_type = Etype (gnat_subprog);
5559 Entity_Id gnat_param;
5560 tree gnu_type = present_gnu_tree (gnat_subprog)
5561 ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
5562 tree gnu_return_type;
5563 tree gnu_param_type_list = NULL_TREE;
5564 tree gnu_param_list = NULL_TREE;
5565 /* Non-null for subprograms containing parameters passed by copy-in copy-out
5566 (In Out or Out parameters not passed by reference), in which case it is
5567 the list of nodes used to specify the values of the In Out/Out parameters
5568 that are returned as a record upon procedure return. The TREE_PURPOSE of
5569 an element of this list is a FIELD_DECL of the record and the TREE_VALUE
5570 is the PARM_DECL corresponding to that field. This list will be saved in
5571 the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
5572 tree gnu_cico_list = NULL_TREE;
5573 tree gnu_cico_return_type = NULL_TREE;
5574 /* Fields in return type of procedure with copy-in copy-out parameters. */
5575 tree gnu_field_list = NULL_TREE;
5576 /* The semantics of "pure" in Ada essentially matches that of "const"
5577 in the back-end. In particular, both properties are orthogonal to
5578 the "nothrow" property if the EH circuitry is explicit in the
5579 internal representation of the back-end. If we are to completely
5580 hide the EH circuitry from it, we need to declare that calls to pure
5581 Ada subprograms that can throw have side effects since they can
5582 trigger an "abnormal" transfer of control flow; thus they can be
5583 neither "const" nor "pure" in the back-end sense. */
5584 bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
5585 bool return_by_direct_ref_p = false;
5586 bool return_by_invisi_ref_p = false;
5587 bool return_unconstrained_p = false;
5588 bool incomplete_profile_p = false;
5589 unsigned int num;
5591 /* Look into the return type and get its associated GCC tree if it is not
5592 void, and then compute various flags for the subprogram type. But make
5593 sure not to do this processing multiple times. */
5594 if (Ekind (gnat_return_type) == E_Void)
5595 gnu_return_type = void_type_node;
5597 else if (gnu_type
5598 && TREE_CODE (gnu_type) == FUNCTION_TYPE
5599 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
5601 gnu_return_type = TREE_TYPE (gnu_type);
5602 return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
5603 return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
5604 return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
5607 else
5609 /* For foreign convention subprograms, return System.Address as void *
5610 or equivalent. Note that this comprises GCC builtins. */
5611 if (Has_Foreign_Convention (gnat_subprog)
5612 && Is_Descendant_Of_Address (gnat_return_type))
5613 gnu_return_type = ptr_type_node;
5614 else
5615 gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
5617 /* If this function returns by reference, make the actual return type
5618 the reference type and make a note of that. */
5619 if (Returns_By_Ref (gnat_subprog))
5621 gnu_return_type = build_reference_type (gnu_return_type);
5622 return_by_direct_ref_p = true;
5625 /* If the return type is an unconstrained array type, the return value
5626 will be allocated on the secondary stack so the actual return type
5627 is the fat pointer type. */
5628 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
5630 gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
5631 return_unconstrained_p = true;
5634 /* This is the same unconstrained array case, but for a dummy type. */
5635 else if (TYPE_REFERENCE_TO (gnu_return_type)
5636 && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
5638 gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
5639 return_unconstrained_p = true;
5642 /* Likewise, if the return type requires a transient scope, the return
5643 value will also be allocated on the secondary stack so the actual
5644 return type is the reference type. */
5645 else if (Requires_Transient_Scope (gnat_return_type))
5647 gnu_return_type = build_reference_type (gnu_return_type);
5648 return_unconstrained_p = true;
5651 /* If the Mechanism is By_Reference, ensure this function uses the
5652 target's by-invisible-reference mechanism, which may not be the
5653 same as above (e.g. it might be passing an extra parameter). */
5654 else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
5655 return_by_invisi_ref_p = true;
5657 /* Likewise, if the return type is itself By_Reference. */
5658 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
5659 return_by_invisi_ref_p = true;
5661 /* If the type is a padded type and the underlying type would not be
5662 passed by reference or the function has a foreign convention, return
5663 the underlying type. */
5664 else if (TYPE_IS_PADDING_P (gnu_return_type)
5665 && (!default_pass_by_ref
5666 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
5667 || Has_Foreign_Convention (gnat_subprog)))
5668 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
5670 /* If the return type is unconstrained, it must have a maximum size.
5671 Use the padded type as the effective return type. And ensure the
5672 function uses the target's by-invisible-reference mechanism to
5673 avoid copying too much data when it returns. */
5674 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
5676 tree orig_type = gnu_return_type;
5677 tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
5679 /* If the size overflows to 0, set it to an arbitrary positive
5680 value so that assignments in the type are preserved. Their
5681 actual size is independent of this positive value. */
5682 if (TREE_CODE (max_return_size) == INTEGER_CST
5683 && TREE_OVERFLOW (max_return_size)
5684 && integer_zerop (max_return_size))
5686 max_return_size = copy_node (bitsize_unit_node);
5687 TREE_OVERFLOW (max_return_size) = 1;
5690 gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
5691 0, gnat_subprog, false, false,
5692 definition, true);
5694 /* Declare it now since it will never be declared otherwise. This
5695 is necessary to ensure that its subtrees are properly marked. */
5696 if (gnu_return_type != orig_type
5697 && !DECL_P (TYPE_NAME (gnu_return_type)))
5698 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
5699 true, debug_info_p, gnat_subprog);
5701 return_by_invisi_ref_p = true;
5704 /* If the return type has a size that overflows, we usually cannot have
5705 a function that returns that type. This usage doesn't really make
5706 sense anyway, so issue an error here. */
5707 if (!return_by_invisi_ref_p
5708 && TYPE_SIZE_UNIT (gnu_return_type)
5709 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
5710 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
5712 post_error ("cannot return type whose size overflows", gnat_subprog);
5713 gnu_return_type = copy_type (gnu_return_type);
5714 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
5715 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
5718 /* If the return type is incomplete, there are 2 cases: if the function
5719 returns by reference, then the return type is only linked indirectly
5720 in the profile, so the profile can be seen as complete since it need
5721 not be further modified, only the reference types need be adjusted;
5722 otherwise the profile is incomplete and need be adjusted too. */
5723 if (TYPE_IS_DUMMY_P (gnu_return_type))
5725 associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
5726 incomplete_profile_p = true;
5729 if (kind == E_Function)
5730 Set_Mechanism (gnat_subprog, return_unconstrained_p
5731 || return_by_direct_ref_p
5732 || return_by_invisi_ref_p
5733 ? By_Reference : By_Copy);
5736 /* A procedure (something that doesn't return anything) shouldn't be
5737 considered const since there would be no reason for calling such a
5738 subprogram. Note that procedures with Out (or In Out) parameters
5739 have already been converted into a function with a return type.
5740 Similarly, if the function returns an unconstrained type, then the
5741 function will allocate the return value on the secondary stack and
5742 thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
5743 if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
5744 const_flag = false;
5746 /* Loop over the parameters and get their associated GCC tree. While doing
5747 this, build a copy-in copy-out structure if we need one. */
5748 for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
5749 Present (gnat_param);
5750 gnat_param = Next_Formal_With_Extras (gnat_param), num++)
5752 const bool mech_is_by_ref
5753 = Mechanism (gnat_param) == By_Reference
5754 && !(num == 0 && Is_Valued_Procedure (gnat_subprog));
5755 tree gnu_param_name = get_entity_name (gnat_param);
5756 tree gnu_param, gnu_param_type;
5757 bool cico = false;
5759 /* Fetch an existing parameter with complete type and reuse it. But we
5760 didn't save the CICO property so we can only do it for In parameters
5761 or parameters passed by reference. */
5762 if ((Ekind (gnat_param) == E_In_Parameter || mech_is_by_ref)
5763 && present_gnu_tree (gnat_param)
5764 && (gnu_param = get_gnu_tree (gnat_param))
5765 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param)))
5767 DECL_CHAIN (gnu_param) = NULL_TREE;
5768 gnu_param_type = TREE_TYPE (gnu_param);
5771 /* Otherwise translate the parameter type and act accordingly. */
5772 else
5774 Entity_Id gnat_param_type = Etype (gnat_param);
5776 /* For foreign convention subprograms, pass System.Address as void *
5777 or equivalent. Note that this comprises GCC builtins. */
5778 if (Has_Foreign_Convention (gnat_subprog)
5779 && Is_Descendant_Of_Address (gnat_param_type))
5780 gnu_param_type = ptr_type_node;
5781 else
5782 gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
5784 /* If the parameter type is incomplete, there are 2 cases: if it is
5785 passed by reference, then the type is only linked indirectly in
5786 the profile, so the profile can be seen as complete since it need
5787 not be further modified, only the reference type need be adjusted;
5788 otherwise the profile is incomplete and need be adjusted too. */
5789 if (TYPE_IS_DUMMY_P (gnu_param_type))
5791 Node_Id gnat_decl;
5793 if (mech_is_by_ref
5794 || (TYPE_REFERENCE_TO (gnu_param_type)
5795 && TYPE_IS_FAT_POINTER_P
5796 (TYPE_REFERENCE_TO (gnu_param_type)))
5797 || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
5799 gnu_param_type = build_reference_type (gnu_param_type);
5800 gnu_param
5801 = create_param_decl (gnu_param_name, gnu_param_type);
5802 TREE_READONLY (gnu_param) = 1;
5803 DECL_BY_REF_P (gnu_param) = 1;
5804 DECL_POINTS_TO_READONLY_P (gnu_param)
5805 = (Ekind (gnat_param) == E_In_Parameter
5806 && !Address_Taken (gnat_param));
5807 Set_Mechanism (gnat_param, By_Reference);
5808 Sloc_to_locus (Sloc (gnat_param),
5809 &DECL_SOURCE_LOCATION (gnu_param));
5812 /* ??? This is a kludge to support null procedures in spec taking
5813 a parameter with an untagged incomplete type coming from a
5814 limited context. The front-end creates a body without knowing
5815 anything about the non-limited view, which is illegal Ada and
5816 cannot be supported. Create a parameter with a fake type. */
5817 else if (kind == E_Procedure
5818 && (gnat_decl = Parent (gnat_subprog))
5819 && Nkind (gnat_decl) == N_Procedure_Specification
5820 && Null_Present (gnat_decl)
5821 && IN (Ekind (gnat_param_type), Incomplete_Kind))
5822 gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
5824 else
5826 /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
5827 Call_to_gnu will stop if it encounters the PARM_DECL. */
5828 gnu_param
5829 = build_decl (input_location, PARM_DECL, gnu_param_name,
5830 gnu_param_type);
5831 associate_subprog_with_dummy_type (gnat_subprog,
5832 gnu_param_type);
5833 incomplete_profile_p = true;
5837 /* Otherwise build the parameter declaration normally. */
5838 else
5840 gnu_param
5841 = gnat_to_gnu_param (gnat_param, gnu_param_type, num == 0,
5842 gnat_subprog, &cico);
5844 /* We are returned either a PARM_DECL or a type if no parameter
5845 needs to be passed; in either case, adjust the type. */
5846 if (DECL_P (gnu_param))
5847 gnu_param_type = TREE_TYPE (gnu_param);
5848 else
5850 gnu_param_type = gnu_param;
5851 gnu_param = NULL_TREE;
5856 /* If we have a GCC tree for the parameter, register it. */
5857 save_gnu_tree (gnat_param, NULL_TREE, false);
5858 if (gnu_param)
5860 gnu_param_type_list
5861 = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
5862 gnu_param_list = chainon (gnu_param, gnu_param_list);
5863 save_gnu_tree (gnat_param, gnu_param, false);
5865 /* If a parameter is a pointer, a function may modify memory through
5866 it and thus shouldn't be considered a const function. Also, the
5867 memory may be modified between two calls, so they can't be CSE'ed.
5868 The latter case also handles by-ref parameters. */
5869 if (POINTER_TYPE_P (gnu_param_type)
5870 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
5871 const_flag = false;
5874 /* If the parameter uses the copy-in copy-out mechanism, allocate a field
5875 for it in the return type and register the association. */
5876 if (cico && !incomplete_profile_p)
5878 if (!gnu_cico_list)
5880 gnu_cico_return_type = make_node (RECORD_TYPE);
5882 /* If this is a function, we also need a field for the
5883 return value to be placed. */
5884 if (!VOID_TYPE_P (gnu_return_type))
5886 tree gnu_field
5887 = create_field_decl (get_identifier ("RETVAL"),
5888 gnu_return_type,
5889 gnu_cico_return_type, NULL_TREE,
5890 NULL_TREE, 0, 0);
5891 Sloc_to_locus (Sloc (gnat_subprog),
5892 &DECL_SOURCE_LOCATION (gnu_field));
5893 gnu_field_list = gnu_field;
5894 gnu_cico_list
5895 = tree_cons (gnu_field, void_type_node, NULL_TREE);
5898 TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN");
5899 /* Set a default alignment to speed up accesses. But we should
5900 not increase the size of the structure too much, lest it does
5901 not fit in return registers anymore. */
5902 SET_TYPE_ALIGN (gnu_cico_return_type,
5903 get_mode_alignment (ptr_mode));
5906 tree gnu_field
5907 = create_field_decl (gnu_param_name, gnu_param_type,
5908 gnu_cico_return_type, NULL_TREE, NULL_TREE,
5909 0, 0);
5910 Sloc_to_locus (Sloc (gnat_param),
5911 &DECL_SOURCE_LOCATION (gnu_field));
5912 DECL_CHAIN (gnu_field) = gnu_field_list;
5913 gnu_field_list = gnu_field;
5914 gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
5918 /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
5919 and finish up the return type. */
5920 if (gnu_cico_list && !incomplete_profile_p)
5922 /* If we have a CICO list but it has only one entry, we convert
5923 this function into a function that returns this object. */
5924 if (list_length (gnu_cico_list) == 1)
5925 gnu_cico_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
5927 /* Do not finalize the return type if the subprogram is stubbed
5928 since structures are incomplete for the back-end. */
5929 else if (Convention (gnat_subprog) != Convention_Stubbed)
5931 finish_record_type (gnu_cico_return_type, nreverse (gnu_field_list),
5932 0, false);
5934 /* Try to promote the mode of the return type if it is passed
5935 in registers, again to speed up accesses. */
5936 if (TYPE_MODE (gnu_cico_return_type) == BLKmode
5937 && !targetm.calls.return_in_memory (gnu_cico_return_type,
5938 NULL_TREE))
5940 unsigned int size
5941 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type));
5942 unsigned int i = BITS_PER_UNIT;
5943 scalar_int_mode mode;
5945 while (i < size)
5946 i <<= 1;
5947 if (int_mode_for_size (i, 0).exists (&mode))
5949 SET_TYPE_MODE (gnu_cico_return_type, mode);
5950 SET_TYPE_ALIGN (gnu_cico_return_type,
5951 GET_MODE_ALIGNMENT (mode));
5952 TYPE_SIZE (gnu_cico_return_type)
5953 = bitsize_int (GET_MODE_BITSIZE (mode));
5954 TYPE_SIZE_UNIT (gnu_cico_return_type)
5955 = size_int (GET_MODE_SIZE (mode));
5959 if (debug_info_p)
5960 rest_of_record_type_compilation (gnu_cico_return_type);
5963 gnu_return_type = gnu_cico_return_type;
5966 /* The lists have been built in reverse. */
5967 gnu_param_type_list = nreverse (gnu_param_type_list);
5968 gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
5969 *param_list = nreverse (gnu_param_list);
5970 gnu_cico_list = nreverse (gnu_cico_list);
5972 /* If the profile is incomplete, we only set the (temporary) return and
5973 parameter types; otherwise, we build the full type. In either case,
5974 we reuse an already existing GCC tree that we built previously here. */
5975 if (incomplete_profile_p)
5977 if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
5979 else
5980 gnu_type = make_node (FUNCTION_TYPE);
5981 TREE_TYPE (gnu_type) = gnu_return_type;
5982 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
5983 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
5984 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
5985 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
5987 else
5989 if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
5991 TREE_TYPE (gnu_type) = gnu_return_type;
5992 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
5993 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
5994 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
5995 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
5996 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
5997 TYPE_CANONICAL (gnu_type) = gnu_type;
5998 layout_type (gnu_type);
6000 else
6002 gnu_type
6003 = build_function_type (gnu_return_type, gnu_param_type_list);
6005 /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
6006 has a different TYPE_CI_CO_LIST or flags. */
6007 if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
6008 return_unconstrained_p,
6009 return_by_direct_ref_p,
6010 return_by_invisi_ref_p))
6012 gnu_type = copy_type (gnu_type);
6013 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
6014 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
6015 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
6016 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6020 if (const_flag)
6021 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
6023 if (No_Return (gnat_subprog))
6024 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
6026 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
6027 corresponding DECL node and check the parameter association. */
6028 if (Convention (gnat_subprog) == Convention_Intrinsic
6029 && Present (Interface_Name (gnat_subprog)))
6031 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6032 tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
6034 /* If we have a builtin DECL for that function, use it. Check if
6035 the profiles are compatible and warn if they are not. Note that
6036 the checker is expected to post diagnostics in this case. */
6037 if (gnu_builtin_decl)
6039 intrin_binding_t inb
6040 = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) };
6042 if (!intrin_profiles_compatible_p (&inb))
6043 post_error
6044 ("?profile of& doesn''t match the builtin it binds!",
6045 gnat_subprog);
6047 return gnu_builtin_decl;
6050 /* Inability to find the builtin DECL most often indicates a genuine
6051 mistake, but imports of unregistered intrinsics are sometimes used
6052 on purpose to allow hooking in alternate bodies; we post a warning
6053 conditioned on Wshadow in this case, to let developers be notified
6054 on demand without risking false positives with common default sets
6055 of options. */
6056 if (warn_shadow)
6057 post_error ("?gcc intrinsic not found for&!", gnat_subprog);
6061 return gnu_type;
6064 /* Return the external name for GNAT_SUBPROG given its entity name. */
6066 static tree
6067 gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name)
6069 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6071 /* If there was no specified Interface_Name and the external and
6072 internal names of the subprogram are the same, only use the
6073 internal name to allow disambiguation of nested subprograms. */
6074 if (No (Interface_Name (gnat_subprog)) && gnu_ext_name == gnu_entity_name)
6075 gnu_ext_name = NULL_TREE;
6077 return gnu_ext_name;
6080 /* Like build_qualified_type, but TYPE_QUALS is added to the existing
6081 qualifiers on TYPE. */
6083 static tree
6084 change_qualified_type (tree type, int type_quals)
6086 /* Qualifiers must be put on the associated array type. */
6087 if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
6088 return type;
6090 return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
6093 /* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
6094 build_nonshared_array_type. */
6096 static void
6097 set_nonaliased_component_on_array_type (tree type)
6099 TYPE_NONALIASED_COMPONENT (type) = 1;
6100 TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1;
6103 /* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
6104 build_nonshared_array_type. */
6106 static void
6107 set_reverse_storage_order_on_array_type (tree type)
6109 TYPE_REVERSE_STORAGE_ORDER (type) = 1;
6110 TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
6113 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
6115 static bool
6116 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
6118 while (Present (Corresponding_Discriminant (discr1)))
6119 discr1 = Corresponding_Discriminant (discr1);
6121 while (Present (Corresponding_Discriminant (discr2)))
6122 discr2 = Corresponding_Discriminant (discr2);
6124 return
6125 Original_Record_Component (discr1) == Original_Record_Component (discr2);
6128 /* Return true if the array type GNU_TYPE, which represents a dimension of
6129 GNAT_TYPE, has a non-aliased component in the back-end sense. */
6131 static bool
6132 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
6134 /* If the array type is not the innermost dimension of the GNAT type,
6135 then it has a non-aliased component. */
6136 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6137 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
6138 return true;
6140 /* If the array type has an aliased component in the front-end sense,
6141 then it also has an aliased component in the back-end sense. */
6142 if (Has_Aliased_Components (gnat_type))
6143 return false;
6145 /* If this is a derived type, then it has a non-aliased component if
6146 and only if its parent type also has one. */
6147 if (Is_Derived_Type (gnat_type))
6149 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
6150 int index;
6151 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
6152 gnu_parent_type
6153 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
6154 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
6155 gnu_parent_type = TREE_TYPE (gnu_parent_type);
6156 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
6159 /* Otherwise, rely exclusively on properties of the element type. */
6160 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
6163 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
6165 static bool
6166 compile_time_known_address_p (Node_Id gnat_address)
6168 /* Handle reference to a constant. */
6169 if (Is_Entity_Name (gnat_address)
6170 && Ekind (Entity (gnat_address)) == E_Constant)
6172 gnat_address = Constant_Value (Entity (gnat_address));
6173 if (No (gnat_address))
6174 return false;
6177 /* Catch System'To_Address. */
6178 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
6179 gnat_address = Expression (gnat_address);
6181 return Compile_Time_Known_Value (gnat_address);
6184 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
6185 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
6187 static bool
6188 cannot_be_superflat (Node_Id gnat_range)
6190 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
6191 Node_Id scalar_range;
6192 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
6194 /* If the low bound is not constant, try to find an upper bound. */
6195 while (Nkind (gnat_lb) != N_Integer_Literal
6196 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
6197 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
6198 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
6199 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6200 || Nkind (scalar_range) == N_Range))
6201 gnat_lb = High_Bound (scalar_range);
6203 /* If the high bound is not constant, try to find a lower bound. */
6204 while (Nkind (gnat_hb) != N_Integer_Literal
6205 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
6206 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
6207 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
6208 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6209 || Nkind (scalar_range) == N_Range))
6210 gnat_hb = Low_Bound (scalar_range);
6212 /* If we have failed to find constant bounds, punt. */
6213 if (Nkind (gnat_lb) != N_Integer_Literal
6214 || Nkind (gnat_hb) != N_Integer_Literal)
6215 return false;
6217 /* We need at least a signed 64-bit type to catch most cases. */
6218 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
6219 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
6220 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
6221 return false;
6223 /* If the low bound is the smallest integer, nothing can be smaller. */
6224 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
6225 if (TREE_OVERFLOW (gnu_lb_minus_one))
6226 return true;
6228 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
6231 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
6233 static bool
6234 constructor_address_p (tree gnu_expr)
6236 while (TREE_CODE (gnu_expr) == NOP_EXPR
6237 || TREE_CODE (gnu_expr) == CONVERT_EXPR
6238 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
6239 gnu_expr = TREE_OPERAND (gnu_expr, 0);
6241 return (TREE_CODE (gnu_expr) == ADDR_EXPR
6242 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
6245 /* Return true if the size in units represented by GNU_SIZE can be handled by
6246 an allocation. If STATIC_P is true, consider only what can be done with a
6247 static allocation. */
6249 static bool
6250 allocatable_size_p (tree gnu_size, bool static_p)
6252 /* We can allocate a fixed size if it is a valid for the middle-end. */
6253 if (TREE_CODE (gnu_size) == INTEGER_CST)
6254 return valid_constant_size_p (gnu_size);
6256 /* We can allocate a variable size if this isn't a static allocation. */
6257 else
6258 return !static_p;
6261 /* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
6262 initial value of an object of GNU_TYPE. */
6264 static bool
6265 initial_value_needs_conversion (tree gnu_type, tree gnu_expr)
6267 /* Do not convert if the object's type is unconstrained because this would
6268 generate useless evaluations of the CONSTRUCTOR to compute the size. */
6269 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
6270 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
6271 return false;
6273 /* Do not convert if the object's type is a padding record whose field is of
6274 self-referential size because we want to copy only the actual data. */
6275 if (type_is_padding_self_referential (gnu_type))
6276 return false;
6278 /* Do not convert a call to a function that returns with variable size since
6279 we want to use the return slot optimization in this case. */
6280 if (TREE_CODE (gnu_expr) == CALL_EXPR
6281 && return_type_with_variable_size_p (TREE_TYPE (gnu_expr)))
6282 return false;
6284 /* Do not convert to a record type with a variant part from a record type
6285 without one, to keep the object simpler. */
6286 if (TREE_CODE (gnu_type) == RECORD_TYPE
6287 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
6288 && get_variant_part (gnu_type)
6289 && !get_variant_part (TREE_TYPE (gnu_expr)))
6290 return false;
6292 /* In all the other cases, convert the expression to the object's type. */
6293 return true;
6296 /* Given GNAT_ENTITY, elaborate all expressions that are required to
6297 be elaborated at the point of its definition, but do nothing else. */
6299 void
6300 elaborate_entity (Entity_Id gnat_entity)
6302 switch (Ekind (gnat_entity))
6304 case E_Signed_Integer_Subtype:
6305 case E_Modular_Integer_Subtype:
6306 case E_Enumeration_Subtype:
6307 case E_Ordinary_Fixed_Point_Subtype:
6308 case E_Decimal_Fixed_Point_Subtype:
6309 case E_Floating_Point_Subtype:
6311 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
6312 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
6314 /* ??? Tests to avoid Constraint_Error in static expressions
6315 are needed until after the front stops generating bogus
6316 conversions on bounds of real types. */
6317 if (!Raises_Constraint_Error (gnat_lb))
6318 elaborate_expression (gnat_lb, gnat_entity, "L", true, false,
6319 Needs_Debug_Info (gnat_entity));
6320 if (!Raises_Constraint_Error (gnat_hb))
6321 elaborate_expression (gnat_hb, gnat_entity, "U", true, false,
6322 Needs_Debug_Info (gnat_entity));
6323 break;
6326 case E_Record_Subtype:
6327 case E_Private_Subtype:
6328 case E_Limited_Private_Subtype:
6329 case E_Record_Subtype_With_Private:
6330 if (Has_Discriminants (gnat_entity) && Is_Constrained (gnat_entity))
6332 Node_Id gnat_discriminant_expr;
6333 Entity_Id gnat_field;
6335 for (gnat_field
6336 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
6337 gnat_discriminant_expr
6338 = First_Elmt (Discriminant_Constraint (gnat_entity));
6339 Present (gnat_field);
6340 gnat_field = Next_Discriminant (gnat_field),
6341 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
6342 /* Ignore access discriminants. */
6343 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
6344 elaborate_expression (Node (gnat_discriminant_expr),
6345 gnat_entity, get_entity_char (gnat_field),
6346 true, false, false);
6348 break;
6353 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6354 NAME, ARGS and ERROR_POINT. */
6356 static void
6357 prepend_one_attribute (struct attrib **attr_list,
6358 enum attrib_type attrib_type,
6359 tree attr_name,
6360 tree attr_args,
6361 Node_Id attr_error_point)
6363 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
6365 attr->type = attrib_type;
6366 attr->name = attr_name;
6367 attr->args = attr_args;
6368 attr->error_point = attr_error_point;
6370 attr->next = *attr_list;
6371 *attr_list = attr;
6374 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
6376 static void
6377 prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma)
6379 const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma);
6380 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
6381 enum attrib_type etype;
6383 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
6384 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
6386 case Pragma_Machine_Attribute:
6387 etype = ATTR_MACHINE_ATTRIBUTE;
6388 break;
6390 case Pragma_Linker_Alias:
6391 etype = ATTR_LINK_ALIAS;
6392 break;
6394 case Pragma_Linker_Section:
6395 etype = ATTR_LINK_SECTION;
6396 break;
6398 case Pragma_Linker_Constructor:
6399 etype = ATTR_LINK_CONSTRUCTOR;
6400 break;
6402 case Pragma_Linker_Destructor:
6403 etype = ATTR_LINK_DESTRUCTOR;
6404 break;
6406 case Pragma_Weak_External:
6407 etype = ATTR_WEAK_EXTERNAL;
6408 break;
6410 case Pragma_Thread_Local_Storage:
6411 etype = ATTR_THREAD_LOCAL_STORAGE;
6412 break;
6414 default:
6415 return;
6418 /* See what arguments we have and turn them into GCC trees for attribute
6419 handlers. These expect identifier for strings. We handle at most two
6420 arguments and static expressions only. */
6421 if (Present (gnat_arg) && Present (First (gnat_arg)))
6423 Node_Id gnat_arg0 = Next (First (gnat_arg));
6424 Node_Id gnat_arg1 = Empty;
6426 if (Present (gnat_arg0)
6427 && Is_OK_Static_Expression (Expression (gnat_arg0)))
6429 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
6431 if (TREE_CODE (gnu_arg0) == STRING_CST)
6433 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6434 if (IDENTIFIER_LENGTH (gnu_arg0) == 0)
6435 return;
6438 gnat_arg1 = Next (gnat_arg0);
6441 if (Present (gnat_arg1)
6442 && Is_OK_Static_Expression (Expression (gnat_arg1)))
6444 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6446 if (TREE_CODE (gnu_arg1) == STRING_CST)
6447 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6451 /* Prepend to the list. Make a list of the argument we might have, as GCC
6452 expects it. */
6453 prepend_one_attribute (attr_list, etype, gnu_arg0,
6454 gnu_arg1
6455 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6456 Present (Next (First (gnat_arg)))
6457 ? Expression (Next (First (gnat_arg))) : gnat_pragma);
6460 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6462 static void
6463 prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
6465 Node_Id gnat_temp;
6467 /* Attributes are stored as Representation Item pragmas. */
6468 for (gnat_temp = First_Rep_Item (gnat_entity);
6469 Present (gnat_temp);
6470 gnat_temp = Next_Rep_Item (gnat_temp))
6471 if (Nkind (gnat_temp) == N_Pragma)
6472 prepend_one_attribute_pragma (attr_list, gnat_temp);
6475 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6476 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6477 return the GCC tree to use for that expression. S is the suffix to use
6478 if a variable needs to be created and DEFINITION is true if this is done
6479 for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6480 otherwise, we are just elaborating the expression for side-effects. If
6481 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6482 isn't needed for code generation. */
6484 static tree
6485 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
6486 bool definition, bool need_value, bool need_debug)
6488 tree gnu_expr;
6490 /* If we already elaborated this expression (e.g. it was involved
6491 in the definition of a private type), use the old value. */
6492 if (present_gnu_tree (gnat_expr))
6493 return get_gnu_tree (gnat_expr);
6495 /* If we don't need a value and this is static or a discriminant,
6496 we don't need to do anything. */
6497 if (!need_value
6498 && (Is_OK_Static_Expression (gnat_expr)
6499 || (Nkind (gnat_expr) == N_Identifier
6500 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6501 return NULL_TREE;
6503 /* If it's a static expression, we don't need a variable for debugging. */
6504 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6505 need_debug = false;
6507 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6508 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s,
6509 definition, need_debug);
6511 /* Save the expression in case we try to elaborate this entity again. Since
6512 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6513 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6514 save_gnu_tree (gnat_expr, gnu_expr, true);
6516 return need_value ? gnu_expr : error_mark_node;
6519 /* Similar, but take a GNU expression and always return a result. */
6521 static tree
6522 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6523 bool definition, bool need_debug)
6525 const bool expr_public_p = Is_Public (gnat_entity);
6526 const bool expr_global_p = expr_public_p || global_bindings_p ();
6527 bool expr_variable_p, use_variable;
6529 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6530 that an expression cannot contain both a discriminant and a variable. */
6531 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6532 return gnu_expr;
6534 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6535 a variable that is initialized to contain the expression when the package
6536 containing the definition is elaborated. If this entity is defined at top
6537 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6538 if this is necessary. */
6539 if (TREE_CONSTANT (gnu_expr))
6540 expr_variable_p = false;
6541 else
6543 /* Skip any conversions and simple constant arithmetics to see if the
6544 expression is based on a read-only variable. */
6545 tree inner = remove_conversions (gnu_expr, true);
6547 inner = skip_simple_constant_arithmetic (inner);
6549 if (handled_component_p (inner))
6550 inner = get_inner_constant_reference (inner);
6552 expr_variable_p
6553 = !(inner
6554 && TREE_CODE (inner) == VAR_DECL
6555 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6558 /* We only need to use the variable if we are in a global context since GCC
6559 can do the right thing in the local case. However, when not optimizing,
6560 use it for bounds of loop iteration scheme to avoid code duplication. */
6561 use_variable = expr_variable_p
6562 && (expr_global_p
6563 || (!optimize
6564 && definition
6565 && Is_Itype (gnat_entity)
6566 && Nkind (Associated_Node_For_Itype (gnat_entity))
6567 == N_Loop_Parameter_Specification));
6569 /* Now create it, possibly only for debugging purposes. */
6570 if (use_variable || need_debug)
6572 /* The following variable creation can happen when processing the body
6573 of subprograms that are defined out of the extended main unit and
6574 inlined. In this case, we are not at the global scope, and thus the
6575 new variable must not be tagged "external", as we used to do here as
6576 soon as DEFINITION was false. */
6577 tree gnu_decl
6578 = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE,
6579 TREE_TYPE (gnu_expr), gnu_expr, true,
6580 expr_public_p, !definition && expr_global_p,
6581 expr_global_p, false, true, need_debug,
6582 NULL, gnat_entity);
6584 /* Using this variable at debug time (if need_debug is true) requires a
6585 proper location. The back-end will compute a location for this
6586 variable only if the variable is used by the generated code.
6587 Returning the variable ensures the caller will use it in generated
6588 code. Note that there is no need for a location if the debug info
6589 contains an integer constant.
6590 TODO: when the encoding-based debug scheme is dropped, move this
6591 condition to the top-level IF block: we will not need to create a
6592 variable anymore in such cases, then. */
6593 if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr)))
6594 return gnu_decl;
6597 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6600 /* Similar, but take an alignment factor and make it explicit in the tree. */
6602 static tree
6603 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6604 bool definition, bool need_debug, unsigned int align)
6606 tree unit_align = size_int (align / BITS_PER_UNIT);
6607 return
6608 size_binop (MULT_EXPR,
6609 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6610 gnu_expr,
6611 unit_align),
6612 gnat_entity, s, definition,
6613 need_debug),
6614 unit_align);
6617 /* Structure to hold internal data for elaborate_reference. */
6619 struct er_data
6621 Entity_Id entity;
6622 bool definition;
6623 unsigned int n;
6626 /* Wrapper function around elaborate_expression_1 for elaborate_reference. */
6628 static tree
6629 elaborate_reference_1 (tree ref, void *data)
6631 struct er_data *er = (struct er_data *)data;
6632 char suffix[16];
6634 /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */
6635 if (TREE_CONSTANT (ref))
6636 return ref;
6638 /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat
6639 pointer. This may be more efficient, but will also allow us to more
6640 easily find the match for the PLACEHOLDER_EXPR. */
6641 if (TREE_CODE (ref) == COMPONENT_REF
6642 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
6643 return build3 (COMPONENT_REF, TREE_TYPE (ref),
6644 elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
6645 TREE_OPERAND (ref, 1), NULL_TREE);
6647 sprintf (suffix, "EXP%d", ++er->n);
6648 return
6649 elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
6652 /* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
6653 DEFINITION is true if this is done for a definition of GNAT_ENTITY and
6654 INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
6656 static tree
6657 elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
6658 tree *init)
6660 struct er_data er = { gnat_entity, definition, 0 };
6661 return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
6664 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6665 the value passed against the list of choices. */
6667 static tree
6668 choices_to_gnu (tree operand, Node_Id choices)
6670 Node_Id choice;
6671 Node_Id gnat_temp;
6672 tree result = boolean_false_node;
6673 tree this_test, low = 0, high = 0, single = 0;
6675 for (choice = First (choices); Present (choice); choice = Next (choice))
6677 switch (Nkind (choice))
6679 case N_Range:
6680 low = gnat_to_gnu (Low_Bound (choice));
6681 high = gnat_to_gnu (High_Bound (choice));
6683 this_test
6684 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6685 build_binary_op (GE_EXPR, boolean_type_node,
6686 operand, low, true),
6687 build_binary_op (LE_EXPR, boolean_type_node,
6688 operand, high, true),
6689 true);
6691 break;
6693 case N_Subtype_Indication:
6694 gnat_temp = Range_Expression (Constraint (choice));
6695 low = gnat_to_gnu (Low_Bound (gnat_temp));
6696 high = gnat_to_gnu (High_Bound (gnat_temp));
6698 this_test
6699 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6700 build_binary_op (GE_EXPR, boolean_type_node,
6701 operand, low, true),
6702 build_binary_op (LE_EXPR, boolean_type_node,
6703 operand, high, true),
6704 true);
6705 break;
6707 case N_Identifier:
6708 case N_Expanded_Name:
6709 /* This represents either a subtype range, an enumeration
6710 literal, or a constant Ekind says which. If an enumeration
6711 literal or constant, fall through to the next case. */
6712 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6713 && Ekind (Entity (choice)) != E_Constant)
6715 tree type = gnat_to_gnu_type (Entity (choice));
6717 low = TYPE_MIN_VALUE (type);
6718 high = TYPE_MAX_VALUE (type);
6720 this_test
6721 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6722 build_binary_op (GE_EXPR, boolean_type_node,
6723 operand, low, true),
6724 build_binary_op (LE_EXPR, boolean_type_node,
6725 operand, high, true),
6726 true);
6727 break;
6730 /* ... fall through ... */
6732 case N_Character_Literal:
6733 case N_Integer_Literal:
6734 single = gnat_to_gnu (choice);
6735 this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
6736 single, true);
6737 break;
6739 case N_Others_Choice:
6740 this_test = boolean_true_node;
6741 break;
6743 default:
6744 gcc_unreachable ();
6747 if (result == boolean_false_node)
6748 result = this_test;
6749 else
6750 result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
6751 this_test, true);
6754 return result;
6757 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6758 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6760 static int
6761 adjust_packed (tree field_type, tree record_type, int packed)
6763 /* If the field contains an item of variable size, we cannot pack it
6764 because we cannot create temporaries of non-fixed size in case
6765 we need to take the address of the field. See addressable_p and
6766 the notes on the addressability issues for further details. */
6767 if (type_has_variable_size (field_type))
6768 return 0;
6770 /* In the other cases, we can honor the packing. */
6771 if (packed)
6772 return packed;
6774 /* If the alignment of the record is specified and the field type
6775 is over-aligned, request Storage_Unit alignment for the field. */
6776 if (TYPE_ALIGN (record_type)
6777 && TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6778 return -1;
6780 /* Likewise if the maximum alignment of the record is specified. */
6781 if (TYPE_MAX_ALIGN (record_type)
6782 && TYPE_ALIGN (field_type) > TYPE_MAX_ALIGN (record_type))
6783 return -1;
6785 return 0;
6788 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6789 placed in GNU_RECORD_TYPE.
6791 PACKED is 1 if the enclosing record is packed or -1 if the enclosing
6792 record has Component_Alignment of Storage_Unit.
6794 DEFINITION is true if this field is for a record being defined.
6796 DEBUG_INFO_P is true if we need to write debug information for types
6797 that we may create in the process. */
6799 static tree
6800 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6801 bool definition, bool debug_info_p)
6803 const Entity_Id gnat_record_type = Underlying_Type (Scope (gnat_field));
6804 const Entity_Id gnat_field_type = Etype (gnat_field);
6805 const bool is_atomic
6806 = (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type));
6807 const bool is_aliased = Is_Aliased (gnat_field);
6808 const bool is_independent
6809 = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
6810 const bool is_volatile
6811 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6812 const bool is_strict_alignment = Strict_Alignment (gnat_field_type);
6813 /* We used to consider that volatile fields also require strict alignment,
6814 but that was an interpolation and would cause us to reject a pragma
6815 volatile on a packed record type containing boolean components, while
6816 there is no basis to do so in the RM. In such cases, the writes will
6817 involve load-modify-store sequences, but that's OK for volatile. The
6818 only constraint is the implementation advice whereby only the bits of
6819 the components should be accessed if they both start and end on byte
6820 boundaries, but that should be guaranteed by the GCC memory model. */
6821 const bool needs_strict_alignment
6822 = (is_atomic || is_aliased || is_independent || is_strict_alignment);
6823 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6824 tree gnu_field_id = get_entity_name (gnat_field);
6825 tree gnu_field, gnu_size, gnu_pos;
6827 /* If this field requires strict alignment, we cannot pack it because
6828 it would very likely be under-aligned in the record. */
6829 if (needs_strict_alignment)
6830 packed = 0;
6831 else
6832 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6834 /* If a size is specified, use it. Otherwise, if the record type is packed,
6835 use the official RM size. See "Handling of Type'Size Values" in Einfo
6836 for further details. */
6837 if (Known_Esize (gnat_field))
6838 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6839 gnat_field, FIELD_DECL, false, true);
6840 else if (packed == 1)
6841 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6842 gnat_field, FIELD_DECL, false, true);
6843 else
6844 gnu_size = NULL_TREE;
6846 /* If we have a specified size that is smaller than that of the field's type,
6847 or a position is specified, and the field's type is a record that doesn't
6848 require strict alignment, see if we can get either an integral mode form
6849 of the type or a smaller form. If we can, show a size was specified for
6850 the field if there wasn't one already, so we know to make this a bitfield
6851 and avoid making things wider.
6853 Changing to an integral mode form is useful when the record is packed as
6854 we can then place the field at a non-byte-aligned position and so achieve
6855 tighter packing. This is in addition required if the field shares a byte
6856 with another field and the front-end lets the back-end handle the access
6857 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6859 Changing to a smaller form is required if the specified size is smaller
6860 than that of the field's type and the type contains sub-fields that are
6861 padded, in order to avoid generating accesses to these sub-fields that
6862 are wider than the field.
6864 We avoid the transformation if it is not required or potentially useful,
6865 as it might entail an increase of the field's alignment and have ripple
6866 effects on the outer record type. A typical case is a field known to be
6867 byte-aligned and not to share a byte with another field. */
6868 if (!needs_strict_alignment
6869 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
6870 && !TYPE_FAT_POINTER_P (gnu_field_type)
6871 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
6872 && (packed == 1
6873 || (gnu_size
6874 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6875 || (Present (Component_Clause (gnat_field))
6876 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6877 % BITS_PER_UNIT == 0
6878 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6880 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6881 if (gnu_packable_type != gnu_field_type)
6883 gnu_field_type = gnu_packable_type;
6884 if (!gnu_size)
6885 gnu_size = rm_size (gnu_field_type);
6889 if (Is_Atomic_Or_VFA (gnat_field))
6890 check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
6892 if (Present (Component_Clause (gnat_field)))
6894 Node_Id gnat_clause = Component_Clause (gnat_field);
6895 Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
6897 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6898 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6899 gnat_field, FIELD_DECL, false, true);
6901 /* Ensure the position does not overlap with the parent subtype, if there
6902 is one. This test is omitted if the parent of the tagged type has a
6903 full rep clause since, in this case, component clauses are allowed to
6904 overlay the space allocated for the parent type and the front-end has
6905 checked that there are no overlapping components. */
6906 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6908 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6910 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6911 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6912 post_error_ne_tree
6913 ("offset of& must be beyond parent{, minimum allowed is ^}",
6914 Position (gnat_clause), gnat_field, TYPE_SIZE_UNIT (gnu_parent));
6917 /* If this field needs strict alignment, make sure that the record is
6918 sufficiently aligned and that the position and size are consistent
6919 with the type. But don't do it if we are just annotating types and
6920 the field's type is tagged, since tagged types aren't fully laid out
6921 in this mode. Also, note that atomic implies volatile so the inner
6922 test sequences ordering is significant here. */
6923 if (needs_strict_alignment
6924 && !(type_annotate_only && Is_Tagged_Type (gnat_field_type)))
6926 const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
6928 if (TYPE_ALIGN (gnu_record_type) < type_align)
6929 SET_TYPE_ALIGN (gnu_record_type, type_align);
6931 /* If the position is not a multiple of the alignment of the type,
6932 then error out and reset the position. */
6933 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
6934 bitsize_int (type_align))))
6936 const char *s;
6938 if (is_atomic)
6939 s = "position of atomic field& must be multiple of ^ bits";
6940 else if (is_aliased)
6941 s = "position of aliased field& must be multiple of ^ bits";
6942 else if (is_independent)
6943 s = "position of independent field& must be multiple of ^ bits";
6944 else if (is_strict_alignment)
6945 s = "position of & with aliased or tagged part must be"
6946 " multiple of ^ bits";
6947 else
6948 gcc_unreachable ();
6950 post_error_ne_num (s, First_Bit (gnat_clause), gnat_field,
6951 type_align);
6952 gnu_pos = NULL_TREE;
6955 if (gnu_size)
6957 tree gnu_type_size = TYPE_SIZE (gnu_field_type);
6958 const int cmp = tree_int_cst_compare (gnu_size, gnu_type_size);
6960 /* If the size is lower than that of the type, or greater for
6961 atomic and aliased, then error out and reset the size. */
6962 if (cmp < 0 || (cmp > 0 && (is_atomic || is_aliased)))
6964 const char *s;
6966 if (is_atomic)
6967 s = "size of atomic field& must be ^ bits";
6968 else if (is_aliased)
6969 s = "size of aliased field& must be ^ bits";
6970 else if (is_independent)
6971 s = "size of independent field& must be at least ^ bits";
6972 else if (is_strict_alignment)
6973 s = "size of & with aliased or tagged part must be"
6974 " at least ^ bits";
6975 else
6976 gcc_unreachable ();
6978 post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field,
6979 gnu_type_size);
6980 gnu_size = NULL_TREE;
6983 /* Likewise if the size is not a multiple of a byte, */
6984 else if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
6985 bitsize_unit_node)))
6987 const char *s;
6989 if (is_independent)
6990 s = "size of independent field& must be multiple of"
6991 " Storage_Unit";
6992 else if (is_strict_alignment)
6993 s = "size of & with aliased or tagged part must be"
6994 " multiple of Storage_Unit";
6995 else
6996 gcc_unreachable ();
6998 post_error_ne (s, Last_Bit (gnat_clause), gnat_field);
6999 gnu_size = NULL_TREE;
7005 /* If the record has rep clauses and this is the tag field, make a rep
7006 clause for it as well. */
7007 else if (Has_Specified_Layout (gnat_record_type)
7008 && Chars (gnat_field) == Name_uTag)
7010 gnu_pos = bitsize_zero_node;
7011 gnu_size = TYPE_SIZE (gnu_field_type);
7014 else
7016 gnu_pos = NULL_TREE;
7018 /* If we are packing the record and the field is BLKmode, round the
7019 size up to a byte boundary. */
7020 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
7021 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
7024 /* We need to make the size the maximum for the type if it is
7025 self-referential and an unconstrained type. In that case, we can't
7026 pack the field since we can't make a copy to align it. */
7027 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
7028 && !gnu_size
7029 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
7030 && !Is_Constrained (Underlying_Type (gnat_field_type)))
7032 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
7033 packed = 0;
7036 /* If a size is specified, adjust the field's type to it. */
7037 if (gnu_size)
7039 tree orig_field_type;
7041 /* If the field's type is justified modular, we would need to remove
7042 the wrapper to (better) meet the layout requirements. However we
7043 can do so only if the field is not aliased to preserve the unique
7044 layout, if it has the same storage order as the enclosing record
7045 and if the prescribed size is not greater than that of the packed
7046 array to preserve the justification. */
7047 if (!needs_strict_alignment
7048 && TREE_CODE (gnu_field_type) == RECORD_TYPE
7049 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
7050 && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type)
7051 == Reverse_Storage_Order (gnat_record_type)
7052 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
7053 <= 0)
7054 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7056 /* Similarly if the field's type is a misaligned integral type, but
7057 there is no restriction on the size as there is no justification. */
7058 if (!needs_strict_alignment
7059 && TYPE_IS_PADDING_P (gnu_field_type)
7060 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
7061 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7063 gnu_field_type
7064 = make_type_from_size (gnu_field_type, gnu_size,
7065 Has_Biased_Representation (gnat_field));
7067 orig_field_type = gnu_field_type;
7068 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
7069 false, false, definition, true);
7071 /* If a padding record was made, declare it now since it will never be
7072 declared otherwise. This is necessary to ensure that its subtrees
7073 are properly marked. */
7074 if (gnu_field_type != orig_field_type
7075 && !DECL_P (TYPE_NAME (gnu_field_type)))
7076 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true,
7077 debug_info_p, gnat_field);
7080 /* Otherwise (or if there was an error), don't specify a position. */
7081 else
7082 gnu_pos = NULL_TREE;
7084 /* If the field's type is a padded type made for a scalar field of a record
7085 type with reverse storage order, we need to propagate the reverse storage
7086 order to the padding type since it is the innermost enclosing aggregate
7087 type around the scalar. */
7088 if (TYPE_IS_PADDING_P (gnu_field_type)
7089 && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type)
7090 && Is_Scalar_Type (gnat_field_type))
7091 gnu_field_type = set_reverse_storage_order_on_pad_type (gnu_field_type);
7093 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
7094 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
7096 /* Now create the decl for the field. */
7097 gnu_field
7098 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
7099 gnu_size, gnu_pos, packed, is_aliased);
7100 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
7101 DECL_ALIASED_P (gnu_field) = is_aliased;
7102 TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile;
7104 if (Ekind (gnat_field) == E_Discriminant)
7106 DECL_INVARIANT_P (gnu_field)
7107 = No (Discriminant_Default_Value (gnat_field));
7108 DECL_DISCRIMINANT_NUMBER (gnu_field)
7109 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7112 return gnu_field;
7115 /* Return true if at least one member of COMPONENT_LIST needs strict
7116 alignment. */
7118 static bool
7119 components_need_strict_alignment (Node_Id component_list)
7121 Node_Id component_decl;
7123 for (component_decl = First_Non_Pragma (Component_Items (component_list));
7124 Present (component_decl);
7125 component_decl = Next_Non_Pragma (component_decl))
7127 Entity_Id gnat_field = Defining_Entity (component_decl);
7129 if (Is_Aliased (gnat_field))
7130 return true;
7132 if (Strict_Alignment (Etype (gnat_field)))
7133 return true;
7136 return false;
7139 /* Return true if TYPE is a type with variable size or a padding type with a
7140 field of variable size or a record that has a field with such a type. */
7142 static bool
7143 type_has_variable_size (tree type)
7145 tree field;
7147 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7148 return true;
7150 if (TYPE_IS_PADDING_P (type)
7151 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7152 return true;
7154 if (!RECORD_OR_UNION_TYPE_P (type))
7155 return false;
7157 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7158 if (type_has_variable_size (TREE_TYPE (field)))
7159 return true;
7161 return false;
7164 /* Return true if FIELD is an artificial field. */
7166 static bool
7167 field_is_artificial (tree field)
7169 /* These fields are generated by the front-end proper. */
7170 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
7171 return true;
7173 /* These fields are generated by gigi. */
7174 if (DECL_INTERNAL_P (field))
7175 return true;
7177 return false;
7180 /* Return true if FIELD is a non-artificial field with self-referential
7181 size. */
7183 static bool
7184 field_has_self_size (tree field)
7186 if (field_is_artificial (field))
7187 return false;
7189 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7190 return false;
7192 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
7195 /* Return true if FIELD is a non-artificial field with variable size. */
7197 static bool
7198 field_has_variable_size (tree field)
7200 if (field_is_artificial (field))
7201 return false;
7203 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7204 return false;
7206 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
7209 /* qsort comparer for the bit positions of two record components. */
7211 static int
7212 compare_field_bitpos (const PTR rt1, const PTR rt2)
7214 const_tree const field1 = * (const_tree const *) rt1;
7215 const_tree const field2 = * (const_tree const *) rt2;
7216 const int ret
7217 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7219 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7222 /* Reverse function from gnat_to_gnu_field: return the GNAT field present in
7223 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and
7224 corresponding to the GNU tree GNU_FIELD. */
7226 static Entity_Id
7227 gnu_field_to_gnat (tree gnu_field, Node_Id gnat_component_list,
7228 Entity_Id gnat_record_type)
7230 Entity_Id gnat_component_decl, gnat_field;
7232 if (Present (Component_Items (gnat_component_list)))
7233 for (gnat_component_decl
7234 = First_Non_Pragma (Component_Items (gnat_component_list));
7235 Present (gnat_component_decl);
7236 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
7238 gnat_field = Defining_Entity (gnat_component_decl);
7239 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
7240 return gnat_field;
7243 if (Has_Discriminants (gnat_record_type))
7244 for (gnat_field = First_Stored_Discriminant (gnat_record_type);
7245 Present (gnat_field);
7246 gnat_field = Next_Stored_Discriminant (gnat_field))
7247 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
7248 return gnat_field;
7250 return Empty;
7253 /* Issue a warning for the problematic placement of GNU_FIELD present in
7254 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE.
7255 IN_VARIANT is true if GNAT_COMPONENT_LIST is the list of a variant.
7256 DO_REORDER is true if fields of GNAT_RECORD_TYPE are being reordered. */
7258 static void
7259 warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list,
7260 Entity_Id gnat_record_type, bool in_variant,
7261 bool do_reorder)
7263 const char *msg1
7264 = in_variant
7265 ? "?variant layout may cause performance issues"
7266 : "?record layout may cause performance issues";
7267 const char *msg2
7268 = field_has_self_size (gnu_field)
7269 ? "?component & whose length depends on a discriminant"
7270 : field_has_variable_size (gnu_field)
7271 ? "?component & whose length is not fixed"
7272 : "?component & whose length is not multiple of a byte";
7273 const char *msg3
7274 = do_reorder
7275 ? "?comes too early and was moved down"
7276 : "?comes too early and ought to be moved down";
7277 Entity_Id gnat_field
7278 = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type);
7280 gcc_assert (Present (gnat_field));
7282 post_error (msg1, gnat_field);
7283 post_error_ne (msg2, gnat_field, gnat_field);
7284 post_error (msg3, gnat_field);
7287 /* Structure holding information for a given variant. */
7288 typedef struct vinfo
7290 /* The record type of the variant. */
7291 tree type;
7293 /* The name of the variant. */
7294 tree name;
7296 /* The qualifier of the variant. */
7297 tree qual;
7299 /* Whether the variant has a rep clause. */
7300 bool has_rep;
7302 /* Whether the variant is packed. */
7303 bool packed;
7305 } vinfo_t;
7307 /* Translate and chain GNAT_COMPONENT_LIST present in GNAT_RECORD_TYPE to
7308 GNU_FIELD_LIST, set the result as the field list of GNU_RECORD_TYPE and
7309 finish it up. Return true if GNU_RECORD_TYPE has a rep clause that affects
7310 the layout (see below). When called from gnat_to_gnu_entity during the
7311 processing of a record definition, the GCC node for the parent, if any,
7312 will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
7313 discriminants will be on GNU_FIELD_LIST. The other call to this function
7314 is a recursive call for the component list of a variant and, in this case,
7315 GNU_FIELD_LIST is empty.
7317 PACKED is 1 if this is for a packed record or -1 if this is for a record
7318 with Component_Alignment of Storage_Unit.
7320 DEFINITION is true if we are defining this record type.
7322 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7323 out the record. This means the alignment only serves to force fields to
7324 be bitfields, but not to require the record to be that aligned. This is
7325 used for variants.
7327 ALL_REP is true if a rep clause is present for all the fields.
7329 UNCHECKED_UNION is true if we are building this type for a record with a
7330 Pragma Unchecked_Union.
7332 ARTIFICIAL is true if this is a type that was generated by the compiler.
7334 DEBUG_INFO is true if we need to write debug information about the type.
7336 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7337 mean that its contents may be unused as well, only the container itself.
7339 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
7340 the outer record type down to this variant level. It is nonzero only if
7341 all the fields down to this level have a rep clause and ALL_REP is false.
7343 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7344 with a rep clause is to be added; in this case, that is all that should
7345 be done with such fields and the return value will be false. */
7347 static bool
7348 components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
7349 tree gnu_field_list, tree gnu_record_type, int packed,
7350 bool definition, bool cancel_alignment, bool all_rep,
7351 bool unchecked_union, bool artificial, bool debug_info,
7352 bool maybe_unused, tree first_free_pos,
7353 tree *p_gnu_rep_list)
7355 const bool needs_xv_encodings
7356 = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL;
7357 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7358 bool variants_have_rep = all_rep;
7359 bool layout_with_rep = false;
7360 bool has_self_field = false;
7361 bool has_aliased_after_self_field = false;
7362 Entity_Id gnat_component_decl, gnat_variant_part;
7363 tree gnu_field, gnu_next, gnu_last;
7364 tree gnu_variant_part = NULL_TREE;
7365 tree gnu_rep_list = NULL_TREE;
7367 /* For each component referenced in a component declaration create a GCC
7368 field and add it to the list, skipping pragmas in the GNAT list. */
7369 gnu_last = tree_last (gnu_field_list);
7370 if (Present (Component_Items (gnat_component_list)))
7371 for (gnat_component_decl
7372 = First_Non_Pragma (Component_Items (gnat_component_list));
7373 Present (gnat_component_decl);
7374 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
7376 Entity_Id gnat_field = Defining_Entity (gnat_component_decl);
7377 Name_Id gnat_name = Chars (gnat_field);
7379 /* If present, the _Parent field must have been created as the single
7380 field of the record type. Put it before any other fields. */
7381 if (gnat_name == Name_uParent)
7383 gnu_field = TYPE_FIELDS (gnu_record_type);
7384 gnu_field_list = chainon (gnu_field_list, gnu_field);
7386 else
7388 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7389 definition, debug_info);
7391 /* If this is the _Tag field, put it before any other fields. */
7392 if (gnat_name == Name_uTag)
7393 gnu_field_list = chainon (gnu_field_list, gnu_field);
7395 /* If this is the _Controller field, put it before the other
7396 fields except for the _Tag or _Parent field. */
7397 else if (gnat_name == Name_uController && gnu_last)
7399 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7400 DECL_CHAIN (gnu_last) = gnu_field;
7403 /* If this is a regular field, put it after the other fields. */
7404 else
7406 DECL_CHAIN (gnu_field) = gnu_field_list;
7407 gnu_field_list = gnu_field;
7408 if (!gnu_last)
7409 gnu_last = gnu_field;
7411 /* And record information for the final layout. */
7412 if (field_has_self_size (gnu_field))
7413 has_self_field = true;
7414 else if (has_self_field && DECL_ALIASED_P (gnu_field))
7415 has_aliased_after_self_field = true;
7419 save_gnu_tree (gnat_field, gnu_field, false);
7422 /* At the end of the component list there may be a variant part. */
7423 gnat_variant_part = Variant_Part (gnat_component_list);
7425 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7426 mutually exclusive and should go in the same memory. To do this we need
7427 to treat each variant as a record whose elements are created from the
7428 component list for the variant. So here we create the records from the
7429 lists for the variants and put them all into the QUAL_UNION_TYPE.
7430 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7431 use GNU_RECORD_TYPE if there are no fields so far. */
7432 if (Present (gnat_variant_part))
7434 Node_Id gnat_discr = Name (gnat_variant_part), variant;
7435 tree gnu_discr = gnat_to_gnu (gnat_discr);
7436 tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
7437 tree gnu_var_name
7438 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7439 "XVN");
7440 tree gnu_union_type, gnu_union_name;
7441 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
7442 bool union_field_needs_strict_alignment = false;
7443 auto_vec <vinfo_t, 16> variant_types;
7444 vinfo_t *gnu_variant;
7445 unsigned int variants_align = 0;
7446 unsigned int i;
7448 gnu_union_name
7449 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7451 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7452 are all in the variant part, to match the layout of C unions. There
7453 is an associated check below. */
7454 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
7455 gnu_union_type = gnu_record_type;
7456 else
7458 gnu_union_type
7459 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7461 TYPE_NAME (gnu_union_type) = gnu_union_name;
7462 SET_TYPE_ALIGN (gnu_union_type, 0);
7463 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7464 TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
7465 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7468 /* If all the fields down to this level have a rep clause, find out
7469 whether all the fields at this level also have one. If so, then
7470 compute the new first free position to be passed downward. */
7471 this_first_free_pos = first_free_pos;
7472 if (this_first_free_pos)
7474 for (gnu_field = gnu_field_list;
7475 gnu_field;
7476 gnu_field = DECL_CHAIN (gnu_field))
7477 if (DECL_FIELD_OFFSET (gnu_field))
7479 tree pos = bit_position (gnu_field);
7480 if (!tree_int_cst_lt (pos, this_first_free_pos))
7481 this_first_free_pos
7482 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
7484 else
7486 this_first_free_pos = NULL_TREE;
7487 break;
7491 /* We build the variants in two passes. The bulk of the work is done in
7492 the first pass, that is to say translating the GNAT nodes, building
7493 the container types and computing the associated properties. However
7494 we cannot finish up the container types during this pass because we
7495 don't know where the variant part will be placed until the end. */
7496 for (variant = First_Non_Pragma (Variants (gnat_variant_part));
7497 Present (variant);
7498 variant = Next_Non_Pragma (variant))
7500 tree gnu_variant_type = make_node (RECORD_TYPE);
7501 tree gnu_inner_name, gnu_qual;
7502 bool has_rep;
7503 int field_packed;
7504 vinfo_t vinfo;
7506 Get_Variant_Encoding (variant);
7507 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7508 TYPE_NAME (gnu_variant_type)
7509 = concat_name (gnu_union_name,
7510 IDENTIFIER_POINTER (gnu_inner_name));
7512 /* Set the alignment of the inner type in case we need to make
7513 inner objects into bitfields, but then clear it out so the
7514 record actually gets only the alignment required. */
7515 SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
7516 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7517 TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
7518 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7520 /* Similarly, if the outer record has a size specified and all
7521 the fields have a rep clause, we can propagate the size. */
7522 if (all_rep_and_size)
7524 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7525 TYPE_SIZE_UNIT (gnu_variant_type)
7526 = TYPE_SIZE_UNIT (gnu_record_type);
7529 /* Add the fields into the record type for the variant. Note that
7530 we aren't sure to really use it at this point, see below. */
7531 has_rep
7532 = components_to_record (Component_List (variant), gnat_record_type,
7533 NULL_TREE, gnu_variant_type, packed,
7534 definition, !all_rep_and_size, all_rep,
7535 unchecked_union, true, needs_xv_encodings,
7536 true, this_first_free_pos,
7537 all_rep || this_first_free_pos
7538 ? NULL : &gnu_rep_list);
7540 /* Translate the qualifier and annotate the GNAT node. */
7541 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7542 Set_Present_Expr (variant, annotate_value (gnu_qual));
7544 /* Deal with packedness like in gnat_to_gnu_field. */
7545 if (components_need_strict_alignment (Component_List (variant)))
7547 field_packed = 0;
7548 union_field_needs_strict_alignment = true;
7550 else
7551 field_packed
7552 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7554 /* Push this variant onto the stack for the second pass. */
7555 vinfo.type = gnu_variant_type;
7556 vinfo.name = gnu_inner_name;
7557 vinfo.qual = gnu_qual;
7558 vinfo.has_rep = has_rep;
7559 vinfo.packed = field_packed;
7560 variant_types.safe_push (vinfo);
7562 /* Compute the global properties that will determine the placement of
7563 the variant part. */
7564 variants_have_rep |= has_rep;
7565 if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align)
7566 variants_align = TYPE_ALIGN (gnu_variant_type);
7569 /* Round up the first free position to the alignment of the variant part
7570 for the variants without rep clause. This will guarantee a consistent
7571 layout independently of the placement of the variant part. */
7572 if (variants_have_rep && variants_align > 0 && this_first_free_pos)
7573 this_first_free_pos = round_up (this_first_free_pos, variants_align);
7575 /* In the second pass, the container types are adjusted if necessary and
7576 finished up, then the corresponding fields of the variant part are
7577 built with their qualifier, unless this is an unchecked union. */
7578 FOR_EACH_VEC_ELT (variant_types, i, gnu_variant)
7580 tree gnu_variant_type = gnu_variant->type;
7581 tree gnu_field_list = TYPE_FIELDS (gnu_variant_type);
7583 /* If this is an Unchecked_Union whose fields are all in the variant
7584 part and we have a single field with no representation clause or
7585 placed at offset zero, use the field directly to match the layout
7586 of C unions. */
7587 if (TREE_CODE (gnu_record_type) == UNION_TYPE
7588 && gnu_field_list
7589 && !DECL_CHAIN (gnu_field_list)
7590 && (!DECL_FIELD_OFFSET (gnu_field_list)
7591 || integer_zerop (bit_position (gnu_field_list))))
7593 gnu_field = gnu_field_list;
7594 DECL_CONTEXT (gnu_field) = gnu_record_type;
7596 else
7598 /* Finalize the variant type now. We used to throw away empty
7599 record types but we no longer do that because we need them to
7600 generate complete debug info for the variant; otherwise, the
7601 union type definition will be lacking the fields associated
7602 with these empty variants. */
7603 if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep)
7605 /* The variant part will be at offset 0 so we need to ensure
7606 that the fields are laid out starting from the first free
7607 position at this level. */
7608 tree gnu_rep_type = make_node (RECORD_TYPE);
7609 tree gnu_rep_part;
7610 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
7611 = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type);
7612 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
7613 gnu_rep_part
7614 = create_rep_part (gnu_rep_type, gnu_variant_type,
7615 this_first_free_pos);
7616 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7617 gnu_field_list = gnu_rep_part;
7618 finish_record_type (gnu_variant_type, gnu_field_list, 0,
7619 false);
7622 if (debug_info)
7623 rest_of_record_type_compilation (gnu_variant_type);
7624 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7625 true, needs_xv_encodings, gnat_component_list);
7627 gnu_field
7628 = create_field_decl (gnu_variant->name, gnu_variant_type,
7629 gnu_union_type,
7630 all_rep_and_size
7631 ? TYPE_SIZE (gnu_variant_type) : 0,
7632 variants_have_rep ? bitsize_zero_node : 0,
7633 gnu_variant->packed, 0);
7635 DECL_INTERNAL_P (gnu_field) = 1;
7637 if (!unchecked_union)
7638 DECL_QUALIFIER (gnu_field) = gnu_variant->qual;
7641 DECL_CHAIN (gnu_field) = gnu_variant_list;
7642 gnu_variant_list = gnu_field;
7645 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7646 if (gnu_variant_list)
7648 int union_field_packed;
7650 if (all_rep_and_size)
7652 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7653 TYPE_SIZE_UNIT (gnu_union_type)
7654 = TYPE_SIZE_UNIT (gnu_record_type);
7657 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7658 all_rep_and_size ? 1 : 0, needs_xv_encodings);
7660 /* If GNU_UNION_TYPE is our record type, it means we must have an
7661 Unchecked_Union with no fields. Verify that and, if so, just
7662 return. */
7663 if (gnu_union_type == gnu_record_type)
7665 gcc_assert (unchecked_union
7666 && !gnu_field_list
7667 && !gnu_rep_list);
7668 return variants_have_rep;
7671 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true,
7672 needs_xv_encodings, gnat_component_list);
7674 /* Deal with packedness like in gnat_to_gnu_field. */
7675 if (union_field_needs_strict_alignment)
7676 union_field_packed = 0;
7677 else
7678 union_field_packed
7679 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7681 gnu_variant_part
7682 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7683 all_rep_and_size
7684 ? TYPE_SIZE (gnu_union_type) : 0,
7685 variants_have_rep ? bitsize_zero_node : 0,
7686 union_field_packed, 0);
7688 DECL_INTERNAL_P (gnu_variant_part) = 1;
7692 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
7693 pull them out and put them onto the appropriate list. We have to do it
7694 in a separate pass since we want to handle the discriminants but can't
7695 play with them until we've used them in debugging data above.
7697 Similarly, pull out the fields with zero size and no rep clause, as they
7698 would otherwise modify the layout and thus very likely run afoul of the
7699 Ada semantics, which are different from those of C here.
7701 Finally, if there is an aliased field placed in the list after fields
7702 with self-referential size, pull out the latter in the same way.
7704 Optionally, if the reordering mechanism is enabled, pull out the fields
7705 with self-referential size, variable size and fixed size not a multiple
7706 of a byte, so that they don't cause the regular fields to be either at
7707 self-referential/variable offset or misaligned. Note, in the latter
7708 case, that this can only happen in packed record types so the alignment
7709 is effectively capped to the byte for the whole record.
7711 Optionally, if the layout warning is enabled, keep track of the above 4
7712 different kinds of fields and issue a warning if some of them would be
7713 (or are being) reordered by the reordering mechanism.
7715 Finally, pull out the fields whose size is not a multiple of a byte, so
7716 that they don't cause the regular fields to be misaligned. As this can
7717 only happen in packed record types, the alignment is capped to the byte.
7719 ??? If we reorder them, debugging information will be wrong but there is
7720 nothing that can be done about this at the moment. */
7721 const bool do_reorder = OK_To_Reorder_Components (gnat_record_type);
7722 const bool w_reorder
7723 = Warn_On_Questionable_Layout
7724 && (Convention (gnat_record_type) == Convention_Ada);
7725 const bool in_variant = (p_gnu_rep_list != NULL);
7726 tree gnu_zero_list = NULL_TREE;
7727 tree gnu_self_list = NULL_TREE;
7728 tree gnu_var_list = NULL_TREE;
7729 tree gnu_bitp_list = NULL_TREE;
7730 tree gnu_tmp_bitp_list = NULL_TREE;
7731 unsigned int tmp_bitp_size = 0;
7732 unsigned int last_reorder_field_type = -1;
7733 unsigned int tmp_last_reorder_field_type = -1;
7735 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7736 do { \
7737 if (gnu_last) \
7738 DECL_CHAIN (gnu_last) = gnu_next; \
7739 else \
7740 gnu_field_list = gnu_next; \
7742 DECL_CHAIN (gnu_field) = (LIST); \
7743 (LIST) = gnu_field; \
7744 } while (0)
7746 gnu_last = NULL_TREE;
7747 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7749 gnu_next = DECL_CHAIN (gnu_field);
7751 if (DECL_FIELD_OFFSET (gnu_field))
7753 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7754 continue;
7757 if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
7759 DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
7760 SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
7761 DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
7762 if (DECL_ALIASED_P (gnu_field))
7763 SET_TYPE_ALIGN (gnu_record_type,
7764 MAX (TYPE_ALIGN (gnu_record_type),
7765 TYPE_ALIGN (TREE_TYPE (gnu_field))));
7766 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
7767 continue;
7770 if (has_aliased_after_self_field && field_has_self_size (gnu_field))
7772 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7773 continue;
7776 /* We don't need further processing in default mode. */
7777 if (!w_reorder && !do_reorder)
7779 gnu_last = gnu_field;
7780 continue;
7783 if (field_has_self_size (gnu_field))
7785 if (w_reorder)
7787 if (last_reorder_field_type < 4)
7788 warn_on_field_placement (gnu_field, gnat_component_list,
7789 gnat_record_type, in_variant,
7790 do_reorder);
7791 else
7792 last_reorder_field_type = 4;
7795 if (do_reorder)
7797 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7798 continue;
7802 else if (field_has_variable_size (gnu_field))
7804 if (w_reorder)
7806 if (last_reorder_field_type < 3)
7807 warn_on_field_placement (gnu_field, gnat_component_list,
7808 gnat_record_type, in_variant,
7809 do_reorder);
7810 else
7811 last_reorder_field_type = 3;
7814 if (do_reorder)
7816 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7817 continue;
7821 else
7823 /* If the field has no size, then it cannot be bit-packed. */
7824 const unsigned int bitp_size
7825 = DECL_SIZE (gnu_field)
7826 ? TREE_INT_CST_LOW (DECL_SIZE (gnu_field)) % BITS_PER_UNIT
7827 : 0;
7829 /* If the field is bit-packed, we move it to a temporary list that
7830 contains the contiguously preceding bit-packed fields, because
7831 we want to be able to put them back if the misalignment happens
7832 to cancel itself after several bit-packed fields. */
7833 if (bitp_size != 0)
7835 tmp_bitp_size = (tmp_bitp_size + bitp_size) % BITS_PER_UNIT;
7837 if (last_reorder_field_type != 2)
7839 tmp_last_reorder_field_type = last_reorder_field_type;
7840 last_reorder_field_type = 2;
7843 if (do_reorder)
7845 MOVE_FROM_FIELD_LIST_TO (gnu_tmp_bitp_list);
7846 continue;
7850 /* No more bit-packed fields, move the existing ones to the end or
7851 put them back at their original location. */
7852 else if (last_reorder_field_type == 2 || gnu_tmp_bitp_list)
7854 last_reorder_field_type = 1;
7856 if (tmp_bitp_size != 0)
7858 if (w_reorder && tmp_last_reorder_field_type < 2)
7859 warn_on_field_placement (gnu_tmp_bitp_list
7860 ? gnu_tmp_bitp_list : gnu_last,
7861 gnat_component_list,
7862 gnat_record_type, in_variant,
7863 do_reorder);
7865 if (do_reorder)
7866 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
7868 gnu_tmp_bitp_list = NULL_TREE;
7869 tmp_bitp_size = 0;
7871 else
7873 /* Rechain the temporary list in front of GNU_FIELD. */
7874 tree gnu_bitp_field = gnu_field;
7875 while (gnu_tmp_bitp_list)
7877 tree gnu_bitp_next = DECL_CHAIN (gnu_tmp_bitp_list);
7878 DECL_CHAIN (gnu_tmp_bitp_list) = gnu_bitp_field;
7879 if (gnu_last)
7880 DECL_CHAIN (gnu_last) = gnu_tmp_bitp_list;
7881 else
7882 gnu_field_list = gnu_tmp_bitp_list;
7883 gnu_bitp_field = gnu_tmp_bitp_list;
7884 gnu_tmp_bitp_list = gnu_bitp_next;
7889 else
7890 last_reorder_field_type = 1;
7893 gnu_last = gnu_field;
7896 #undef MOVE_FROM_FIELD_LIST_TO
7898 gnu_field_list = nreverse (gnu_field_list);
7900 /* If permitted, we reorder the fields as follows:
7902 1) all (groups of) fields whose length is fixed and multiple of a byte,
7903 2) the remaining fields whose length is fixed and not multiple of a byte,
7904 3) the remaining fields whose length doesn't depend on discriminants,
7905 4) all fields whose length depends on discriminants,
7906 5) the variant part,
7908 within the record and within each variant recursively. */
7910 if (w_reorder)
7912 /* If we have pending bit-packed fields, warn if they would be moved
7913 to after regular fields. */
7914 if (last_reorder_field_type == 2
7915 && tmp_bitp_size != 0
7916 && tmp_last_reorder_field_type < 2)
7917 warn_on_field_placement (gnu_tmp_bitp_list
7918 ? gnu_tmp_bitp_list : gnu_field_list,
7919 gnat_component_list, gnat_record_type,
7920 in_variant, do_reorder);
7923 if (do_reorder)
7925 /* If we have pending bit-packed fields on the temporary list, we put
7926 them either on the bit-packed list or back on the regular list. */
7927 if (gnu_tmp_bitp_list)
7929 if (tmp_bitp_size != 0)
7930 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
7931 else
7932 gnu_field_list = chainon (gnu_tmp_bitp_list, gnu_field_list);
7935 gnu_field_list
7936 = chainon (gnu_field_list,
7937 chainon (gnu_bitp_list,
7938 chainon (gnu_var_list, gnu_self_list)));
7941 /* Otherwise, if there is an aliased field placed after a field whose length
7942 depends on discriminants, we put all the fields of the latter sort, last.
7943 We need to do this in case an object of this record type is mutable. */
7944 else if (has_aliased_after_self_field)
7945 gnu_field_list = chainon (gnu_field_list, gnu_self_list);
7947 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7948 in our REP list to the previous level because this level needs them in
7949 order to do a correct layout, i.e. avoid having overlapping fields. */
7950 if (p_gnu_rep_list && gnu_rep_list)
7951 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7953 /* Deal with the annoying case of an extension of a record with variable size
7954 and partial rep clause, for which the _Parent field is forced at offset 0
7955 and has variable size, which we do not support below. Note that we cannot
7956 do it if the field has fixed size because we rely on the presence of the
7957 REP part built below to trigger the reordering of the fields in a derived
7958 record type when all the fields have a fixed position. */
7959 else if (gnu_rep_list
7960 && !DECL_CHAIN (gnu_rep_list)
7961 && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
7962 && !variants_have_rep
7963 && first_free_pos
7964 && integer_zerop (first_free_pos)
7965 && integer_zerop (bit_position (gnu_rep_list)))
7967 DECL_CHAIN (gnu_rep_list) = gnu_field_list;
7968 gnu_field_list = gnu_rep_list;
7969 gnu_rep_list = NULL_TREE;
7972 /* Otherwise, sort the fields by bit position and put them into their own
7973 record, before the others, if we also have fields without rep clause. */
7974 else if (gnu_rep_list)
7976 tree gnu_rep_type, gnu_rep_part;
7977 int i, len = list_length (gnu_rep_list);
7978 tree *gnu_arr = XALLOCAVEC (tree, len);
7980 /* If all the fields have a rep clause, we can do a flat layout. */
7981 layout_with_rep = !gnu_field_list
7982 && (!gnu_variant_part || variants_have_rep);
7983 gnu_rep_type
7984 = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE);
7986 for (gnu_field = gnu_rep_list, i = 0;
7987 gnu_field;
7988 gnu_field = DECL_CHAIN (gnu_field), i++)
7989 gnu_arr[i] = gnu_field;
7991 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7993 /* Put the fields in the list in order of increasing position, which
7994 means we start from the end. */
7995 gnu_rep_list = NULL_TREE;
7996 for (i = len - 1; i >= 0; i--)
7998 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
7999 gnu_rep_list = gnu_arr[i];
8000 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
8003 if (layout_with_rep)
8004 gnu_field_list = gnu_rep_list;
8005 else
8007 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
8008 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
8009 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
8011 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
8012 without rep clause are laid out starting from this position.
8013 Therefore, we force it as a minimal size on the REP part. */
8014 gnu_rep_part
8015 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
8017 /* Chain the REP part at the beginning of the field list. */
8018 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
8019 gnu_field_list = gnu_rep_part;
8023 /* Chain the variant part at the end of the field list. */
8024 if (gnu_variant_part)
8025 gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
8027 if (cancel_alignment)
8028 SET_TYPE_ALIGN (gnu_record_type, 0);
8030 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
8032 finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0,
8033 debug_info && !maybe_unused);
8035 /* Chain the fields with zero size at the beginning of the field list. */
8036 if (gnu_zero_list)
8037 TYPE_FIELDS (gnu_record_type)
8038 = chainon (gnu_zero_list, TYPE_FIELDS (gnu_record_type));
8040 return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
8043 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
8044 placed into an Esize, Component_Bit_Offset, or Component_Size value
8045 in the GNAT tree. */
8047 static Uint
8048 annotate_value (tree gnu_size)
8050 TCode tcode;
8051 Node_Ref_Or_Val ops[3], ret, pre_op1 = No_Uint;
8052 struct tree_int_map in;
8053 int i;
8055 /* See if we've already saved the value for this node. */
8056 if (EXPR_P (gnu_size))
8058 struct tree_int_map *e;
8060 in.base.from = gnu_size;
8061 e = annotate_value_cache->find (&in);
8063 if (e)
8064 return (Node_Ref_Or_Val) e->to;
8066 else
8067 in.base.from = NULL_TREE;
8069 /* If we do not return inside this switch, TCODE will be set to the
8070 code to use for a Create_Node operand and LEN (set above) will be
8071 the number of recursive calls for us to make. */
8073 switch (TREE_CODE (gnu_size))
8075 case INTEGER_CST:
8076 /* For negative values, build NEGATE_EXPR of the opposite. Such values
8077 can appear for discriminants in expressions for variants. */
8078 if (tree_int_cst_sgn (gnu_size) < 0)
8080 tree t = wide_int_to_tree (sizetype, wi::neg (gnu_size));
8081 return annotate_value (build1 (NEGATE_EXPR, sizetype, t));
8084 return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
8086 case COMPONENT_REF:
8087 /* The only case we handle here is a simple discriminant reference. */
8088 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
8090 tree n = DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1));
8092 /* Climb up the chain of successive extensions, if any. */
8093 while (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == COMPONENT_REF
8094 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 1))
8095 == parent_name_id)
8096 gnu_size = TREE_OPERAND (gnu_size, 0);
8098 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR)
8099 return
8100 Create_Node (Discrim_Val, annotate_value (n), No_Uint, No_Uint);
8103 return No_Uint;
8105 CASE_CONVERT: case NON_LVALUE_EXPR:
8106 return annotate_value (TREE_OPERAND (gnu_size, 0));
8108 /* Now just list the operations we handle. */
8109 case COND_EXPR: tcode = Cond_Expr; break;
8110 case PLUS_EXPR: tcode = Plus_Expr; break;
8111 case MINUS_EXPR: tcode = Minus_Expr; break;
8112 case MULT_EXPR: tcode = Mult_Expr; break;
8113 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
8114 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
8115 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
8116 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
8117 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
8118 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
8119 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
8120 case NEGATE_EXPR: tcode = Negate_Expr; break;
8121 case MIN_EXPR: tcode = Min_Expr; break;
8122 case MAX_EXPR: tcode = Max_Expr; break;
8123 case ABS_EXPR: tcode = Abs_Expr; break;
8124 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
8125 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
8126 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
8127 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
8128 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
8129 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
8130 case LT_EXPR: tcode = Lt_Expr; break;
8131 case LE_EXPR: tcode = Le_Expr; break;
8132 case GT_EXPR: tcode = Gt_Expr; break;
8133 case GE_EXPR: tcode = Ge_Expr; break;
8134 case EQ_EXPR: tcode = Eq_Expr; break;
8135 case NE_EXPR: tcode = Ne_Expr; break;
8137 case BIT_AND_EXPR:
8138 tcode = Bit_And_Expr;
8139 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
8140 Such values appear in expressions with aligning patterns. Note that,
8141 since sizetype is unsigned, we have to jump through some hoops. */
8142 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
8144 tree op1 = TREE_OPERAND (gnu_size, 1);
8145 wide_int signed_op1 = wi::sext (op1, TYPE_PRECISION (sizetype));
8146 if (wi::neg_p (signed_op1))
8148 op1 = wide_int_to_tree (sizetype, wi::neg (signed_op1));
8149 pre_op1 = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
8152 break;
8154 case CALL_EXPR:
8155 /* In regular mode, inline back only if symbolic annotation is requested
8156 in order to avoid memory explosion on big discriminated record types.
8157 But not in ASIS mode, as symbolic annotation is required for DDA. */
8158 if (List_Representation_Info == 3 || type_annotate_only)
8160 tree t = maybe_inline_call_in_expr (gnu_size);
8161 if (t)
8162 return annotate_value (t);
8164 else
8165 return Uint_Minus_1;
8167 /* Fall through... */
8169 default:
8170 return No_Uint;
8173 /* Now get each of the operands that's relevant for this code. If any
8174 cannot be expressed as a repinfo node, say we can't. */
8175 for (i = 0; i < 3; i++)
8176 ops[i] = No_Uint;
8178 for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
8180 if (i == 1 && pre_op1 != No_Uint)
8181 ops[i] = pre_op1;
8182 else
8183 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
8184 if (ops[i] == No_Uint)
8185 return No_Uint;
8188 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
8190 /* Save the result in the cache. */
8191 if (in.base.from)
8193 struct tree_int_map **h;
8194 /* We can't assume the hash table data hasn't moved since the initial
8195 look up, so we have to search again. Allocating and inserting an
8196 entry at that point would be an alternative, but then we'd better
8197 discard the entry if we decided not to cache it. */
8198 h = annotate_value_cache->find_slot (&in, INSERT);
8199 gcc_assert (!*h);
8200 *h = ggc_alloc<tree_int_map> ();
8201 (*h)->base.from = gnu_size;
8202 (*h)->to = ret;
8205 return ret;
8208 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
8209 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
8210 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
8211 BY_REF is true if the object is used by reference. */
8213 void
8214 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
8216 if (by_ref)
8218 if (TYPE_IS_FAT_POINTER_P (gnu_type))
8219 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
8220 else
8221 gnu_type = TREE_TYPE (gnu_type);
8224 if (Unknown_Esize (gnat_entity))
8226 if (TREE_CODE (gnu_type) == RECORD_TYPE
8227 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8228 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
8229 else if (!size)
8230 size = TYPE_SIZE (gnu_type);
8232 if (size)
8233 Set_Esize (gnat_entity, annotate_value (size));
8236 if (Unknown_Alignment (gnat_entity))
8237 Set_Alignment (gnat_entity,
8238 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
8241 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
8242 Return NULL_TREE if there is no such element in the list. */
8244 static tree
8245 purpose_member_field (const_tree elem, tree list)
8247 while (list)
8249 tree field = TREE_PURPOSE (list);
8250 if (SAME_FIELD_P (field, elem))
8251 return list;
8252 list = TREE_CHAIN (list);
8254 return NULL_TREE;
8257 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
8258 set Component_Bit_Offset and Esize of the components to the position and
8259 size used by Gigi. */
8261 static void
8262 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
8264 /* For an extension, the inherited components have not been translated because
8265 they are fetched from the _Parent component on the fly. */
8266 const bool is_extension
8267 = Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity);
8269 /* We operate by first making a list of all fields and their position (we
8270 can get the size easily) and then update all the sizes in the tree. */
8271 tree gnu_list
8272 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
8273 BIGGEST_ALIGNMENT, NULL_TREE);
8275 for (Entity_Id gnat_field = First_Entity (gnat_entity);
8276 Present (gnat_field);
8277 gnat_field = Next_Entity (gnat_field))
8278 if ((Ekind (gnat_field) == E_Component
8279 && (is_extension || present_gnu_tree (gnat_field)))
8280 || (Ekind (gnat_field) == E_Discriminant
8281 && !Is_Unchecked_Union (Scope (gnat_field))))
8283 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
8284 gnu_list);
8285 if (t)
8287 tree parent_offset;
8289 /* If we are just annotating types and the type is tagged, the tag
8290 and the parent components are not generated by the front-end so
8291 we need to add the appropriate offset to each component without
8292 representation clause. */
8293 if (type_annotate_only
8294 && Is_Tagged_Type (gnat_entity)
8295 && No (Component_Clause (gnat_field)))
8297 /* For a component appearing in the current extension, the
8298 offset is the size of the parent. */
8299 if (Is_Derived_Type (gnat_entity)
8300 && Original_Record_Component (gnat_field) == gnat_field)
8301 parent_offset
8302 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
8303 bitsizetype);
8304 else
8305 parent_offset = bitsize_int (POINTER_SIZE);
8307 if (TYPE_FIELDS (gnu_type))
8308 parent_offset
8309 = round_up (parent_offset,
8310 DECL_ALIGN (TYPE_FIELDS (gnu_type)));
8312 else
8313 parent_offset = bitsize_zero_node;
8315 Set_Component_Bit_Offset
8316 (gnat_field,
8317 annotate_value
8318 (size_binop (PLUS_EXPR,
8319 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
8320 TREE_VEC_ELT (TREE_VALUE (t), 2)),
8321 parent_offset)));
8323 Set_Esize (gnat_field,
8324 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
8326 else if (is_extension)
8328 /* If there is no entry, this is an inherited component whose
8329 position is the same as in the parent type. */
8330 Entity_Id gnat_orig_field = Original_Record_Component (gnat_field);
8332 /* If we are just annotating types, discriminants renaming those of
8333 the parent have no entry so deal with them specifically. */
8334 if (type_annotate_only
8335 && gnat_orig_field == gnat_field
8336 && Ekind (gnat_field) == E_Discriminant)
8337 gnat_orig_field = Corresponding_Discriminant (gnat_field);
8339 Set_Component_Bit_Offset (gnat_field,
8340 Component_Bit_Offset (gnat_orig_field));
8342 Set_Esize (gnat_field, Esize (gnat_orig_field));
8347 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
8348 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
8349 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
8350 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
8351 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
8352 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
8353 pre-existing list to be chained to the newly created entries. */
8355 static tree
8356 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
8357 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
8359 tree gnu_field;
8361 for (gnu_field = TYPE_FIELDS (gnu_type);
8362 gnu_field;
8363 gnu_field = DECL_CHAIN (gnu_field))
8365 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
8366 DECL_FIELD_BIT_OFFSET (gnu_field));
8367 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
8368 DECL_FIELD_OFFSET (gnu_field));
8369 unsigned int our_offset_align
8370 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
8371 tree v = make_tree_vec (3);
8373 TREE_VEC_ELT (v, 0) = gnu_our_offset;
8374 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
8375 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
8376 gnu_list = tree_cons (gnu_field, v, gnu_list);
8378 /* Recurse on internal fields, flattening the nested fields except for
8379 those in the variant part, if requested. */
8380 if (DECL_INTERNAL_P (gnu_field))
8382 tree gnu_field_type = TREE_TYPE (gnu_field);
8383 if (do_not_flatten_variant
8384 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
8385 gnu_list
8386 = build_position_list (gnu_field_type, do_not_flatten_variant,
8387 size_zero_node, bitsize_zero_node,
8388 BIGGEST_ALIGNMENT, gnu_list);
8389 else
8390 gnu_list
8391 = build_position_list (gnu_field_type, do_not_flatten_variant,
8392 gnu_our_offset, gnu_our_bitpos,
8393 our_offset_align, gnu_list);
8397 return gnu_list;
8400 /* Return a list describing the substitutions needed to reflect the
8401 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
8402 be in any order. The values in an element of the list are in the form
8403 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
8404 a definition of GNAT_SUBTYPE. */
8406 static vec<subst_pair>
8407 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
8409 vec<subst_pair> gnu_list = vNULL;
8410 Entity_Id gnat_discrim;
8411 Node_Id gnat_constr;
8413 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
8414 gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
8415 Present (gnat_discrim);
8416 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
8417 gnat_constr = Next_Elmt (gnat_constr))
8418 /* Ignore access discriminants. */
8419 if (!Is_Access_Type (Etype (Node (gnat_constr))))
8421 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
8422 tree replacement = convert (TREE_TYPE (gnu_field),
8423 elaborate_expression
8424 (Node (gnat_constr), gnat_subtype,
8425 get_entity_char (gnat_discrim),
8426 definition, true, false));
8427 subst_pair s = { gnu_field, replacement };
8428 gnu_list.safe_push (s);
8431 return gnu_list;
8434 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
8435 variants of QUAL_UNION_TYPE that are still relevant after applying
8436 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
8437 list to be prepended to the newly created entries. */
8439 static vec<variant_desc>
8440 build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
8441 vec<variant_desc> gnu_list)
8443 tree gnu_field;
8445 for (gnu_field = TYPE_FIELDS (qual_union_type);
8446 gnu_field;
8447 gnu_field = DECL_CHAIN (gnu_field))
8449 tree qual = DECL_QUALIFIER (gnu_field);
8450 unsigned int i;
8451 subst_pair *s;
8453 FOR_EACH_VEC_ELT (subst_list, i, s)
8454 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
8456 /* If the new qualifier is not unconditionally false, its variant may
8457 still be accessed. */
8458 if (!integer_zerop (qual))
8460 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
8461 variant_desc v = { variant_type, gnu_field, qual, NULL_TREE };
8463 gnu_list.safe_push (v);
8465 /* Recurse on the variant subpart of the variant, if any. */
8466 variant_subpart = get_variant_part (variant_type);
8467 if (variant_subpart)
8468 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
8469 subst_list, gnu_list);
8471 /* If the new qualifier is unconditionally true, the subsequent
8472 variants cannot be accessed. */
8473 if (integer_onep (qual))
8474 break;
8478 return gnu_list;
8481 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
8482 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
8483 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
8484 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
8485 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
8486 true if we are being called to process the Component_Size of GNAT_OBJECT;
8487 this is used only for error messages. ZERO_OK is true if a size of zero
8488 is permitted; if ZERO_OK is false, it means that a size of zero should be
8489 treated as an unspecified size. */
8491 static tree
8492 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
8493 enum tree_code kind, bool component_p, bool zero_ok)
8495 Node_Id gnat_error_node;
8496 tree type_size, size;
8498 /* Return 0 if no size was specified. */
8499 if (uint_size == No_Uint)
8500 return NULL_TREE;
8502 /* Ignore a negative size since that corresponds to our back-annotation. */
8503 if (UI_Lt (uint_size, Uint_0))
8504 return NULL_TREE;
8506 /* Find the node to use for error messages. */
8507 if ((Ekind (gnat_object) == E_Component
8508 || Ekind (gnat_object) == E_Discriminant)
8509 && Present (Component_Clause (gnat_object)))
8510 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
8511 else if (Present (Size_Clause (gnat_object)))
8512 gnat_error_node = Expression (Size_Clause (gnat_object));
8513 else
8514 gnat_error_node = gnat_object;
8516 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8517 but cannot be represented in bitsizetype. */
8518 size = UI_To_gnu (uint_size, bitsizetype);
8519 if (TREE_OVERFLOW (size))
8521 if (component_p)
8522 post_error_ne ("component size for& is too large", gnat_error_node,
8523 gnat_object);
8524 else
8525 post_error_ne ("size for& is too large", gnat_error_node,
8526 gnat_object);
8527 return NULL_TREE;
8530 /* Ignore a zero size if it is not permitted. */
8531 if (!zero_ok && integer_zerop (size))
8532 return NULL_TREE;
8534 /* The size of objects is always a multiple of a byte. */
8535 if (kind == VAR_DECL
8536 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
8538 if (component_p)
8539 post_error_ne ("component size for& is not a multiple of Storage_Unit",
8540 gnat_error_node, gnat_object);
8541 else
8542 post_error_ne ("size for& is not a multiple of Storage_Unit",
8543 gnat_error_node, gnat_object);
8544 return NULL_TREE;
8547 /* If this is an integral type or a packed array type, the front-end has
8548 already verified the size, so we need not do it here (which would mean
8549 checking against the bounds). However, if this is an aliased object,
8550 it may not be smaller than the type of the object. */
8551 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
8552 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
8553 return size;
8555 /* If the object is a record that contains a template, add the size of the
8556 template to the specified size. */
8557 if (TREE_CODE (gnu_type) == RECORD_TYPE
8558 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8559 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
8561 if (kind == VAR_DECL
8562 /* If a type needs strict alignment, a component of this type in
8563 a packed record cannot be packed and thus uses the type size. */
8564 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
8565 type_size = TYPE_SIZE (gnu_type);
8566 else
8567 type_size = rm_size (gnu_type);
8569 /* Modify the size of a discriminated type to be the maximum size. */
8570 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
8571 type_size = max_size (type_size, true);
8573 /* If this is an access type or a fat pointer, the minimum size is that given
8574 by the smallest integral mode that's valid for pointers. */
8575 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
8577 scalar_int_mode p_mode = NARROWEST_INT_MODE;
8578 while (!targetm.valid_pointer_mode (p_mode))
8579 p_mode = GET_MODE_WIDER_MODE (p_mode).require ();
8580 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
8583 /* Issue an error either if the default size of the object isn't a constant
8584 or if the new size is smaller than it. */
8585 if (TREE_CODE (type_size) != INTEGER_CST
8586 || TREE_OVERFLOW (type_size)
8587 || tree_int_cst_lt (size, type_size))
8589 if (component_p)
8590 post_error_ne_tree
8591 ("component size for& too small{, minimum allowed is ^}",
8592 gnat_error_node, gnat_object, type_size);
8593 else
8594 post_error_ne_tree
8595 ("size for& too small{, minimum allowed is ^}",
8596 gnat_error_node, gnat_object, type_size);
8597 return NULL_TREE;
8600 return size;
8603 /* Similarly, but both validate and process a value of RM size. This routine
8604 is only called for types. */
8606 static void
8607 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
8609 Node_Id gnat_attr_node;
8610 tree old_size, size;
8612 /* Do nothing if no size was specified. */
8613 if (uint_size == No_Uint)
8614 return;
8616 /* Ignore a negative size since that corresponds to our back-annotation. */
8617 if (UI_Lt (uint_size, Uint_0))
8618 return;
8620 /* Only issue an error if a Value_Size clause was explicitly given.
8621 Otherwise, we'd be duplicating an error on the Size clause. */
8622 gnat_attr_node
8623 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
8625 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8626 but cannot be represented in bitsizetype. */
8627 size = UI_To_gnu (uint_size, bitsizetype);
8628 if (TREE_OVERFLOW (size))
8630 if (Present (gnat_attr_node))
8631 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8632 gnat_entity);
8633 return;
8636 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8637 exists, or this is an integer type, in which case the front-end will
8638 have always set it. */
8639 if (No (gnat_attr_node)
8640 && integer_zerop (size)
8641 && !Has_Size_Clause (gnat_entity)
8642 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8643 return;
8645 old_size = rm_size (gnu_type);
8647 /* If the old size is self-referential, get the maximum size. */
8648 if (CONTAINS_PLACEHOLDER_P (old_size))
8649 old_size = max_size (old_size, true);
8651 /* Issue an error either if the old size of the object isn't a constant or
8652 if the new size is smaller than it. The front-end has already verified
8653 this for scalar and packed array types. */
8654 if (TREE_CODE (old_size) != INTEGER_CST
8655 || TREE_OVERFLOW (old_size)
8656 || (AGGREGATE_TYPE_P (gnu_type)
8657 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8658 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8659 && !(TYPE_IS_PADDING_P (gnu_type)
8660 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8661 && TYPE_PACKED_ARRAY_TYPE_P
8662 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8663 && tree_int_cst_lt (size, old_size)))
8665 if (Present (gnat_attr_node))
8666 post_error_ne_tree
8667 ("Value_Size for& too small{, minimum allowed is ^}",
8668 gnat_attr_node, gnat_entity, old_size);
8669 return;
8672 /* Otherwise, set the RM size proper for integral types... */
8673 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8674 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8675 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8676 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8677 SET_TYPE_RM_SIZE (gnu_type, size);
8679 /* ...or the Ada size for record and union types. */
8680 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
8681 && !TYPE_FAT_POINTER_P (gnu_type))
8682 SET_TYPE_ADA_SIZE (gnu_type, size);
8685 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8686 a type or object whose present alignment is ALIGN. If this alignment is
8687 valid, return it. Otherwise, give an error and return ALIGN. */
8689 static unsigned int
8690 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8692 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8693 unsigned int new_align;
8694 Node_Id gnat_error_node;
8696 /* Don't worry about checking alignment if alignment was not specified
8697 by the source program and we already posted an error for this entity. */
8698 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8699 return align;
8701 /* Post the error on the alignment clause if any. Note, for the implicit
8702 base type of an array type, the alignment clause is on the first
8703 subtype. */
8704 if (Present (Alignment_Clause (gnat_entity)))
8705 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8707 else if (Is_Itype (gnat_entity)
8708 && Is_Array_Type (gnat_entity)
8709 && Etype (gnat_entity) == gnat_entity
8710 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8711 gnat_error_node =
8712 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8714 else
8715 gnat_error_node = gnat_entity;
8717 /* Within GCC, an alignment is an integer, so we must make sure a value is
8718 specified that fits in that range. Also, there is an upper bound to
8719 alignments we can support/allow. */
8720 if (!UI_Is_In_Int_Range (alignment)
8721 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8722 post_error_ne_num ("largest supported alignment for& is ^",
8723 gnat_error_node, gnat_entity, max_allowed_alignment);
8724 else if (!(Present (Alignment_Clause (gnat_entity))
8725 && From_At_Mod (Alignment_Clause (gnat_entity)))
8726 && new_align * BITS_PER_UNIT < align)
8728 unsigned int double_align;
8729 bool is_capped_double, align_clause;
8731 /* If the default alignment of "double" or larger scalar types is
8732 specifically capped and the new alignment is above the cap, do
8733 not post an error and change the alignment only if there is an
8734 alignment clause; this makes it possible to have the associated
8735 GCC type overaligned by default for performance reasons. */
8736 if ((double_align = double_float_alignment) > 0)
8738 Entity_Id gnat_type
8739 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8740 is_capped_double
8741 = is_double_float_or_array (gnat_type, &align_clause);
8743 else if ((double_align = double_scalar_alignment) > 0)
8745 Entity_Id gnat_type
8746 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8747 is_capped_double
8748 = is_double_scalar_or_array (gnat_type, &align_clause);
8750 else
8751 is_capped_double = align_clause = false;
8753 if (is_capped_double && new_align >= double_align)
8755 if (align_clause)
8756 align = new_align * BITS_PER_UNIT;
8758 else
8760 if (is_capped_double)
8761 align = double_align * BITS_PER_UNIT;
8763 post_error_ne_num ("alignment for& must be at least ^",
8764 gnat_error_node, gnat_entity,
8765 align / BITS_PER_UNIT);
8768 else
8770 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8771 if (new_align > align)
8772 align = new_align;
8775 return align;
8778 /* Verify that TYPE is something we can implement atomically. If not, issue
8779 an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
8780 process a component type. */
8782 static void
8783 check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p)
8785 Node_Id gnat_error_point = gnat_entity;
8786 Node_Id gnat_node;
8787 machine_mode mode;
8788 enum mode_class mclass;
8789 unsigned int align;
8790 tree size;
8792 /* If this is an anonymous base type, nothing to check, the error will be
8793 reported on the source type if need be. */
8794 if (!Comes_From_Source (gnat_entity))
8795 return;
8797 mode = TYPE_MODE (type);
8798 mclass = GET_MODE_CLASS (mode);
8799 align = TYPE_ALIGN (type);
8800 size = TYPE_SIZE (type);
8802 /* Consider all aligned floating-point types atomic and any aligned types
8803 that are represented by integers no wider than a machine word. */
8804 scalar_int_mode int_mode;
8805 if ((mclass == MODE_FLOAT
8806 || (is_a <scalar_int_mode> (mode, &int_mode)
8807 && GET_MODE_BITSIZE (int_mode) <= BITS_PER_WORD))
8808 && align >= GET_MODE_ALIGNMENT (mode))
8809 return;
8811 /* For the moment, also allow anything that has an alignment equal to its
8812 size and which is smaller than a word. */
8813 if (size
8814 && TREE_CODE (size) == INTEGER_CST
8815 && compare_tree_int (size, align) == 0
8816 && align <= BITS_PER_WORD)
8817 return;
8819 for (gnat_node = First_Rep_Item (gnat_entity);
8820 Present (gnat_node);
8821 gnat_node = Next_Rep_Item (gnat_node))
8822 if (Nkind (gnat_node) == N_Pragma)
8824 unsigned char pragma_id
8825 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
8827 if ((pragma_id == Pragma_Atomic && !component_p)
8828 || (pragma_id == Pragma_Atomic_Components && component_p))
8830 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8831 break;
8835 if (component_p)
8836 post_error_ne ("atomic access to component of & cannot be guaranteed",
8837 gnat_error_point, gnat_entity);
8838 else if (Is_Volatile_Full_Access (gnat_entity))
8839 post_error_ne ("volatile full access to & cannot be guaranteed",
8840 gnat_error_point, gnat_entity);
8841 else
8842 post_error_ne ("atomic access to & cannot be guaranteed",
8843 gnat_error_point, gnat_entity);
8847 /* Helper for the intrin compatibility checks family. Evaluate whether
8848 two types are definitely incompatible. */
8850 static bool
8851 intrin_types_incompatible_p (tree t1, tree t2)
8853 enum tree_code code;
8855 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8856 return false;
8858 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8859 return true;
8861 if (TREE_CODE (t1) != TREE_CODE (t2))
8862 return true;
8864 code = TREE_CODE (t1);
8866 switch (code)
8868 case INTEGER_TYPE:
8869 case REAL_TYPE:
8870 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8872 case POINTER_TYPE:
8873 case REFERENCE_TYPE:
8874 /* Assume designated types are ok. We'd need to account for char * and
8875 void * variants to do better, which could rapidly get messy and isn't
8876 clearly worth the effort. */
8877 return false;
8879 default:
8880 break;
8883 return false;
8886 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8887 on the Ada/builtin argument lists for the INB binding. */
8889 static bool
8890 intrin_arglists_compatible_p (intrin_binding_t * inb)
8892 function_args_iterator ada_iter, btin_iter;
8894 function_args_iter_init (&ada_iter, inb->ada_fntype);
8895 function_args_iter_init (&btin_iter, inb->btin_fntype);
8897 /* Sequence position of the last argument we checked. */
8898 int argpos = 0;
8900 while (true)
8902 tree ada_type = function_args_iter_cond (&ada_iter);
8903 tree btin_type = function_args_iter_cond (&btin_iter);
8905 /* If we've exhausted both lists simultaneously, we're done. */
8906 if (!ada_type && !btin_type)
8907 break;
8909 /* If one list is shorter than the other, they fail to match. */
8910 if (!ada_type || !btin_type)
8911 return false;
8913 /* If we're done with the Ada args and not with the internal builtin
8914 args, or the other way around, complain. */
8915 if (ada_type == void_type_node
8916 && btin_type != void_type_node)
8918 post_error ("?Ada arguments list too short!", inb->gnat_entity);
8919 return false;
8922 if (btin_type == void_type_node
8923 && ada_type != void_type_node)
8925 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
8926 inb->gnat_entity, inb->gnat_entity, argpos);
8927 return false;
8930 /* Otherwise, check that types match for the current argument. */
8931 argpos ++;
8932 if (intrin_types_incompatible_p (ada_type, btin_type))
8934 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
8935 inb->gnat_entity, inb->gnat_entity, argpos);
8936 return false;
8940 function_args_iter_next (&ada_iter);
8941 function_args_iter_next (&btin_iter);
8944 return true;
8947 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
8948 on the Ada/builtin return values for the INB binding. */
8950 static bool
8951 intrin_return_compatible_p (intrin_binding_t * inb)
8953 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
8954 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
8956 /* Accept function imported as procedure, common and convenient. */
8957 if (VOID_TYPE_P (ada_return_type)
8958 && !VOID_TYPE_P (btin_return_type))
8959 return true;
8961 /* Check return types compatibility otherwise. Note that this
8962 handles void/void as well. */
8963 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
8965 post_error ("?intrinsic binding type mismatch on return value!",
8966 inb->gnat_entity);
8967 return false;
8970 return true;
8973 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
8974 compatible. Issue relevant warnings when they are not.
8976 This is intended as a light check to diagnose the most obvious cases, not
8977 as a full fledged type compatibility predicate. It is the programmer's
8978 responsibility to ensure correctness of the Ada declarations in Imports,
8979 especially when binding straight to a compiler internal. */
8981 static bool
8982 intrin_profiles_compatible_p (intrin_binding_t * inb)
8984 /* Check compatibility on return values and argument lists, each responsible
8985 for posting warnings as appropriate. Ensure use of the proper sloc for
8986 this purpose. */
8988 bool arglists_compatible_p, return_compatible_p;
8989 location_t saved_location = input_location;
8991 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
8993 return_compatible_p = intrin_return_compatible_p (inb);
8994 arglists_compatible_p = intrin_arglists_compatible_p (inb);
8996 input_location = saved_location;
8998 return return_compatible_p && arglists_compatible_p;
9001 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
9002 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
9003 specified size for this field. POS_LIST is a position list describing
9004 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
9005 to this layout. */
9007 static tree
9008 create_field_decl_from (tree old_field, tree field_type, tree record_type,
9009 tree size, tree pos_list,
9010 vec<subst_pair> subst_list)
9012 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
9013 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
9014 unsigned int offset_align = tree_to_uhwi (TREE_VEC_ELT (t, 1));
9015 tree new_pos, new_field;
9016 unsigned int i;
9017 subst_pair *s;
9019 if (CONTAINS_PLACEHOLDER_P (pos))
9020 FOR_EACH_VEC_ELT (subst_list, i, s)
9021 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
9023 /* If the position is now a constant, we can set it as the position of the
9024 field when we make it. Otherwise, we need to deal with it specially. */
9025 if (TREE_CONSTANT (pos))
9026 new_pos = bit_from_pos (pos, bitpos);
9027 else
9028 new_pos = NULL_TREE;
9030 new_field
9031 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
9032 size, new_pos, DECL_PACKED (old_field),
9033 !DECL_NONADDRESSABLE_P (old_field));
9035 if (!new_pos)
9037 normalize_offset (&pos, &bitpos, offset_align);
9038 /* Finalize the position. */
9039 DECL_FIELD_OFFSET (new_field) = variable_size (pos);
9040 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
9041 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
9042 DECL_SIZE (new_field) = size;
9043 DECL_SIZE_UNIT (new_field)
9044 = convert (sizetype,
9045 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
9046 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
9049 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
9050 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
9051 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
9052 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
9054 return new_field;
9057 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
9058 it is the minimal size the REP_PART must have. */
9060 static tree
9061 create_rep_part (tree rep_type, tree record_type, tree min_size)
9063 tree field;
9065 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
9066 min_size = NULL_TREE;
9068 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
9069 min_size, NULL_TREE, 0, 1);
9070 DECL_INTERNAL_P (field) = 1;
9072 return field;
9075 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
9077 static tree
9078 get_rep_part (tree record_type)
9080 tree field = TYPE_FIELDS (record_type);
9082 /* The REP part is the first field, internal, another record, and its name
9083 starts with an 'R'. */
9084 if (field
9085 && DECL_INTERNAL_P (field)
9086 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
9087 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
9088 return field;
9090 return NULL_TREE;
9093 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
9095 tree
9096 get_variant_part (tree record_type)
9098 tree field;
9100 /* The variant part is the only internal field that is a qualified union. */
9101 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9102 if (DECL_INTERNAL_P (field)
9103 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
9104 return field;
9106 return NULL_TREE;
9109 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
9110 the list of variants to be used and RECORD_TYPE is the type of the parent.
9111 POS_LIST is a position list describing the layout of fields present in
9112 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
9113 layout. DEBUG_INFO_P is true if we need to write debug information. */
9115 static tree
9116 create_variant_part_from (tree old_variant_part,
9117 vec<variant_desc> variant_list,
9118 tree record_type, tree pos_list,
9119 vec<subst_pair> subst_list,
9120 bool debug_info_p)
9122 tree offset = DECL_FIELD_OFFSET (old_variant_part);
9123 tree old_union_type = TREE_TYPE (old_variant_part);
9124 tree new_union_type, new_variant_part;
9125 tree union_field_list = NULL_TREE;
9126 variant_desc *v;
9127 unsigned int i;
9129 /* First create the type of the variant part from that of the old one. */
9130 new_union_type = make_node (QUAL_UNION_TYPE);
9131 TYPE_NAME (new_union_type)
9132 = concat_name (TYPE_NAME (record_type),
9133 IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
9135 /* If the position of the variant part is constant, subtract it from the
9136 size of the type of the parent to get the new size. This manual CSE
9137 reduces the code size when not optimizing. */
9138 if (TREE_CODE (offset) == INTEGER_CST
9139 && TYPE_SIZE (record_type)
9140 && TYPE_SIZE_UNIT (record_type))
9142 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
9143 tree first_bit = bit_from_pos (offset, bitpos);
9144 TYPE_SIZE (new_union_type)
9145 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
9146 TYPE_SIZE_UNIT (new_union_type)
9147 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
9148 byte_from_pos (offset, bitpos));
9149 SET_TYPE_ADA_SIZE (new_union_type,
9150 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
9151 first_bit));
9152 SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
9153 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
9155 else
9156 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
9158 /* Now finish up the new variants and populate the union type. */
9159 FOR_EACH_VEC_ELT_REVERSE (variant_list, i, v)
9161 tree old_field = v->field, new_field;
9162 tree old_variant, old_variant_subpart, new_variant, field_list;
9164 /* Skip variants that don't belong to this nesting level. */
9165 if (DECL_CONTEXT (old_field) != old_union_type)
9166 continue;
9168 /* Retrieve the list of fields already added to the new variant. */
9169 new_variant = v->new_type;
9170 field_list = TYPE_FIELDS (new_variant);
9172 /* If the old variant had a variant subpart, we need to create a new
9173 variant subpart and add it to the field list. */
9174 old_variant = v->type;
9175 old_variant_subpart = get_variant_part (old_variant);
9176 if (old_variant_subpart)
9178 tree new_variant_subpart
9179 = create_variant_part_from (old_variant_subpart, variant_list,
9180 new_variant, pos_list, subst_list,
9181 debug_info_p);
9182 DECL_CHAIN (new_variant_subpart) = field_list;
9183 field_list = new_variant_subpart;
9186 /* Finish up the new variant and create the field. */
9187 finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p);
9188 compute_record_mode (new_variant);
9189 create_type_decl (TYPE_NAME (new_variant), new_variant, true,
9190 debug_info_p, Empty);
9192 new_field
9193 = create_field_decl_from (old_field, new_variant, new_union_type,
9194 TYPE_SIZE (new_variant),
9195 pos_list, subst_list);
9196 DECL_QUALIFIER (new_field) = v->qual;
9197 DECL_INTERNAL_P (new_field) = 1;
9198 DECL_CHAIN (new_field) = union_field_list;
9199 union_field_list = new_field;
9202 /* Finish up the union type and create the variant part. Note that we don't
9203 reverse the field list because VARIANT_LIST has been traversed in reverse
9204 order. */
9205 finish_record_type (new_union_type, union_field_list, 2, debug_info_p);
9206 compute_record_mode (new_union_type);
9207 create_type_decl (TYPE_NAME (new_union_type), new_union_type, true,
9208 debug_info_p, Empty);
9210 new_variant_part
9211 = create_field_decl_from (old_variant_part, new_union_type, record_type,
9212 TYPE_SIZE (new_union_type),
9213 pos_list, subst_list);
9214 DECL_INTERNAL_P (new_variant_part) = 1;
9216 /* With multiple discriminants it is possible for an inner variant to be
9217 statically selected while outer ones are not; in this case, the list
9218 of fields of the inner variant is not flattened and we end up with a
9219 qualified union with a single member. Drop the useless container. */
9220 if (!DECL_CHAIN (union_field_list))
9222 DECL_CONTEXT (union_field_list) = record_type;
9223 DECL_FIELD_OFFSET (union_field_list)
9224 = DECL_FIELD_OFFSET (new_variant_part);
9225 DECL_FIELD_BIT_OFFSET (union_field_list)
9226 = DECL_FIELD_BIT_OFFSET (new_variant_part);
9227 SET_DECL_OFFSET_ALIGN (union_field_list,
9228 DECL_OFFSET_ALIGN (new_variant_part));
9229 new_variant_part = union_field_list;
9232 return new_variant_part;
9235 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
9236 which are both RECORD_TYPE, after applying the substitutions described
9237 in SUBST_LIST. */
9239 static void
9240 copy_and_substitute_in_size (tree new_type, tree old_type,
9241 vec<subst_pair> subst_list)
9243 unsigned int i;
9244 subst_pair *s;
9246 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
9247 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
9248 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
9249 SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
9250 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
9252 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
9253 FOR_EACH_VEC_ELT (subst_list, i, s)
9254 TYPE_SIZE (new_type)
9255 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
9256 s->discriminant, s->replacement);
9258 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
9259 FOR_EACH_VEC_ELT (subst_list, i, s)
9260 TYPE_SIZE_UNIT (new_type)
9261 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
9262 s->discriminant, s->replacement);
9264 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
9265 FOR_EACH_VEC_ELT (subst_list, i, s)
9266 SET_TYPE_ADA_SIZE
9267 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
9268 s->discriminant, s->replacement));
9270 /* Finalize the size. */
9271 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
9272 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
9275 /* Return true if DISC is a stored discriminant of RECORD_TYPE. */
9277 static inline bool
9278 is_stored_discriminant (Entity_Id discr, Entity_Id record_type)
9280 if (Is_Tagged_Type (record_type))
9281 return No (Corresponding_Discriminant (discr));
9282 else if (Ekind (record_type) == E_Record_Type)
9283 return Original_Record_Component (discr) == discr;
9284 else
9285 return true;
9288 /* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are
9289 both record types, after applying the substitutions described in SUBST_LIST.
9290 DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */
9292 static void
9293 copy_and_substitute_in_layout (Entity_Id gnat_new_type,
9294 Entity_Id gnat_old_type,
9295 tree gnu_new_type,
9296 tree gnu_old_type,
9297 vec<subst_pair> gnu_subst_list,
9298 bool debug_info_p)
9300 const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
9301 tree gnu_field_list = NULL_TREE;
9302 bool selected_variant, all_constant_pos = true;
9303 vec<variant_desc> gnu_variant_list;
9305 /* Look for REP and variant parts in the old type. */
9306 tree gnu_rep_part = get_rep_part (gnu_old_type);
9307 tree gnu_variant_part = get_variant_part (gnu_old_type);
9309 /* If there is a variant part, we must compute whether the constraints
9310 statically select a particular variant. If so, we simply drop the
9311 qualified union and flatten the list of fields. Otherwise we will
9312 build a new qualified union for the variants that are still relevant. */
9313 if (gnu_variant_part)
9315 variant_desc *v;
9316 unsigned int i;
9318 gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part),
9319 gnu_subst_list, vNULL);
9321 /* If all the qualifiers are unconditionally true, the innermost variant
9322 is statically selected. */
9323 selected_variant = true;
9324 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9325 if (!integer_onep (v->qual))
9327 selected_variant = false;
9328 break;
9331 /* Otherwise, create the new variants. */
9332 if (!selected_variant)
9333 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9335 tree old_variant = v->type;
9336 tree new_variant = make_node (RECORD_TYPE);
9337 tree suffix
9338 = concat_name (DECL_NAME (gnu_variant_part),
9339 IDENTIFIER_POINTER (DECL_NAME (v->field)));
9340 TYPE_NAME (new_variant)
9341 = concat_name (TYPE_NAME (gnu_new_type),
9342 IDENTIFIER_POINTER (suffix));
9343 TYPE_REVERSE_STORAGE_ORDER (new_variant)
9344 = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
9345 copy_and_substitute_in_size (new_variant, old_variant,
9346 gnu_subst_list);
9347 v->new_type = new_variant;
9350 else
9352 gnu_variant_list.create (0);
9353 selected_variant = false;
9356 /* Make a list of fields and their position in the old type. */
9357 tree gnu_pos_list
9358 = build_position_list (gnu_old_type,
9359 gnu_variant_list.exists () && !selected_variant,
9360 size_zero_node, bitsize_zero_node,
9361 BIGGEST_ALIGNMENT, NULL_TREE);
9363 /* Now go down every component in the new type and compute its size and
9364 position from those of the component in the old type and the stored
9365 constraints of the new type. */
9366 Entity_Id gnat_field, gnat_old_field;
9367 for (gnat_field = First_Entity (gnat_new_type);
9368 Present (gnat_field);
9369 gnat_field = Next_Entity (gnat_field))
9370 if ((Ekind (gnat_field) == E_Component
9371 || (Ekind (gnat_field) == E_Discriminant
9372 && is_stored_discriminant (gnat_field, gnat_new_type)))
9373 && (gnat_old_field = is_subtype
9374 ? Original_Record_Component (gnat_field)
9375 : Corresponding_Record_Component (gnat_field))
9376 && Underlying_Type (Scope (gnat_old_field)) == gnat_old_type
9377 && present_gnu_tree (gnat_old_field))
9379 Name_Id gnat_name = Chars (gnat_field);
9380 tree gnu_old_field = get_gnu_tree (gnat_old_field);
9381 if (TREE_CODE (gnu_old_field) == COMPONENT_REF)
9382 gnu_old_field = TREE_OPERAND (gnu_old_field, 1);
9383 tree gnu_context = DECL_CONTEXT (gnu_old_field);
9384 tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
9385 tree gnu_cont_type, gnu_last = NULL_TREE;
9387 /* If the type is the same, retrieve the GCC type from the
9388 old field to take into account possible adjustments. */
9389 if (Etype (gnat_field) == Etype (gnat_old_field))
9390 gnu_field_type = TREE_TYPE (gnu_old_field);
9391 else
9392 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
9394 /* If there was a component clause, the field types must be the same
9395 for the old and new types, so copy the data from the old field to
9396 avoid recomputation here. Also if the field is justified modular
9397 and the optimization in gnat_to_gnu_field was applied. */
9398 if (Present (Component_Clause (gnat_old_field))
9399 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
9400 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
9401 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
9402 == TREE_TYPE (gnu_old_field)))
9404 gnu_size = DECL_SIZE (gnu_old_field);
9405 gnu_field_type = TREE_TYPE (gnu_old_field);
9408 /* If the old field was packed and of constant size, we have to get the
9409 old size here as it might differ from what the Etype conveys and the
9410 latter might overlap with the following field. Try to arrange the
9411 type for possible better packing along the way. */
9412 else if (DECL_PACKED (gnu_old_field)
9413 && TREE_CODE (DECL_SIZE (gnu_old_field)) == INTEGER_CST)
9415 gnu_size = DECL_SIZE (gnu_old_field);
9416 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
9417 && !TYPE_FAT_POINTER_P (gnu_field_type)
9418 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
9419 gnu_field_type = make_packable_type (gnu_field_type, true);
9422 else
9423 gnu_size = TYPE_SIZE (gnu_field_type);
9425 /* If the context of the old field is the old type or its REP part,
9426 put the field directly in the new type; otherwise look up the
9427 context in the variant list and put the field either in the new
9428 type if there is a selected variant or in one new variant. */
9429 if (gnu_context == gnu_old_type
9430 || (gnu_rep_part && gnu_context == TREE_TYPE (gnu_rep_part)))
9431 gnu_cont_type = gnu_new_type;
9432 else
9434 variant_desc *v;
9435 unsigned int i;
9436 tree rep_part;
9438 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9439 if (gnu_context == v->type
9440 || ((rep_part = get_rep_part (v->type))
9441 && gnu_context == TREE_TYPE (rep_part)))
9442 break;
9444 if (v)
9445 gnu_cont_type = selected_variant ? gnu_new_type : v->new_type;
9446 else
9447 /* The front-end may pass us "ghost" components if it fails to
9448 recognize that a constrain statically selects a particular
9449 variant. Discard them. */
9450 continue;
9453 /* Now create the new field modeled on the old one. */
9454 gnu_field
9455 = create_field_decl_from (gnu_old_field, gnu_field_type,
9456 gnu_cont_type, gnu_size,
9457 gnu_pos_list, gnu_subst_list);
9458 gnu_pos = DECL_FIELD_OFFSET (gnu_field);
9460 /* If the context is a variant, put it in the new variant directly. */
9461 if (gnu_cont_type != gnu_new_type)
9463 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
9464 TYPE_FIELDS (gnu_cont_type) = gnu_field;
9467 /* To match the layout crafted in components_to_record, if this is
9468 the _Tag or _Parent field, put it before any other fields. */
9469 else if (gnat_name == Name_uTag || gnat_name == Name_uParent)
9470 gnu_field_list = chainon (gnu_field_list, gnu_field);
9472 /* Similarly, if this is the _Controller field, put it before the
9473 other fields except for the _Tag or _Parent field. */
9474 else if (gnat_name == Name_uController && gnu_last)
9476 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
9477 DECL_CHAIN (gnu_last) = gnu_field;
9480 /* Otherwise, put it after the other fields. */
9481 else
9483 DECL_CHAIN (gnu_field) = gnu_field_list;
9484 gnu_field_list = gnu_field;
9485 if (!gnu_last)
9486 gnu_last = gnu_field;
9487 if (TREE_CODE (gnu_pos) != INTEGER_CST)
9488 all_constant_pos = false;
9491 /* For a stored discriminant in a derived type, replace the field. */
9492 if (!is_subtype && Ekind (gnat_field) == E_Discriminant)
9494 tree gnu_ref = get_gnu_tree (gnat_field);
9495 TREE_OPERAND (gnu_ref, 1) = gnu_field;
9497 else
9498 save_gnu_tree (gnat_field, gnu_field, false);
9501 /* If there is a variant list, a selected variant and the fields all have a
9502 constant position, put them in order of increasing position to match that
9503 of constant CONSTRUCTORs. Likewise if there is no variant list but a REP
9504 part, since the latter has been flattened in the process. */
9505 if ((gnu_variant_list.exists () ? selected_variant : gnu_rep_part != NULL)
9506 && all_constant_pos)
9508 const int len = list_length (gnu_field_list);
9509 tree *field_arr = XALLOCAVEC (tree, len), t = gnu_field_list;
9511 for (int i = 0; t; t = DECL_CHAIN (t), i++)
9512 field_arr[i] = t;
9514 qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
9516 gnu_field_list = NULL_TREE;
9517 for (int i = 0; i < len; i++)
9519 DECL_CHAIN (field_arr[i]) = gnu_field_list;
9520 gnu_field_list = field_arr[i];
9524 /* If there is a variant list and no selected variant, we need to create the
9525 nest of variant parts from the old nest. */
9526 else if (gnu_variant_list.exists () && !selected_variant)
9528 tree new_variant_part
9529 = create_variant_part_from (gnu_variant_part, gnu_variant_list,
9530 gnu_new_type, gnu_pos_list,
9531 gnu_subst_list, debug_info_p);
9532 DECL_CHAIN (new_variant_part) = gnu_field_list;
9533 gnu_field_list = new_variant_part;
9536 gnu_variant_list.release ();
9537 gnu_subst_list.release ();
9539 gnu_field_list = nreverse (gnu_field_list);
9541 /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
9542 Otherwise sizes and alignment must be computed independently. */
9543 if (is_subtype)
9545 finish_record_type (gnu_new_type, gnu_field_list, 2, debug_info_p);
9546 compute_record_mode (gnu_new_type);
9548 else
9549 finish_record_type (gnu_new_type, gnu_field_list, 1, debug_info_p);
9551 /* Now go through the entities again looking for Itypes that we have not yet
9552 elaborated (e.g. Etypes of fields that have Original_Components). */
9553 for (Entity_Id gnat_field = First_Entity (gnat_new_type);
9554 Present (gnat_field);
9555 gnat_field = Next_Entity (gnat_field))
9556 if ((Ekind (gnat_field) == E_Component
9557 || Ekind (gnat_field) == E_Discriminant)
9558 && Is_Itype (Etype (gnat_field))
9559 && !present_gnu_tree (Etype (gnat_field)))
9560 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
9563 /* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
9564 the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
9565 the original array type if it has been translated. This association is a
9566 parallel type for GNAT encodings or a debug type for standard DWARF. Note
9567 that for standard DWARF, we also want to get the original type name. */
9569 static void
9570 associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
9572 Entity_Id gnat_original_array_type
9573 = Underlying_Type (Original_Array_Type (gnat_entity));
9574 tree gnu_original_array_type;
9576 if (!present_gnu_tree (gnat_original_array_type))
9577 return;
9579 gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
9581 if (TYPE_IS_DUMMY_P (gnu_original_array_type))
9582 return;
9584 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
9586 tree original_name = TYPE_NAME (gnu_original_array_type);
9588 if (TREE_CODE (original_name) == TYPE_DECL)
9589 original_name = DECL_NAME (original_name);
9591 SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
9592 TYPE_NAME (gnu_type) = original_name;
9594 else
9595 add_parallel_type (gnu_type, gnu_original_array_type);
9598 /* Given a type T, a FIELD_DECL F, and a replacement value R, return an
9599 equivalent type with adjusted size expressions where all occurrences
9600 of references to F in a PLACEHOLDER_EXPR have been replaced by R.
9602 The function doesn't update the layout of the type, i.e. it assumes
9603 that the substitution is purely formal. That's why the replacement
9604 value R must itself contain a PLACEHOLDER_EXPR. */
9606 tree
9607 substitute_in_type (tree t, tree f, tree r)
9609 tree nt;
9611 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
9613 switch (TREE_CODE (t))
9615 case INTEGER_TYPE:
9616 case ENUMERAL_TYPE:
9617 case BOOLEAN_TYPE:
9618 case REAL_TYPE:
9620 /* First the domain types of arrays. */
9621 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
9622 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
9624 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
9625 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
9627 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
9628 return t;
9630 nt = copy_type (t);
9631 TYPE_GCC_MIN_VALUE (nt) = low;
9632 TYPE_GCC_MAX_VALUE (nt) = high;
9634 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
9635 SET_TYPE_INDEX_TYPE
9636 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
9638 return nt;
9641 /* Then the subtypes. */
9642 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
9643 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
9645 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
9646 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
9648 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
9649 return t;
9651 nt = copy_type (t);
9652 SET_TYPE_RM_MIN_VALUE (nt, low);
9653 SET_TYPE_RM_MAX_VALUE (nt, high);
9655 return nt;
9658 return t;
9660 case COMPLEX_TYPE:
9661 nt = substitute_in_type (TREE_TYPE (t), f, r);
9662 if (nt == TREE_TYPE (t))
9663 return t;
9665 return build_complex_type (nt);
9667 case FUNCTION_TYPE:
9668 /* These should never show up here. */
9669 gcc_unreachable ();
9671 case ARRAY_TYPE:
9673 tree component = substitute_in_type (TREE_TYPE (t), f, r);
9674 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
9676 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
9677 return t;
9679 nt = build_nonshared_array_type (component, domain);
9680 SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
9681 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
9682 SET_TYPE_MODE (nt, TYPE_MODE (t));
9683 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9684 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9685 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
9686 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
9687 if (TYPE_REVERSE_STORAGE_ORDER (t))
9688 set_reverse_storage_order_on_array_type (nt);
9689 if (TYPE_NONALIASED_COMPONENT (t))
9690 set_nonaliased_component_on_array_type (nt);
9691 return nt;
9694 case RECORD_TYPE:
9695 case UNION_TYPE:
9696 case QUAL_UNION_TYPE:
9698 bool changed_field = false;
9699 tree field;
9701 /* Start out with no fields, make new fields, and chain them
9702 in. If we haven't actually changed the type of any field,
9703 discard everything we've done and return the old type. */
9704 nt = copy_type (t);
9705 TYPE_FIELDS (nt) = NULL_TREE;
9707 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
9709 tree new_field = copy_node (field), new_n;
9711 new_n = substitute_in_type (TREE_TYPE (field), f, r);
9712 if (new_n != TREE_TYPE (field))
9714 TREE_TYPE (new_field) = new_n;
9715 changed_field = true;
9718 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
9719 if (new_n != DECL_FIELD_OFFSET (field))
9721 DECL_FIELD_OFFSET (new_field) = new_n;
9722 changed_field = true;
9725 /* Do the substitution inside the qualifier, if any. */
9726 if (TREE_CODE (t) == QUAL_UNION_TYPE)
9728 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
9729 if (new_n != DECL_QUALIFIER (field))
9731 DECL_QUALIFIER (new_field) = new_n;
9732 changed_field = true;
9736 DECL_CONTEXT (new_field) = nt;
9737 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
9739 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
9740 TYPE_FIELDS (nt) = new_field;
9743 if (!changed_field)
9744 return t;
9746 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
9747 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9748 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9749 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
9750 return nt;
9753 default:
9754 return t;
9758 /* Return the RM size of GNU_TYPE. This is the actual number of bits
9759 needed to represent the object. */
9761 tree
9762 rm_size (tree gnu_type)
9764 /* For integral types, we store the RM size explicitly. */
9765 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
9766 return TYPE_RM_SIZE (gnu_type);
9768 /* Return the RM size of the actual data plus the size of the template. */
9769 if (TREE_CODE (gnu_type) == RECORD_TYPE
9770 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9771 return
9772 size_binop (PLUS_EXPR,
9773 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
9774 DECL_SIZE (TYPE_FIELDS (gnu_type)));
9776 /* For record or union types, we store the size explicitly. */
9777 if (RECORD_OR_UNION_TYPE_P (gnu_type)
9778 && !TYPE_FAT_POINTER_P (gnu_type)
9779 && TYPE_ADA_SIZE (gnu_type))
9780 return TYPE_ADA_SIZE (gnu_type);
9782 /* For other types, this is just the size. */
9783 return TYPE_SIZE (gnu_type);
9786 /* Return the name to be used for GNAT_ENTITY. If a type, create a
9787 fully-qualified name, possibly with type information encoding.
9788 Otherwise, return the name. */
9790 static const char *
9791 get_entity_char (Entity_Id gnat_entity)
9793 Get_Encoded_Name (gnat_entity);
9794 return ggc_strdup (Name_Buffer);
9797 tree
9798 get_entity_name (Entity_Id gnat_entity)
9800 Get_Encoded_Name (gnat_entity);
9801 return get_identifier_with_length (Name_Buffer, Name_Len);
9804 /* Return an identifier representing the external name to be used for
9805 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
9806 and the specified suffix. */
9808 tree
9809 create_concat_name (Entity_Id gnat_entity, const char *suffix)
9811 const Entity_Kind kind = Ekind (gnat_entity);
9812 const bool has_suffix = (suffix != NULL);
9813 String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
9814 String_Pointer sp = {suffix, &temp};
9816 Get_External_Name (gnat_entity, has_suffix, sp);
9818 /* A variable using the Stdcall convention lives in a DLL. We adjust
9819 its name to use the jump table, the _imp__NAME contains the address
9820 for the NAME variable. */
9821 if ((kind == E_Variable || kind == E_Constant)
9822 && Has_Stdcall_Convention (gnat_entity))
9824 const int len = strlen (STDCALL_PREFIX) + Name_Len;
9825 char *new_name = (char *) alloca (len + 1);
9826 strcpy (new_name, STDCALL_PREFIX);
9827 strcat (new_name, Name_Buffer);
9828 return get_identifier_with_length (new_name, len);
9831 return get_identifier_with_length (Name_Buffer, Name_Len);
9834 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9835 string, return a new IDENTIFIER_NODE that is the concatenation of
9836 the name followed by "___" and the specified suffix. */
9838 tree
9839 concat_name (tree gnu_name, const char *suffix)
9841 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
9842 char *new_name = (char *) alloca (len + 1);
9843 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
9844 strcat (new_name, "___");
9845 strcat (new_name, suffix);
9846 return get_identifier_with_length (new_name, len);
9849 /* Initialize data structures of the decl.c module. */
9851 void
9852 init_gnat_decl (void)
9854 /* Initialize the cache of annotated values. */
9855 annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
9857 /* Initialize the association of dummy types with subprograms. */
9858 dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
9861 /* Destroy data structures of the decl.c module. */
9863 void
9864 destroy_gnat_decl (void)
9866 /* Destroy the cache of annotated values. */
9867 annotate_value_cache->empty ();
9868 annotate_value_cache = NULL;
9870 /* Destroy the association of dummy types with subprograms. */
9871 dummy_to_subprog_map->empty ();
9872 dummy_to_subprog_map = NULL;
9875 #include "gt-ada-decl.h"