1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2018, 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 ****************************************************************************/
25
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"
38
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"
54
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. */
58
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
73
74 #define STDCALL_PREFIX "_imp__"
75
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.
79
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. */
84
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
91
92 struct incomplete
93 {
94 struct incomplete *next;
95 tree old_type;
96 Entity_Id full_type;
97 };
98
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;
103
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;
107
108 typedef struct subst_pair_d {
109 tree discriminant;
110 tree replacement;
111 } subst_pair;
112
113
114 typedef struct variant_desc_d {
115 /* The type of the variant. */
116 tree type;
117
118 /* The associated field. */
119 tree field;
120
121 /* The value of the qualifier. */
122 tree qual;
123
124 /* The type of the variant after transformation. */
125 tree new_type;
126 } variant_desc;
127
128
129 /* A map used to cache the result of annotate_value. */
130 struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
131 {
132 static inline hashval_t
hashvalue_annotation_hasher133 hash (tree_int_map *m)
134 {
135 return htab_hash_pointer (m->base.from);
136 }
137
138 static inline bool
equalvalue_annotation_hasher139 equal (tree_int_map *a, tree_int_map *b)
140 {
141 return a->base.from == b->base.from;
142 }
143
144 static int
keep_cache_entryvalue_annotation_hasher145 keep_cache_entry (tree_int_map *&m)
146 {
147 return ggc_marked_p (m->base.from);
148 }
149 };
150
151 static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
152
153 /* A map used to associate a dummy type with a list of subprogram entities. */
154 struct GTY((for_user)) tree_entity_vec_map
155 {
156 struct tree_map_base base;
157 vec<Entity_Id, va_gc_atomic> *to;
158 };
159
160 void
gt_pch_nx(Entity_Id &)161 gt_pch_nx (Entity_Id &)
162 {
163 }
164
165 void
gt_pch_nx(Entity_Id * x,gt_pointer_operator op,void * cookie)166 gt_pch_nx (Entity_Id *x, gt_pointer_operator op, void *cookie)
167 {
168 op (x, cookie);
169 }
170
171 struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
172 {
173 static inline hashval_t
hashdummy_type_hasher174 hash (tree_entity_vec_map *m)
175 {
176 return htab_hash_pointer (m->base.from);
177 }
178
179 static inline bool
equaldummy_type_hasher180 equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
181 {
182 return a->base.from == b->base.from;
183 }
184
185 static int
keep_cache_entrydummy_type_hasher186 keep_cache_entry (tree_entity_vec_map *&m)
187 {
188 return ggc_marked_p (m->base.from);
189 }
190 };
191
192 static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
193
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 void set_nonaliased_component_on_array_type (tree);
211 static void set_reverse_storage_order_on_array_type (tree);
212 static bool same_discriminant_p (Entity_Id, Entity_Id);
213 static bool array_type_has_nonaliased_component (tree, Entity_Id);
214 static bool compile_time_known_address_p (Node_Id);
215 static bool cannot_be_superflat (Node_Id);
216 static bool constructor_address_p (tree);
217 static bool allocatable_size_p (tree, bool);
218 static bool initial_value_needs_conversion (tree, tree);
219 static int compare_field_bitpos (const PTR, const PTR);
220 static bool components_to_record (Node_Id, Entity_Id, tree, tree, int, bool,
221 bool, bool, bool, bool, bool, bool, tree,
222 tree *);
223 static Uint annotate_value (tree);
224 static void annotate_rep (Entity_Id, tree);
225 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
226 static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
227 static vec<variant_desc> build_variant_list (tree, vec<subst_pair>,
228 vec<variant_desc>);
229 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
230 static void set_rm_size (Uint, tree, Entity_Id);
231 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
232 static unsigned int promote_object_alignment (tree, Entity_Id);
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);
245
246 /* The relevant constituents of a subprogram binding to a GCC builtin. Used
247 to pass around calls performing profile compatibility checks. */
248
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;
254
255 static bool intrin_profiles_compatible_p (intrin_binding_t *);
256
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.
260
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.
264
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. */
269
270 tree
gnat_to_gnu_entity(Entity_Id gnat_entity,tree gnu_expr,bool definition)271 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
272 {
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. This can
299 also be used to purposely avoid making such an association but this use
300 case ought not to be applied to types because it can break the deferral
301 mechanism implemented for access types. */
302 bool saved = false;
303 /* True if we incremented defer_incomplete_level. */
304 bool this_deferred = false;
305 /* True if we incremented force_global. */
306 bool this_global = false;
307 /* True if we should check to see if elaborated during processing. */
308 bool maybe_present = false;
309 /* True if we made GNU_DECL and its type here. */
310 bool this_made_decl = false;
311 /* Size and alignment of the GCC node, if meaningful. */
312 unsigned int esize = 0, align = 0;
313 /* Contains the list of attributes directly attached to the entity. */
314 struct attrib *attr_list = NULL;
315
316 /* Since a use of an Itype is a definition, process it as such if it is in
317 the main unit, except for E_Access_Subtype because it's actually a use
318 of its base type, see below. */
319 if (!definition
320 && is_type
321 && Is_Itype (gnat_entity)
322 && Ekind (gnat_entity) != E_Access_Subtype
323 && !present_gnu_tree (gnat_entity)
324 && In_Extended_Main_Code_Unit (gnat_entity))
325 {
326 /* Ensure that we are in a subprogram mentioned in the Scope chain of
327 this entity, our current scope is global, or we encountered a task
328 or entry (where we can't currently accurately check scoping). */
329 if (!current_function_decl
330 || DECL_ELABORATION_PROC_P (current_function_decl))
331 {
332 process_type (gnat_entity);
333 return get_gnu_tree (gnat_entity);
334 }
335
336 for (gnat_temp = Scope (gnat_entity);
337 Present (gnat_temp);
338 gnat_temp = Scope (gnat_temp))
339 {
340 if (Is_Type (gnat_temp))
341 gnat_temp = Underlying_Type (gnat_temp);
342
343 if (Ekind (gnat_temp) == E_Subprogram_Body)
344 gnat_temp
345 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
346
347 if (Is_Subprogram (gnat_temp)
348 && Present (Protected_Body_Subprogram (gnat_temp)))
349 gnat_temp = Protected_Body_Subprogram (gnat_temp);
350
351 if (Ekind (gnat_temp) == E_Entry
352 || Ekind (gnat_temp) == E_Entry_Family
353 || Ekind (gnat_temp) == E_Task_Type
354 || (Is_Subprogram (gnat_temp)
355 && present_gnu_tree (gnat_temp)
356 && (current_function_decl
357 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))))
358 {
359 process_type (gnat_entity);
360 return get_gnu_tree (gnat_entity);
361 }
362 }
363
364 /* This abort means the Itype has an incorrect scope, i.e. that its
365 scope does not correspond to the subprogram it is first used in. */
366 gcc_unreachable ();
367 }
368
369 /* If we've already processed this entity, return what we got last time.
370 If we are defining the node, we should not have already processed it.
371 In that case, we will abort below when we try to save a new GCC tree
372 for this object. We also need to handle the case of getting a dummy
373 type when a Full_View exists but be careful so as not to trigger its
374 premature elaboration. Likewise for a cloned subtype without its own
375 freeze node, which typically happens when a generic gets instantiated
376 on an incomplete or private type. */
377 if ((!definition || (is_type && imported_p))
378 && present_gnu_tree (gnat_entity))
379 {
380 gnu_decl = get_gnu_tree (gnat_entity);
381
382 if (TREE_CODE (gnu_decl) == TYPE_DECL
383 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
384 && IN (kind, Incomplete_Or_Private_Kind)
385 && Present (Full_View (gnat_entity))
386 && (present_gnu_tree (Full_View (gnat_entity))
387 || No (Freeze_Node (Full_View (gnat_entity)))))
388 {
389 gnu_decl
390 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE,
391 false);
392 save_gnu_tree (gnat_entity, NULL_TREE, false);
393 save_gnu_tree (gnat_entity, gnu_decl, false);
394 }
395
396 if (TREE_CODE (gnu_decl) == TYPE_DECL
397 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
398 && Ekind (gnat_entity) == E_Record_Subtype
399 && No (Freeze_Node (gnat_entity))
400 && Present (Cloned_Subtype (gnat_entity))
401 && (present_gnu_tree (Cloned_Subtype (gnat_entity))
402 || No (Freeze_Node (Cloned_Subtype (gnat_entity)))))
403 {
404 gnu_decl
405 = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), NULL_TREE,
406 false);
407 save_gnu_tree (gnat_entity, NULL_TREE, false);
408 save_gnu_tree (gnat_entity, gnu_decl, false);
409 }
410
411 return gnu_decl;
412 }
413
414 /* If this is a numeric or enumeral type, or an access type, a nonzero Esize
415 must be specified unless it was specified by the programmer. Exceptions
416 are for access-to-protected-subprogram types and all access subtypes, as
417 another GNAT type is used to lay out the GCC type for them. */
418 gcc_assert (!is_type
419 || Known_Esize (gnat_entity)
420 || Has_Size_Clause (gnat_entity)
421 || (!IN (kind, Numeric_Kind)
422 && !IN (kind, Enumeration_Kind)
423 && (!IN (kind, Access_Kind)
424 || kind == E_Access_Protected_Subprogram_Type
425 || kind == E_Anonymous_Access_Protected_Subprogram_Type
426 || kind == E_Access_Subtype
427 || type_annotate_only)));
428
429 /* The RM size must be specified for all discrete and fixed-point types. */
430 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
431 && Unknown_RM_Size (gnat_entity)));
432
433 /* If we get here, it means we have not yet done anything with this entity.
434 If we are not defining it, it must be a type or an entity that is defined
435 elsewhere or externally, otherwise we should have defined it already. */
436 gcc_assert (definition
437 || type_annotate_only
438 || is_type
439 || kind == E_Discriminant
440 || kind == E_Component
441 || kind == E_Label
442 || (kind == E_Constant && Present (Full_View (gnat_entity)))
443 || Is_Public (gnat_entity));
444
445 /* Get the name of the entity and set up the line number and filename of
446 the original definition for use in any decl we make. Make sure we do not
447 inherit another source location. */
448 gnu_entity_name = get_entity_name (gnat_entity);
449 if (Sloc (gnat_entity) != No_Location
450 && !renaming_from_instantiation_p (gnat_entity))
451 Sloc_to_locus (Sloc (gnat_entity), &input_location);
452
453 /* For cases when we are not defining (i.e., we are referencing from
454 another compilation unit) public entities, show we are at global level
455 for the purpose of computing scopes. Don't do this for components or
456 discriminants since the relevant test is whether or not the record is
457 being defined. */
458 if (!definition
459 && kind != E_Component
460 && kind != E_Discriminant
461 && Is_Public (gnat_entity)
462 && !Is_Statically_Allocated (gnat_entity))
463 force_global++, this_global = true;
464
465 /* Handle any attributes directly attached to the entity. */
466 if (Has_Gigi_Rep_Item (gnat_entity))
467 prepend_attributes (&attr_list, gnat_entity);
468
469 /* Do some common processing for types. */
470 if (is_type)
471 {
472 /* Compute the equivalent type to be used in gigi. */
473 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
474
475 /* Machine_Attributes on types are expected to be propagated to
476 subtypes. The corresponding Gigi_Rep_Items are only attached
477 to the first subtype though, so we handle the propagation here. */
478 if (Base_Type (gnat_entity) != gnat_entity
479 && !Is_First_Subtype (gnat_entity)
480 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
481 prepend_attributes (&attr_list,
482 First_Subtype (Base_Type (gnat_entity)));
483
484 /* Compute a default value for the size of an elementary type. */
485 if (Known_Esize (gnat_entity) && Is_Elementary_Type (gnat_entity))
486 {
487 unsigned int max_esize;
488
489 gcc_assert (UI_Is_In_Int_Range (Esize (gnat_entity)));
490 esize = UI_To_Int (Esize (gnat_entity));
491
492 if (IN (kind, Float_Kind))
493 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
494 else if (IN (kind, Access_Kind))
495 max_esize = POINTER_SIZE * 2;
496 else
497 max_esize = LONG_LONG_TYPE_SIZE;
498
499 if (esize > max_esize)
500 esize = max_esize;
501 }
502 }
503
504 switch (kind)
505 {
506 case E_Component:
507 case E_Discriminant:
508 {
509 /* The GNAT record where the component was defined. */
510 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
511
512 /* If the entity is a discriminant of an extended tagged type used to
513 rename a discriminant of the parent type, return the latter. */
514 if (kind == E_Discriminant
515 && Present (Corresponding_Discriminant (gnat_entity))
516 && Is_Tagged_Type (gnat_record))
517 {
518 gnu_decl
519 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
520 gnu_expr, definition);
521 saved = true;
522 break;
523 }
524
525 /* If the entity is an inherited component (in the case of extended
526 tagged record types), just return the original entity, which must
527 be a FIELD_DECL. Likewise for discriminants. If the entity is a
528 non-girder discriminant (in the case of derived untagged record
529 types), return the stored discriminant it renames. */
530 if (Present (Original_Record_Component (gnat_entity))
531 && Original_Record_Component (gnat_entity) != gnat_entity)
532 {
533 gnu_decl
534 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
535 gnu_expr, definition);
536 /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */
537 if (kind == E_Discriminant)
538 saved = true;
539 break;
540 }
541
542 /* Otherwise, if we are not defining this and we have no GCC type
543 for the containing record, make one for it. Then we should
544 have made our own equivalent. */
545 if (!definition && !present_gnu_tree (gnat_record))
546 {
547 /* ??? If this is in a record whose scope is a protected
548 type and we have an Original_Record_Component, use it.
549 This is a workaround for major problems in protected type
550 handling. */
551 Entity_Id Scop = Scope (Scope (gnat_entity));
552 if (Is_Protected_Type (Underlying_Type (Scop))
553 && Present (Original_Record_Component (gnat_entity)))
554 {
555 gnu_decl
556 = gnat_to_gnu_entity (Original_Record_Component
557 (gnat_entity),
558 gnu_expr, false);
559 }
560 else
561 {
562 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, false);
563 gnu_decl = get_gnu_tree (gnat_entity);
564 }
565
566 saved = true;
567 break;
568 }
569
570 /* Here we have no GCC type and this is a reference rather than a
571 definition. This should never happen. Most likely the cause is
572 reference before declaration in the GNAT tree for gnat_entity. */
573 gcc_unreachable ();
574 }
575
576 case E_Constant:
577 /* Ignore constant definitions already marked with the error node. See
578 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
579 if (definition
580 && present_gnu_tree (gnat_entity)
581 && get_gnu_tree (gnat_entity) == error_mark_node)
582 {
583 maybe_present = true;
584 break;
585 }
586
587 /* Ignore deferred constant definitions without address clause since
588 they are processed fully in the front-end. If No_Initialization
589 is set, this is not a deferred constant but a constant whose value
590 is built manually. And constants that are renamings are handled
591 like variables. */
592 if (definition
593 && !gnu_expr
594 && No (Address_Clause (gnat_entity))
595 && !No_Initialization (Declaration_Node (gnat_entity))
596 && No (Renamed_Object (gnat_entity)))
597 {
598 gnu_decl = error_mark_node;
599 saved = true;
600 break;
601 }
602
603 /* If this is a use of a deferred constant without address clause,
604 get its full definition. */
605 if (!definition
606 && No (Address_Clause (gnat_entity))
607 && Present (Full_View (gnat_entity)))
608 {
609 gnu_decl
610 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, false);
611 saved = true;
612 break;
613 }
614
615 /* If we have a constant that we are not defining, get the expression it
616 was defined to represent. This is necessary to avoid generating dumb
617 elaboration code in simple cases, but we may throw it away later if it
618 is not a constant. But do not do it for dispatch tables because they
619 are only referenced indirectly and we need to have a consistent view
620 of the exported and of the imported declarations of the tables from
621 external units for them to be properly merged in LTO mode. Moreover
622 simply do not retrieve the expression it if it is an allocator since
623 the designated type might still be dummy at this point. Note that we
624 invoke gnat_to_gnu_external and not gnat_to_gnu because the expression
625 may contain N_Expression_With_Actions nodes and thus declarations of
626 objects from other units that we need to discard. */
627 if (!definition
628 && !No_Initialization (Declaration_Node (gnat_entity))
629 && !Is_Dispatch_Table_Entity (gnat_entity)
630 && Present (gnat_temp = Expression (Declaration_Node (gnat_entity)))
631 && Nkind (gnat_temp) != N_Allocator
632 && (!type_annotate_only || Compile_Time_Known_Value (gnat_temp)))
633 gnu_expr = gnat_to_gnu_external (gnat_temp);
634
635 /* ... fall through ... */
636
637 case E_Exception:
638 case E_Loop_Parameter:
639 case E_Out_Parameter:
640 case E_Variable:
641 {
642 const Entity_Id gnat_type = Etype (gnat_entity);
643 /* Always create a variable for volatile objects and variables seen
644 constant but with a Linker_Section pragma. */
645 bool const_flag
646 = ((kind == E_Constant || kind == E_Variable)
647 && Is_True_Constant (gnat_entity)
648 && !(kind == E_Variable
649 && Present (Linker_Section_Pragma (gnat_entity)))
650 && !Treat_As_Volatile (gnat_entity)
651 && (((Nkind (Declaration_Node (gnat_entity))
652 == N_Object_Declaration)
653 && Present (Expression (Declaration_Node (gnat_entity))))
654 || Present (Renamed_Object (gnat_entity))
655 || imported_p));
656 bool inner_const_flag = const_flag;
657 bool static_flag = Is_Statically_Allocated (gnat_entity);
658 /* We implement RM 13.3(19) for exported and imported (non-constant)
659 objects by making them volatile. */
660 bool volatile_flag
661 = (Treat_As_Volatile (gnat_entity)
662 || (!const_flag && (Is_Exported (gnat_entity) || imported_p)));
663 bool mutable_p = false;
664 bool used_by_ref = false;
665 tree gnu_ext_name = NULL_TREE;
666 tree renamed_obj = NULL_TREE;
667 tree gnu_object_size;
668
669 /* We need to translate the renamed object even though we are only
670 referencing the renaming. But it may contain a call for which
671 we'll generate a temporary to hold the return value and which
672 is part of the definition of the renaming, so discard it. */
673 if (Present (Renamed_Object (gnat_entity)) && !definition)
674 {
675 if (kind == E_Exception)
676 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
677 NULL_TREE, false);
678 else
679 gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
680 }
681
682 /* Get the type after elaborating the renamed object. */
683 if (Has_Foreign_Convention (gnat_entity)
684 && Is_Descendant_Of_Address (Underlying_Type (gnat_type)))
685 gnu_type = ptr_type_node;
686 else
687 {
688 gnu_type = gnat_to_gnu_type (gnat_type);
689
690 /* If this is a standard exception definition, use the standard
691 exception type. This is necessary to make sure that imported
692 and exported views of exceptions are merged in LTO mode. */
693 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
694 && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
695 gnu_type = except_type_node;
696 }
697
698 /* For a debug renaming declaration, build a debug-only entity. */
699 if (Present (Debug_Renaming_Link (gnat_entity)))
700 {
701 /* Force a non-null value to make sure the symbol is retained. */
702 tree value = build1 (INDIRECT_REF, gnu_type,
703 build1 (NOP_EXPR,
704 build_pointer_type (gnu_type),
705 integer_minus_one_node));
706 gnu_decl = build_decl (input_location,
707 VAR_DECL, gnu_entity_name, gnu_type);
708 SET_DECL_VALUE_EXPR (gnu_decl, value);
709 DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
710 TREE_STATIC (gnu_decl) = global_bindings_p ();
711 gnat_pushdecl (gnu_decl, gnat_entity);
712 break;
713 }
714
715 /* If this is a loop variable, its type should be the base type.
716 This is because the code for processing a loop determines whether
717 a normal loop end test can be done by comparing the bounds of the
718 loop against those of the base type, which is presumed to be the
719 size used for computation. But this is not correct when the size
720 of the subtype is smaller than the type. */
721 if (kind == E_Loop_Parameter)
722 gnu_type = get_base_type (gnu_type);
723
724 /* Reject non-renamed objects whose type is an unconstrained array or
725 any object whose type is a dummy type or void. */
726 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
727 && No (Renamed_Object (gnat_entity)))
728 || TYPE_IS_DUMMY_P (gnu_type)
729 || TREE_CODE (gnu_type) == VOID_TYPE)
730 {
731 gcc_assert (type_annotate_only);
732 if (this_global)
733 force_global--;
734 return error_mark_node;
735 }
736
737 /* If an alignment is specified, use it if valid. Note that exceptions
738 are objects but don't have an alignment and there is also no point in
739 setting it for an address clause, since the final type of the object
740 will be a reference type. */
741 if (Known_Alignment (gnat_entity)
742 && kind != E_Exception
743 && No (Address_Clause (gnat_entity)))
744 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
745 TYPE_ALIGN (gnu_type));
746
747 /* Likewise, if a size is specified, use it if valid. */
748 if (Known_Esize (gnat_entity))
749 gnu_size
750 = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
751 VAR_DECL, false, Has_Size_Clause (gnat_entity));
752 if (gnu_size)
753 {
754 gnu_type
755 = make_type_from_size (gnu_type, gnu_size,
756 Has_Biased_Representation (gnat_entity));
757
758 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
759 gnu_size = NULL_TREE;
760 }
761
762 /* If this object has self-referential size, it must be a record with
763 a default discriminant. We are supposed to allocate an object of
764 the maximum size in this case, unless it is a constant with an
765 initializing expression, in which case we can get the size from
766 that. Note that the resulting size may still be a variable, so
767 this may end up with an indirect allocation. */
768 if (No (Renamed_Object (gnat_entity))
769 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
770 {
771 if (gnu_expr && kind == E_Constant)
772 {
773 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
774 if (CONTAINS_PLACEHOLDER_P (size))
775 {
776 /* If the initializing expression is itself a constant,
777 despite having a nominal type with self-referential
778 size, we can get the size directly from it. */
779 if (TREE_CODE (gnu_expr) == COMPONENT_REF
780 && TYPE_IS_PADDING_P
781 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
782 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
783 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
784 || DECL_READONLY_ONCE_ELAB
785 (TREE_OPERAND (gnu_expr, 0))))
786 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
787 else
788 gnu_size
789 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
790 }
791 else
792 gnu_size = size;
793 }
794 /* We may have no GNU_EXPR because No_Initialization is
795 set even though there's an Expression. */
796 else if (kind == E_Constant
797 && (Nkind (Declaration_Node (gnat_entity))
798 == N_Object_Declaration)
799 && Present (Expression (Declaration_Node (gnat_entity))))
800 gnu_size
801 = TYPE_SIZE (gnat_to_gnu_type
802 (Etype
803 (Expression (Declaration_Node (gnat_entity)))));
804 else
805 {
806 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
807 mutable_p = true;
808 }
809
810 /* If the size isn't constant and we are at global level, call
811 elaborate_expression_1 to make a variable for it rather than
812 calculating it each time. */
813 if (!TREE_CONSTANT (gnu_size) && global_bindings_p ())
814 gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
815 "SIZE", definition, false);
816 }
817
818 /* If the size is zero byte, make it one byte since some linkers have
819 troubles with zero-sized objects. If the object will have a
820 template, that will make it nonzero so don't bother. Also avoid
821 doing that for an object renaming or an object with an address
822 clause, as we would lose useful information on the view size
823 (e.g. for null array slices) and we are not allocating the object
824 here anyway. */
825 if (((gnu_size
826 && integer_zerop (gnu_size)
827 && !TREE_OVERFLOW (gnu_size))
828 || (TYPE_SIZE (gnu_type)
829 && integer_zerop (TYPE_SIZE (gnu_type))
830 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
831 && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
832 && No (Renamed_Object (gnat_entity))
833 && No (Address_Clause (gnat_entity)))
834 gnu_size = bitsize_unit_node;
835
836 /* If this is an object with no specified size and alignment, and
837 if either it is atomic or we are not optimizing alignment for
838 space and it is composite and not an exception, an Out parameter
839 or a reference to another object, and the size of its type is a
840 constant, set the alignment to the smallest one which is not
841 smaller than the size, with an appropriate cap. */
842 if (!gnu_size && align == 0
843 && (Is_Atomic_Or_VFA (gnat_entity)
844 || (!Optimize_Alignment_Space (gnat_entity)
845 && kind != E_Exception
846 && kind != E_Out_Parameter
847 && Is_Composite_Type (gnat_type)
848 && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
849 && !Is_Exported (gnat_entity)
850 && !imported_p
851 && No (Renamed_Object (gnat_entity))
852 && No (Address_Clause (gnat_entity))))
853 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
854 align = promote_object_alignment (gnu_type, gnat_entity);
855
856 /* If the object is set to have atomic components, find the component
857 type and validate it.
858
859 ??? Note that we ignore Has_Volatile_Components on objects; it's
860 not at all clear what to do in that case. */
861 if (Has_Atomic_Components (gnat_entity))
862 {
863 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
864 ? TREE_TYPE (gnu_type) : gnu_type);
865
866 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
867 && TYPE_MULTI_ARRAY_P (gnu_inner))
868 gnu_inner = TREE_TYPE (gnu_inner);
869
870 check_ok_for_atomic_type (gnu_inner, gnat_entity, true);
871 }
872
873 /* If this is an aliased object with an unconstrained array nominal
874 subtype, make a type that includes the template. We will either
875 allocate or create a variable of that type, see below. */
876 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
877 && Is_Array_Type (Underlying_Type (gnat_type))
878 && !type_annotate_only)
879 {
880 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
881 gnu_type
882 = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
883 gnu_type,
884 concat_name (gnu_entity_name,
885 "UNC"),
886 debug_info_p);
887 }
888
889 /* ??? If this is an object of CW type initialized to a value, try to
890 ensure that the object is sufficient aligned for this value, but
891 without pessimizing the allocation. This is a kludge necessary
892 because we don't support dynamic alignment. */
893 if (align == 0
894 && Ekind (gnat_type) == E_Class_Wide_Subtype
895 && No (Renamed_Object (gnat_entity))
896 && No (Address_Clause (gnat_entity)))
897 align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
898
899 #ifdef MINIMUM_ATOMIC_ALIGNMENT
900 /* If the size is a constant and no alignment is specified, force
901 the alignment to be the minimum valid atomic alignment. The
902 restriction on constant size avoids problems with variable-size
903 temporaries; if the size is variable, there's no issue with
904 atomic access. Also don't do this for a constant, since it isn't
905 necessary and can interfere with constant replacement. Finally,
906 do not do it for Out parameters since that creates an
907 size inconsistency with In parameters. */
908 if (align == 0
909 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
910 && !FLOAT_TYPE_P (gnu_type)
911 && !const_flag && No (Renamed_Object (gnat_entity))
912 && !imported_p && No (Address_Clause (gnat_entity))
913 && kind != E_Out_Parameter
914 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
915 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
916 align = MINIMUM_ATOMIC_ALIGNMENT;
917 #endif
918
919 /* Make a new type with the desired size and alignment, if needed.
920 But do not take into account alignment promotions to compute the
921 size of the object. */
922 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
923 if (gnu_size || align > 0)
924 {
925 tree orig_type = gnu_type;
926
927 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
928 false, false, definition, true);
929
930 /* If a padding record was made, declare it now since it will
931 never be declared otherwise. This is necessary to ensure
932 that its subtrees are properly marked. */
933 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
934 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
935 debug_info_p, gnat_entity);
936 }
937
938 /* Now check if the type of the object allows atomic access. */
939 if (Is_Atomic_Or_VFA (gnat_entity))
940 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
941
942 /* If this is a renaming, avoid as much as possible to create a new
943 object. However, in some cases, creating it is required because
944 renaming can be applied to objects that are not names in Ada.
945 This processing needs to be applied to the raw expression so as
946 to make it more likely to rename the underlying object. */
947 if (Present (Renamed_Object (gnat_entity)))
948 {
949 /* If the renamed object had padding, strip off the reference to
950 the inner object and reset our type. */
951 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
952 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
953 /* Strip useless conversions around the object. */
954 || gnat_useless_type_conversion (gnu_expr))
955 {
956 gnu_expr = TREE_OPERAND (gnu_expr, 0);
957 gnu_type = TREE_TYPE (gnu_expr);
958 }
959
960 /* Or else, if the renamed object has an unconstrained type with
961 default discriminant, use the padded type. */
962 else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr)))
963 gnu_type = TREE_TYPE (gnu_expr);
964
965 /* Case 1: if this is a constant renaming stemming from a function
966 call, treat it as a normal object whose initial value is what
967 is being renamed. RM 3.3 says that the result of evaluating a
968 function call is a constant object. Therefore, it can be the
969 inner object of a constant renaming and the renaming must be
970 fully instantiated, i.e. it cannot be a reference to (part of)
971 an existing object. And treat other rvalues the same way. */
972 tree inner = gnu_expr;
973 while (handled_component_p (inner) || CONVERT_EXPR_P (inner))
974 inner = TREE_OPERAND (inner, 0);
975 /* Expand_Dispatching_Call can prepend a comparison of the tags
976 before the call to "=". */
977 if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
978 || TREE_CODE (inner) == COMPOUND_EXPR)
979 inner = TREE_OPERAND (inner, 1);
980 if ((TREE_CODE (inner) == CALL_EXPR
981 && !call_is_atomic_load (inner))
982 || TREE_CODE (inner) == CONSTRUCTOR
983 || CONSTANT_CLASS_P (inner)
984 || COMPARISON_CLASS_P (inner)
985 || BINARY_CLASS_P (inner)
986 || EXPRESSION_CLASS_P (inner)
987 /* We need to detect the case where a temporary is created to
988 hold the return value, since we cannot safely rename it at
989 top level as it lives only in the elaboration routine. */
990 || (TREE_CODE (inner) == VAR_DECL
991 && DECL_RETURN_VALUE_P (inner))
992 /* We also need to detect the case where the front-end creates
993 a dangling 'reference to a function call at top level and
994 substitutes it in the renaming, for example:
995
996 q__b : boolean renames r__f.e (1);
997
998 can be rewritten into:
999
1000 q__R1s : constant q__A2s := r__f'reference;
1001 [...]
1002 q__b : boolean renames q__R1s.all.e (1);
1003
1004 We cannot safely rename the rewritten expression since the
1005 underlying object lives only in the elaboration routine. */
1006 || (TREE_CODE (inner) == INDIRECT_REF
1007 && (inner
1008 = remove_conversions (TREE_OPERAND (inner, 0), true))
1009 && TREE_CODE (inner) == VAR_DECL
1010 && DECL_RETURN_VALUE_P (inner)))
1011 ;
1012
1013 /* Case 2: if the renaming entity need not be materialized, use
1014 the elaborated renamed expression for the renaming. But this
1015 means that the caller is responsible for evaluating the address
1016 of the renaming in the correct place for the definition case to
1017 instantiate the SAVE_EXPRs. */
1018 else if (!Materialize_Entity (gnat_entity))
1019 {
1020 tree init = NULL_TREE;
1021
1022 gnu_decl
1023 = elaborate_reference (gnu_expr, gnat_entity, definition,
1024 &init);
1025
1026 /* We cannot evaluate the first arm of a COMPOUND_EXPR in the
1027 correct place for this case. */
1028 gcc_assert (!init);
1029
1030 /* No DECL_EXPR will be created so the expression needs to be
1031 marked manually because it will likely be shared. */
1032 if (global_bindings_p ())
1033 MARK_VISITED (gnu_decl);
1034
1035 /* This assertion will fail if the renamed object isn't aligned
1036 enough as to make it possible to honor the alignment set on
1037 the renaming. */
1038 if (align)
1039 {
1040 unsigned int ralign = DECL_P (gnu_decl)
1041 ? DECL_ALIGN (gnu_decl)
1042 : TYPE_ALIGN (TREE_TYPE (gnu_decl));
1043 gcc_assert (ralign >= align);
1044 }
1045
1046 /* The expression might not be a DECL so save it manually. */
1047 save_gnu_tree (gnat_entity, gnu_decl, true);
1048 saved = true;
1049 annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
1050 break;
1051 }
1052
1053 /* Case 3: otherwise, make a constant pointer to the object we
1054 are renaming and attach the object to the pointer after it is
1055 elaborated. The object will be referenced directly instead
1056 of indirectly via the pointer to avoid aliasing problems with
1057 non-addressable entities. The pointer is called a "renaming"
1058 pointer in this case. Note that we also need to preserve the
1059 volatility of the renamed object through the indirection. */
1060 else
1061 {
1062 tree init = NULL_TREE;
1063
1064 if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type))
1065 gnu_type
1066 = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1067 gnu_type = build_reference_type (gnu_type);
1068 used_by_ref = true;
1069 const_flag = true;
1070 volatile_flag = false;
1071 inner_const_flag = TREE_READONLY (gnu_expr);
1072 gnu_size = NULL_TREE;
1073
1074 renamed_obj
1075 = elaborate_reference (gnu_expr, gnat_entity, definition,
1076 &init);
1077
1078 /* The expression needs to be marked manually because it will
1079 likely be shared, even for a definition since the ADDR_EXPR
1080 built below can cause the first few nodes to be folded. */
1081 if (global_bindings_p ())
1082 MARK_VISITED (renamed_obj);
1083
1084 if (type_annotate_only
1085 && TREE_CODE (renamed_obj) == ERROR_MARK)
1086 gnu_expr = NULL_TREE;
1087 else
1088 {
1089 gnu_expr
1090 = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
1091 if (init)
1092 gnu_expr
1093 = build_compound_expr (TREE_TYPE (gnu_expr), init,
1094 gnu_expr);
1095 }
1096 }
1097 }
1098
1099 /* If we are defining an aliased object whose nominal subtype is
1100 unconstrained, the object is a record that contains both the
1101 template and the object. If there is an initializer, it will
1102 have already been converted to the right type, but we need to
1103 create the template if there is no initializer. */
1104 if (definition
1105 && !gnu_expr
1106 && TREE_CODE (gnu_type) == RECORD_TYPE
1107 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1108 /* Beware that padding might have been introduced above. */
1109 || (TYPE_PADDING_P (gnu_type)
1110 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1111 == RECORD_TYPE
1112 && TYPE_CONTAINS_TEMPLATE_P
1113 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1114 {
1115 tree template_field
1116 = TYPE_PADDING_P (gnu_type)
1117 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1118 : TYPE_FIELDS (gnu_type);
1119 vec<constructor_elt, va_gc> *v;
1120 vec_alloc (v, 1);
1121 tree t = build_template (TREE_TYPE (template_field),
1122 TREE_TYPE (DECL_CHAIN (template_field)),
1123 NULL_TREE);
1124 CONSTRUCTOR_APPEND_ELT (v, template_field, t);
1125 gnu_expr = gnat_build_constructor (gnu_type, v);
1126 }
1127
1128 /* Convert the expression to the type of the object if need be. */
1129 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1130 gnu_expr = convert (gnu_type, gnu_expr);
1131
1132 /* If this is a pointer that doesn't have an initializing expression,
1133 initialize it to NULL, unless the object is declared imported as
1134 per RM B.1(24). */
1135 if (definition
1136 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1137 && !gnu_expr
1138 && !Is_Imported (gnat_entity))
1139 gnu_expr = integer_zero_node;
1140
1141 /* If we are defining the object and it has an Address clause, we must
1142 either get the address expression from the saved GCC tree for the
1143 object if it has a Freeze node, or elaborate the address expression
1144 here since the front-end has guaranteed that the elaboration has no
1145 effects in this case. */
1146 if (definition && Present (Address_Clause (gnat_entity)))
1147 {
1148 const Node_Id gnat_clause = Address_Clause (gnat_entity);
1149 Node_Id gnat_address = Expression (gnat_clause);
1150 tree gnu_address
1151 = present_gnu_tree (gnat_entity)
1152 ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_address);
1153
1154 save_gnu_tree (gnat_entity, NULL_TREE, false);
1155
1156 /* Convert the type of the object to a reference type that can
1157 alias everything as per RM 13.3(19). */
1158 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1159 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1160 gnu_type
1161 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1162 gnu_address = convert (gnu_type, gnu_address);
1163 used_by_ref = true;
1164 const_flag
1165 = (!Is_Public (gnat_entity)
1166 || compile_time_known_address_p (gnat_address));
1167 volatile_flag = false;
1168 gnu_size = NULL_TREE;
1169
1170 /* If this is an aliased object with an unconstrained array nominal
1171 subtype, then it can overlay only another aliased object with an
1172 unconstrained array nominal subtype and compatible template. */
1173 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
1174 && Is_Array_Type (Underlying_Type (gnat_type))
1175 && !type_annotate_only)
1176 {
1177 tree rec_type = TREE_TYPE (gnu_type);
1178 tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type)));
1179
1180 /* This is the pattern built for a regular object. */
1181 if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1182 && TREE_OPERAND (gnu_address, 1) == off)
1183 gnu_address = TREE_OPERAND (gnu_address, 0);
1184 /* This is the pattern built for an overaligned object. */
1185 else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR
1186 && TREE_CODE (TREE_OPERAND (gnu_address, 1))
1187 == PLUS_EXPR
1188 && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1)
1189 == off)
1190 gnu_address
1191 = build2 (POINTER_PLUS_EXPR, gnu_type,
1192 TREE_OPERAND (gnu_address, 0),
1193 TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0));
1194 else
1195 {
1196 post_error_ne ("aliased object& with unconstrained array "
1197 "nominal subtype", gnat_clause,
1198 gnat_entity);
1199 post_error ("\\can overlay only aliased object with "
1200 "compatible subtype", gnat_clause);
1201 }
1202 }
1203
1204 /* If we don't have an initializing expression for the underlying
1205 variable, the initializing expression for the pointer is the
1206 specified address. Otherwise, we have to make a COMPOUND_EXPR
1207 to assign both the address and the initial value. */
1208 if (!gnu_expr)
1209 gnu_expr = gnu_address;
1210 else
1211 gnu_expr
1212 = build2 (COMPOUND_EXPR, gnu_type,
1213 build_binary_op (INIT_EXPR, NULL_TREE,
1214 build_unary_op (INDIRECT_REF,
1215 NULL_TREE,
1216 gnu_address),
1217 gnu_expr),
1218 gnu_address);
1219 }
1220
1221 /* If it has an address clause and we are not defining it, mark it
1222 as an indirect object. Likewise for Stdcall objects that are
1223 imported. */
1224 if ((!definition && Present (Address_Clause (gnat_entity)))
1225 || (imported_p && Has_Stdcall_Convention (gnat_entity)))
1226 {
1227 /* Convert the type of the object to a reference type that can
1228 alias everything as per RM 13.3(19). */
1229 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1230 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1231 gnu_type
1232 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1233 used_by_ref = true;
1234 const_flag = false;
1235 volatile_flag = false;
1236 gnu_size = NULL_TREE;
1237
1238 /* No point in taking the address of an initializing expression
1239 that isn't going to be used. */
1240 gnu_expr = NULL_TREE;
1241
1242 /* If it has an address clause whose value is known at compile
1243 time, make the object a CONST_DECL. This will avoid a
1244 useless dereference. */
1245 if (Present (Address_Clause (gnat_entity)))
1246 {
1247 Node_Id gnat_address
1248 = Expression (Address_Clause (gnat_entity));
1249
1250 if (compile_time_known_address_p (gnat_address))
1251 {
1252 gnu_expr = gnat_to_gnu (gnat_address);
1253 const_flag = true;
1254 }
1255 }
1256 }
1257
1258 /* If we are at top level and this object is of variable size,
1259 make the actual type a hidden pointer to the real type and
1260 make the initializer be a memory allocation and initialization.
1261 Likewise for objects we aren't defining (presumed to be
1262 external references from other packages), but there we do
1263 not set up an initialization.
1264
1265 If the object's size overflows, make an allocator too, so that
1266 Storage_Error gets raised. Note that we will never free
1267 such memory, so we presume it never will get allocated. */
1268 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1269 global_bindings_p ()
1270 || !definition
1271 || static_flag)
1272 || (gnu_size
1273 && !allocatable_size_p (convert (sizetype,
1274 size_binop
1275 (CEIL_DIV_EXPR, gnu_size,
1276 bitsize_unit_node)),
1277 global_bindings_p ()
1278 || !definition
1279 || static_flag)))
1280 {
1281 if (volatile_flag && !TYPE_VOLATILE (gnu_type))
1282 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
1283 gnu_type = build_reference_type (gnu_type);
1284 used_by_ref = true;
1285 const_flag = true;
1286 volatile_flag = false;
1287 gnu_size = NULL_TREE;
1288
1289 /* In case this was a aliased object whose nominal subtype is
1290 unconstrained, the pointer above will be a thin pointer and
1291 build_allocator will automatically make the template.
1292
1293 If we have a template initializer only (that we made above),
1294 pretend there is none and rely on what build_allocator creates
1295 again anyway. Otherwise (if we have a full initializer), get
1296 the data part and feed that to build_allocator.
1297
1298 If we are elaborating a mutable object, tell build_allocator to
1299 ignore a possibly simpler size from the initializer, if any, as
1300 we must allocate the maximum possible size in this case. */
1301 if (definition && !imported_p)
1302 {
1303 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1304
1305 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1306 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1307 {
1308 gnu_alloc_type
1309 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1310
1311 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1312 && CONSTRUCTOR_NELTS (gnu_expr) == 1)
1313 gnu_expr = NULL_TREE;
1314 else
1315 gnu_expr
1316 = build_component_ref
1317 (gnu_expr,
1318 DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1319 false);
1320 }
1321
1322 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1323 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type)))
1324 post_error ("?`Storage_Error` will be raised at run time!",
1325 gnat_entity);
1326
1327 gnu_expr
1328 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1329 Empty, Empty, gnat_entity, mutable_p);
1330 }
1331 else
1332 gnu_expr = NULL_TREE;
1333 }
1334
1335 /* If this object would go into the stack and has an alignment larger
1336 than the largest stack alignment the back-end can honor, resort to
1337 a variable of "aligning type". */
1338 if (definition
1339 && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT
1340 && !imported_p
1341 && !static_flag
1342 && !global_bindings_p ())
1343 {
1344 /* Create the new variable. No need for extra room before the
1345 aligned field as this is in automatic storage. */
1346 tree gnu_new_type
1347 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1348 TYPE_SIZE_UNIT (gnu_type),
1349 BIGGEST_ALIGNMENT, 0, gnat_entity);
1350 tree gnu_new_var
1351 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1352 NULL_TREE, gnu_new_type, NULL_TREE,
1353 false, false, false, false, false,
1354 true, debug_info_p && definition, NULL,
1355 gnat_entity);
1356
1357 /* Initialize the aligned field if we have an initializer. */
1358 if (gnu_expr)
1359 add_stmt_with_node
1360 (build_binary_op (INIT_EXPR, NULL_TREE,
1361 build_component_ref
1362 (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1363 false),
1364 gnu_expr),
1365 gnat_entity);
1366
1367 /* And setup this entity as a reference to the aligned field. */
1368 gnu_type = build_reference_type (gnu_type);
1369 gnu_expr
1370 = build_unary_op
1371 (ADDR_EXPR, NULL_TREE,
1372 build_component_ref (gnu_new_var, TYPE_FIELDS (gnu_new_type),
1373 false));
1374 TREE_CONSTANT (gnu_expr) = 1;
1375
1376 used_by_ref = true;
1377 const_flag = true;
1378 volatile_flag = false;
1379 gnu_size = NULL_TREE;
1380 }
1381
1382 /* If this is an aggregate constant initialized to a constant, force it
1383 to be statically allocated. This saves an initialization copy. */
1384 if (!static_flag
1385 && const_flag
1386 && gnu_expr
1387 && TREE_CONSTANT (gnu_expr)
1388 && AGGREGATE_TYPE_P (gnu_type)
1389 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
1390 && !(TYPE_IS_PADDING_P (gnu_type)
1391 && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
1392 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1393 static_flag = true;
1394
1395 /* If this is an aliased object with an unconstrained array nominal
1396 subtype, we make its type a thin reference, i.e. the reference
1397 counterpart of a thin pointer, so it points to the array part.
1398 This is aimed to make it easier for the debugger to decode the
1399 object. Note that we have to do it this late because of the
1400 couple of allocation adjustments that might be made above. */
1401 if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
1402 && Is_Array_Type (Underlying_Type (gnat_type))
1403 && !type_annotate_only)
1404 {
1405 /* In case the object with the template has already been allocated
1406 just above, we have nothing to do here. */
1407 if (!TYPE_IS_THIN_POINTER_P (gnu_type))
1408 {
1409 /* This variable is a GNAT encoding used by Workbench: let it
1410 go through the debugging information but mark it as
1411 artificial: users are not interested in it. */
1412 tree gnu_unc_var
1413 = create_var_decl (concat_name (gnu_entity_name, "UNC"),
1414 NULL_TREE, gnu_type, gnu_expr,
1415 const_flag, Is_Public (gnat_entity),
1416 imported_p || !definition, static_flag,
1417 volatile_flag, true,
1418 debug_info_p && definition,
1419 NULL, gnat_entity);
1420 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
1421 TREE_CONSTANT (gnu_expr) = 1;
1422
1423 used_by_ref = true;
1424 const_flag = true;
1425 volatile_flag = false;
1426 inner_const_flag = TREE_READONLY (gnu_unc_var);
1427 gnu_size = NULL_TREE;
1428 }
1429
1430 tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
1431 gnu_type
1432 = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
1433 }
1434
1435 /* Convert the expression to the type of the object if need be. */
1436 if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
1437 gnu_expr = convert (gnu_type, gnu_expr);
1438
1439 /* If this name is external or a name was specified, use it, but don't
1440 use the Interface_Name with an address clause (see cd30005). */
1441 if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity))
1442 || (Present (Interface_Name (gnat_entity))
1443 && No (Address_Clause (gnat_entity))))
1444 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1445
1446 /* Deal with a pragma Linker_Section on a constant or variable. */
1447 if ((kind == E_Constant || kind == E_Variable)
1448 && Present (Linker_Section_Pragma (gnat_entity)))
1449 prepend_one_attribute_pragma (&attr_list,
1450 Linker_Section_Pragma (gnat_entity));
1451
1452 /* Now create the variable or the constant and set various flags. */
1453 gnu_decl
1454 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1455 gnu_expr, const_flag, Is_Public (gnat_entity),
1456 imported_p || !definition, static_flag,
1457 volatile_flag, artificial_p,
1458 debug_info_p && definition, attr_list,
1459 gnat_entity, !renamed_obj);
1460 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1461 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1462 DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
1463
1464 /* If we are defining an Out parameter and optimization isn't enabled,
1465 create a fake PARM_DECL for debugging purposes and make it point to
1466 the VAR_DECL. Suppress debug info for the latter but make sure it
1467 will live in memory so that it can be accessed from within the
1468 debugger through the PARM_DECL. */
1469 if (kind == E_Out_Parameter
1470 && definition
1471 && debug_info_p
1472 && !optimize
1473 && !flag_generate_lto)
1474 {
1475 tree param = create_param_decl (gnu_entity_name, gnu_type);
1476 gnat_pushdecl (param, gnat_entity);
1477 SET_DECL_VALUE_EXPR (param, gnu_decl);
1478 DECL_HAS_VALUE_EXPR_P (param) = 1;
1479 DECL_IGNORED_P (gnu_decl) = 1;
1480 TREE_ADDRESSABLE (gnu_decl) = 1;
1481 }
1482
1483 /* If this is a loop parameter, set the corresponding flag. */
1484 else if (kind == E_Loop_Parameter)
1485 DECL_LOOP_PARM_P (gnu_decl) = 1;
1486
1487 /* If this is a renaming pointer, attach the renamed object to it. */
1488 if (renamed_obj)
1489 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1490
1491 /* If this is a constant and we are defining it or it generates a real
1492 symbol at the object level and we are referencing it, we may want
1493 or need to have a true variable to represent it:
1494 - if optimization isn't enabled, for debugging purposes,
1495 - if the constant is public and not overlaid on something else,
1496 - if its address is taken,
1497 - if either itself or its type is aliased. */
1498 if (TREE_CODE (gnu_decl) == CONST_DECL
1499 && (definition || Sloc (gnat_entity) > Standard_Location)
1500 && ((!optimize && debug_info_p)
1501 || (Is_Public (gnat_entity)
1502 && No (Address_Clause (gnat_entity)))
1503 || Address_Taken (gnat_entity)
1504 || Is_Aliased (gnat_entity)
1505 || Is_Aliased (gnat_type)))
1506 {
1507 tree gnu_corr_var
1508 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1509 gnu_expr, true, Is_Public (gnat_entity),
1510 !definition, static_flag, volatile_flag,
1511 artificial_p, debug_info_p && definition,
1512 attr_list, gnat_entity, false);
1513
1514 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1515 }
1516
1517 /* If this is a constant, even if we don't need a true variable, we
1518 may need to avoid returning the initializer in every case. That
1519 can happen for the address of a (constant) constructor because,
1520 upon dereferencing it, the constructor will be reinjected in the
1521 tree, which may not be valid in every case; see lvalue_required_p
1522 for more details. */
1523 if (TREE_CODE (gnu_decl) == CONST_DECL)
1524 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1525
1526 /* If this object is declared in a block that contains a block with an
1527 exception handler, and we aren't using the GCC exception mechanism,
1528 we must force this variable in memory in order to avoid an invalid
1529 optimization. */
1530 if (Front_End_Exceptions ()
1531 && Has_Nested_Block_With_Handler (Scope (gnat_entity)))
1532 TREE_ADDRESSABLE (gnu_decl) = 1;
1533
1534 /* If this is a local variable with non-BLKmode and aggregate type,
1535 and optimization isn't enabled, then force it in memory so that
1536 a register won't be allocated to it with possible subparts left
1537 uninitialized and reaching the register allocator. */
1538 else if (TREE_CODE (gnu_decl) == VAR_DECL
1539 && !DECL_EXTERNAL (gnu_decl)
1540 && !TREE_STATIC (gnu_decl)
1541 && DECL_MODE (gnu_decl) != BLKmode
1542 && AGGREGATE_TYPE_P (TREE_TYPE (gnu_decl))
1543 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_decl))
1544 && !optimize)
1545 TREE_ADDRESSABLE (gnu_decl) = 1;
1546
1547 /* If we are defining an object with variable size or an object with
1548 fixed size that will be dynamically allocated, and we are using the
1549 front-end setjmp/longjmp exception mechanism, update the setjmp
1550 buffer. */
1551 if (definition
1552 && Exception_Mechanism == Front_End_SJLJ
1553 && get_block_jmpbuf_decl ()
1554 && DECL_SIZE_UNIT (gnu_decl)
1555 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1556 || (flag_stack_check == GENERIC_STACK_CHECK
1557 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1558 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1559 add_stmt_with_node (build_call_n_expr
1560 (update_setjmp_buf_decl, 1,
1561 build_unary_op (ADDR_EXPR, NULL_TREE,
1562 get_block_jmpbuf_decl ())),
1563 gnat_entity);
1564
1565 /* Back-annotate Esize and Alignment of the object if not already
1566 known. Note that we pick the values of the type, not those of
1567 the object, to shield ourselves from low-level platform-dependent
1568 adjustments like alignment promotion. This is both consistent with
1569 all the treatment above, where alignment and size are set on the
1570 type of the object and not on the object directly, and makes it
1571 possible to support all confirming representation clauses. */
1572 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1573 used_by_ref);
1574 }
1575 break;
1576
1577 case E_Void:
1578 /* Return a TYPE_DECL for "void" that we previously made. */
1579 gnu_decl = TYPE_NAME (void_type_node);
1580 break;
1581
1582 case E_Enumeration_Type:
1583 /* A special case: for the types Character and Wide_Character in
1584 Standard, we do not list all the literals. So if the literals
1585 are not specified, make this an integer type. */
1586 if (No (First_Literal (gnat_entity)))
1587 {
1588 if (esize == CHAR_TYPE_SIZE && flag_signed_char)
1589 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1590 else
1591 gnu_type = make_unsigned_type (esize);
1592 TYPE_NAME (gnu_type) = gnu_entity_name;
1593
1594 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1595 This is needed by the DWARF-2 back-end to distinguish between
1596 unsigned integer types and character types. */
1597 TYPE_STRING_FLAG (gnu_type) = 1;
1598
1599 /* This flag is needed by the call just below. */
1600 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1601
1602 finish_character_type (gnu_type);
1603 }
1604 else
1605 {
1606 /* We have a list of enumeral constants in First_Literal. We make a
1607 CONST_DECL for each one and build into GNU_LITERAL_LIST the list
1608 to be placed into TYPE_FIELDS. Each node is itself a TREE_LIST
1609 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1610 value of the literal. But when we have a regular boolean type, we
1611 simplify this a little by using a BOOLEAN_TYPE. */
1612 const bool is_boolean = Is_Boolean_Type (gnat_entity)
1613 && !Has_Non_Standard_Rep (gnat_entity);
1614 const bool is_unsigned = Is_Unsigned_Type (gnat_entity);
1615 tree gnu_list = NULL_TREE;
1616 Entity_Id gnat_literal;
1617
1618 gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1619 TYPE_PRECISION (gnu_type) = esize;
1620 TYPE_UNSIGNED (gnu_type) = is_unsigned;
1621 set_min_and_max_values_for_integral_type (gnu_type, esize,
1622 TYPE_SIGN (gnu_type));
1623 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
1624 layout_type (gnu_type);
1625
1626 for (gnat_literal = First_Literal (gnat_entity);
1627 Present (gnat_literal);
1628 gnat_literal = Next_Literal (gnat_literal))
1629 {
1630 tree gnu_value
1631 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1632 /* Do not generate debug info for individual enumerators. */
1633 tree gnu_literal
1634 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1635 gnu_type, gnu_value, true, false, false,
1636 false, false, artificial_p, false,
1637 NULL, gnat_literal);
1638 save_gnu_tree (gnat_literal, gnu_literal, false);
1639 gnu_list
1640 = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list);
1641 }
1642
1643 if (!is_boolean)
1644 TYPE_VALUES (gnu_type) = nreverse (gnu_list);
1645
1646 /* Note that the bounds are updated at the end of this function
1647 to avoid an infinite recursion since they refer to the type. */
1648 goto discrete_type;
1649 }
1650 break;
1651
1652 case E_Signed_Integer_Type:
1653 /* For integer types, just make a signed type the appropriate number
1654 of bits. */
1655 gnu_type = make_signed_type (esize);
1656 goto discrete_type;
1657
1658 case E_Ordinary_Fixed_Point_Type:
1659 case E_Decimal_Fixed_Point_Type:
1660 {
1661 /* Small_Value is the scale factor. */
1662 const Ureal gnat_small_value = Small_Value (gnat_entity);
1663 tree scale_factor = NULL_TREE;
1664
1665 gnu_type = make_signed_type (esize);
1666
1667 /* Try to decode the scale factor and to save it for the fixed-point
1668 types debug hook. */
1669
1670 /* There are various ways to describe the scale factor, however there
1671 are cases where back-end internals cannot hold it. In such cases,
1672 we output invalid scale factor for such cases (i.e. the 0/0
1673 rational constant) but we expect GNAT to output GNAT encodings,
1674 then. Thus, keep this in sync with
1675 Exp_Dbug.Is_Handled_Scale_Factor. */
1676
1677 /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
1678 binary or decimal scale: it is easier to read for humans. */
1679 if (UI_Eq (Numerator (gnat_small_value), Uint_1)
1680 && (Rbase (gnat_small_value) == 2
1681 || Rbase (gnat_small_value) == 10))
1682 {
1683 /* Given RM restrictions on 'Small values, we assume here that
1684 the denominator fits in an int. */
1685 const tree base = build_int_cst (integer_type_node,
1686 Rbase (gnat_small_value));
1687 const tree exponent
1688 = build_int_cst (integer_type_node,
1689 UI_To_Int (Denominator (gnat_small_value)));
1690 scale_factor
1691 = build2 (RDIV_EXPR, integer_type_node,
1692 integer_one_node,
1693 build2 (POWER_EXPR, integer_type_node,
1694 base, exponent));
1695 }
1696
1697 /* Default to arbitrary scale factors descriptions. */
1698 else
1699 {
1700 const Uint num = Norm_Num (gnat_small_value);
1701 const Uint den = Norm_Den (gnat_small_value);
1702
1703 if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
1704 {
1705 const tree gnu_num
1706 = build_int_cst (integer_type_node,
1707 UI_To_Int (Norm_Num (gnat_small_value)));
1708 const tree gnu_den
1709 = build_int_cst (integer_type_node,
1710 UI_To_Int (Norm_Den (gnat_small_value)));
1711 scale_factor = build2 (RDIV_EXPR, integer_type_node,
1712 gnu_num, gnu_den);
1713 }
1714 else
1715 /* If compiler internals cannot represent arbitrary scale
1716 factors, output an invalid scale factor so that debugger
1717 don't try to handle them but so that we still have a type
1718 in the output. Note that GNAT */
1719 scale_factor = integer_zero_node;
1720 }
1721
1722 TYPE_FIXED_POINT_P (gnu_type) = 1;
1723 SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor);
1724 }
1725 goto discrete_type;
1726
1727 case E_Modular_Integer_Type:
1728 {
1729 /* For modular types, make the unsigned type of the proper number
1730 of bits and then set up the modulus, if required. */
1731 tree gnu_modulus, gnu_high = NULL_TREE;
1732
1733 /* Packed Array Impl. Types are supposed to be subtypes only. */
1734 gcc_assert (!Is_Packed_Array_Impl_Type (gnat_entity));
1735
1736 gnu_type = make_unsigned_type (esize);
1737
1738 /* Get the modulus in this type. If it overflows, assume it is because
1739 it is equal to 2**Esize. Note that there is no overflow checking
1740 done on unsigned type, so we detect the overflow by looking for
1741 a modulus of zero, which is otherwise invalid. */
1742 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1743
1744 if (!integer_zerop (gnu_modulus))
1745 {
1746 TYPE_MODULAR_P (gnu_type) = 1;
1747 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1748 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1749 build_int_cst (gnu_type, 1));
1750 }
1751
1752 /* If the upper bound is not maximal, make an extra subtype. */
1753 if (gnu_high
1754 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1755 {
1756 tree gnu_subtype = make_unsigned_type (esize);
1757 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1758 TREE_TYPE (gnu_subtype) = gnu_type;
1759 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1760 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1761 gnu_type = gnu_subtype;
1762 }
1763 }
1764 goto discrete_type;
1765
1766 case E_Signed_Integer_Subtype:
1767 case E_Enumeration_Subtype:
1768 case E_Modular_Integer_Subtype:
1769 case E_Ordinary_Fixed_Point_Subtype:
1770 case E_Decimal_Fixed_Point_Subtype:
1771
1772 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1773 not want to call create_range_type since we would like each subtype
1774 node to be distinct. ??? Historically this was in preparation for
1775 when memory aliasing is implemented, but that's obsolete now given
1776 the call to relate_alias_sets below.
1777
1778 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1779 this fact is used by the arithmetic conversion functions.
1780
1781 We elaborate the Ancestor_Subtype if it is not in the current unit
1782 and one of our bounds is non-static. We do this to ensure consistent
1783 naming in the case where several subtypes share the same bounds, by
1784 elaborating the first such subtype first, thus using its name. */
1785
1786 if (!definition
1787 && Present (Ancestor_Subtype (gnat_entity))
1788 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1789 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1790 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1791 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
1792
1793 /* Set the precision to the Esize except for bit-packed arrays. */
1794 if (Is_Packed_Array_Impl_Type (gnat_entity)
1795 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1796 esize = UI_To_Int (RM_Size (gnat_entity));
1797
1798 /* First subtypes of Character are treated as Character; otherwise
1799 this should be an unsigned type if the base type is unsigned or
1800 if the lower bound is constant and non-negative or if the type
1801 is biased. However, even if the lower bound is constant and
1802 non-negative, we use a signed type for a subtype with the same
1803 size as its signed base type, because this eliminates useless
1804 conversions to it and gives more leeway to the optimizer; but
1805 this means that we will need to explicitly test for this case
1806 when we change the representation based on the RM size. */
1807 if (kind == E_Enumeration_Subtype
1808 && No (First_Literal (Etype (gnat_entity)))
1809 && Esize (gnat_entity) == RM_Size (gnat_entity)
1810 && esize == CHAR_TYPE_SIZE
1811 && flag_signed_char)
1812 gnu_type = make_signed_type (CHAR_TYPE_SIZE);
1813 else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity)))
1814 || (Esize (Etype (gnat_entity)) != Esize (gnat_entity)
1815 && Is_Unsigned_Type (gnat_entity))
1816 || Has_Biased_Representation (gnat_entity))
1817 gnu_type = make_unsigned_type (esize);
1818 else
1819 gnu_type = make_signed_type (esize);
1820 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1821
1822 SET_TYPE_RM_MIN_VALUE
1823 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
1824 gnat_entity, "L", definition, true,
1825 debug_info_p));
1826
1827 SET_TYPE_RM_MAX_VALUE
1828 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
1829 gnat_entity, "U", definition, true,
1830 debug_info_p));
1831
1832 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1833 = Has_Biased_Representation (gnat_entity);
1834
1835 /* Do the same processing for Character subtypes as for types. */
1836 if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
1837 {
1838 TYPE_NAME (gnu_type) = gnu_entity_name;
1839 TYPE_STRING_FLAG (gnu_type) = 1;
1840 TYPE_ARTIFICIAL (gnu_type) = artificial_p;
1841 finish_character_type (gnu_type);
1842 }
1843
1844 /* Inherit our alias set from what we're a subtype of. Subtypes
1845 are not different types and a pointer can designate any instance
1846 within a subtype hierarchy. */
1847 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1848
1849 /* One of the above calls might have caused us to be elaborated,
1850 so don't blow up if so. */
1851 if (present_gnu_tree (gnat_entity))
1852 {
1853 maybe_present = true;
1854 break;
1855 }
1856
1857 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1858 TYPE_STUB_DECL (gnu_type)
1859 = create_type_stub_decl (gnu_entity_name, gnu_type);
1860
1861 /* For a packed array, make the original array type a parallel/debug
1862 type. */
1863 if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity))
1864 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1865
1866 discrete_type:
1867
1868 /* We have to handle clauses that under-align the type specially. */
1869 if ((Present (Alignment_Clause (gnat_entity))
1870 || (Is_Packed_Array_Impl_Type (gnat_entity)
1871 && Present
1872 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1873 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1874 {
1875 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1876 if (align >= TYPE_ALIGN (gnu_type))
1877 align = 0;
1878 }
1879
1880 /* If the type we are dealing with represents a bit-packed array,
1881 we need to have the bits left justified on big-endian targets
1882 and right justified on little-endian targets. We also need to
1883 ensure that when the value is read (e.g. for comparison of two
1884 such values), we only get the good bits, since the unused bits
1885 are uninitialized. Both goals are accomplished by wrapping up
1886 the modular type in an enclosing record type. */
1887 if (Is_Packed_Array_Impl_Type (gnat_entity)
1888 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1889 {
1890 tree gnu_field_type, gnu_field;
1891
1892 /* Set the RM size before wrapping up the original type. */
1893 SET_TYPE_RM_SIZE (gnu_type,
1894 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1895 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1896
1897 /* Strip the ___XP suffix for standard DWARF. */
1898 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1899 gnu_entity_name = TYPE_NAME (gnu_type);
1900
1901 /* Create a stripped-down declaration, mainly for debugging. */
1902 create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
1903 gnat_entity);
1904
1905 /* Now save it and build the enclosing record type. */
1906 gnu_field_type = gnu_type;
1907
1908 gnu_type = make_node (RECORD_TYPE);
1909 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1910 TYPE_PACKED (gnu_type) = 1;
1911 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1912 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1913 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1914
1915 /* Propagate the alignment of the modular type to the record type,
1916 unless there is an alignment clause that under-aligns the type.
1917 This means that bit-packed arrays are given "ceil" alignment for
1918 their size by default, which may seem counter-intuitive but makes
1919 it possible to overlay them on modular types easily. */
1920 SET_TYPE_ALIGN (gnu_type,
1921 align > 0 ? align : TYPE_ALIGN (gnu_field_type));
1922
1923 /* Propagate the reverse storage order flag to the record type so
1924 that the required byte swapping is performed when retrieving the
1925 enclosed modular value. */
1926 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
1927 = Reverse_Storage_Order (Original_Array_Type (gnat_entity));
1928
1929 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1930
1931 /* Don't declare the field as addressable since we won't be taking
1932 its address and this would prevent create_field_decl from making
1933 a bitfield. */
1934 gnu_field
1935 = create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
1936 gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
1937
1938 /* We will output additional debug info manually below. */
1939 finish_record_type (gnu_type, gnu_field, 2, false);
1940 compute_record_mode (gnu_type);
1941 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1942
1943 if (debug_info_p)
1944 {
1945 /* Make the original array type a parallel/debug type. */
1946 associate_original_type_to_packed_array (gnu_type, gnat_entity);
1947
1948 /* Since GNU_TYPE is a padding type around the packed array
1949 implementation type, the padded type is its debug type. */
1950 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1951 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
1952 }
1953 }
1954
1955 /* If the type we are dealing with has got a smaller alignment than the
1956 natural one, we need to wrap it up in a record type and misalign the
1957 latter; we reuse the padding machinery for this purpose. */
1958 else if (align > 0)
1959 {
1960 tree gnu_size = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1961
1962 /* Set the RM size before wrapping the type. */
1963 SET_TYPE_RM_SIZE (gnu_type, gnu_size);
1964
1965 gnu_type
1966 = maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
1967 gnat_entity, false, true, definition, false);
1968
1969 TYPE_PACKED (gnu_type) = 1;
1970 SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
1971 }
1972
1973 break;
1974
1975 case E_Floating_Point_Type:
1976 /* The type of the Low and High bounds can be our type if this is
1977 a type from Standard, so set them at the end of the function. */
1978 gnu_type = make_node (REAL_TYPE);
1979 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1980 layout_type (gnu_type);
1981 break;
1982
1983 case E_Floating_Point_Subtype:
1984 /* See the E_Signed_Integer_Subtype case for the rationale. */
1985 if (!definition
1986 && Present (Ancestor_Subtype (gnat_entity))
1987 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1988 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1989 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1990 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
1991
1992 gnu_type = make_node (REAL_TYPE);
1993 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1994 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1995 TYPE_GCC_MIN_VALUE (gnu_type)
1996 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1997 TYPE_GCC_MAX_VALUE (gnu_type)
1998 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1999 layout_type (gnu_type);
2000
2001 SET_TYPE_RM_MIN_VALUE
2002 (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity),
2003 gnat_entity, "L", definition, true,
2004 debug_info_p));
2005
2006 SET_TYPE_RM_MAX_VALUE
2007 (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity),
2008 gnat_entity, "U", definition, true,
2009 debug_info_p));
2010
2011 /* Inherit our alias set from what we're a subtype of, as for
2012 integer subtypes. */
2013 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
2014
2015 /* One of the above calls might have caused us to be elaborated,
2016 so don't blow up if so. */
2017 maybe_present = true;
2018 break;
2019
2020 /* Array Types and Subtypes
2021
2022 Unconstrained array types are represented by E_Array_Type and
2023 constrained array types are represented by E_Array_Subtype. There
2024 are no actual objects of an unconstrained array type; all we have
2025 are pointers to that type.
2026
2027 The following fields are defined on array types and subtypes:
2028
2029 Component_Type Component type of the array.
2030 Number_Dimensions Number of dimensions (an int).
2031 First_Index Type of first index. */
2032
2033 case E_Array_Type:
2034 {
2035 const bool convention_fortran_p
2036 = (Convention (gnat_entity) == Convention_Fortran);
2037 const int ndim = Number_Dimensions (gnat_entity);
2038 tree gnu_template_type;
2039 tree gnu_ptr_template;
2040 tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
2041 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2042 tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
2043 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
2044 Entity_Id gnat_index, gnat_name;
2045 int index;
2046 tree comp_type;
2047
2048 /* Create the type for the component now, as it simplifies breaking
2049 type reference loops. */
2050 comp_type
2051 = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
2052 if (present_gnu_tree (gnat_entity))
2053 {
2054 /* As a side effect, the type may have been translated. */
2055 maybe_present = true;
2056 break;
2057 }
2058
2059 /* We complete an existing dummy fat pointer type in place. This both
2060 avoids further complex adjustments in update_pointer_to and yields
2061 better debugging information in DWARF by leveraging the support for
2062 incomplete declarations of "tagged" types in the DWARF back-end. */
2063 gnu_type = get_dummy_type (gnat_entity);
2064 if (gnu_type && TYPE_POINTER_TO (gnu_type))
2065 {
2066 gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
2067 TYPE_NAME (gnu_fat_type) = NULL_TREE;
2068 gnu_ptr_template =
2069 TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2070 gnu_template_type = TREE_TYPE (gnu_ptr_template);
2071
2072 /* Save the contents of the dummy type for update_pointer_to. */
2073 TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
2074 TYPE_FIELDS (TYPE_POINTER_TO (gnu_type))
2075 = copy_node (TYPE_FIELDS (gnu_fat_type));
2076 DECL_CHAIN (TYPE_FIELDS (TYPE_POINTER_TO (gnu_type)))
2077 = copy_node (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
2078 }
2079 else
2080 {
2081 gnu_fat_type = make_node (RECORD_TYPE);
2082 gnu_template_type = make_node (RECORD_TYPE);
2083 gnu_ptr_template = build_pointer_type (gnu_template_type);
2084 }
2085
2086 /* Make a node for the array. If we are not defining the array
2087 suppress expanding incomplete types. */
2088 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
2089
2090 if (!definition)
2091 {
2092 defer_incomplete_level++;
2093 this_deferred = true;
2094 }
2095
2096 /* Build the fat pointer type. Use a "void *" object instead of
2097 a pointer to the array type since we don't have the array type
2098 yet (it will reference the fat pointer via the bounds). Note
2099 that we reuse the existing fields of a dummy type because for:
2100
2101 type Arr is array (Positive range <>) of Element_Type;
2102 type Array_Ref is access Arr;
2103 Var : Array_Ref := Null;
2104
2105 in a declarative part, Arr will be frozen only after Var, which
2106 means that the fields used in the CONSTRUCTOR built for Null are
2107 those of the dummy type, which in turn means that COMPONENT_REFs
2108 of Var may be built with these fields. Now if COMPONENT_REFs of
2109 Var are also built later with the fields of the final type, the
2110 aliasing machinery may consider that the accesses are distinct
2111 if the FIELD_DECLs are distinct as objects. */
2112 if (COMPLETE_TYPE_P (gnu_fat_type))
2113 {
2114 tem = TYPE_FIELDS (gnu_fat_type);
2115 TREE_TYPE (tem) = ptr_type_node;
2116 TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template;
2117 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
2118 for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
2119 SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
2120 }
2121 else
2122 {
2123 tem
2124 = create_field_decl (get_identifier ("P_ARRAY"),
2125 ptr_type_node, gnu_fat_type,
2126 NULL_TREE, NULL_TREE, 0, 0);
2127 DECL_CHAIN (tem)
2128 = create_field_decl (get_identifier ("P_BOUNDS"),
2129 gnu_ptr_template, gnu_fat_type,
2130 NULL_TREE, NULL_TREE, 0, 0);
2131 finish_fat_pointer_type (gnu_fat_type, tem);
2132 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2133 }
2134
2135 /* Build a reference to the template from a PLACEHOLDER_EXPR that
2136 is the fat pointer. This will be used to access the individual
2137 fields once we build them. */
2138 tem = build3 (COMPONENT_REF, gnu_ptr_template,
2139 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
2140 DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
2141 gnu_template_reference
2142 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
2143 TREE_READONLY (gnu_template_reference) = 1;
2144 TREE_THIS_NOTRAP (gnu_template_reference) = 1;
2145
2146 /* Now create the GCC type for each index and add the fields for that
2147 index to the template. */
2148 for (index = (convention_fortran_p ? ndim - 1 : 0),
2149 gnat_index = First_Index (gnat_entity);
2150 IN_RANGE (index, 0, ndim - 1);
2151 index += (convention_fortran_p ? - 1 : 1),
2152 gnat_index = Next_Index (gnat_index))
2153 {
2154 char field_name[16];
2155 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2156 tree gnu_index_base_type
2157 = maybe_character_type (get_base_type (gnu_index_type));
2158 tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
2159 tree gnu_min, gnu_max, gnu_high;
2160
2161 /* Make the FIELD_DECLs for the low and high bounds of this
2162 type and then make extractions of these fields from the
2163 template. */
2164 sprintf (field_name, "LB%d", index);
2165 gnu_lb_field = create_field_decl (get_identifier (field_name),
2166 gnu_index_base_type,
2167 gnu_template_type, NULL_TREE,
2168 NULL_TREE, 0, 0);
2169 Sloc_to_locus (Sloc (gnat_entity),
2170 &DECL_SOURCE_LOCATION (gnu_lb_field));
2171
2172 field_name[0] = 'U';
2173 gnu_hb_field = create_field_decl (get_identifier (field_name),
2174 gnu_index_base_type,
2175 gnu_template_type, NULL_TREE,
2176 NULL_TREE, 0, 0);
2177 Sloc_to_locus (Sloc (gnat_entity),
2178 &DECL_SOURCE_LOCATION (gnu_hb_field));
2179
2180 gnu_temp_fields[index] = chainon (gnu_lb_field, gnu_hb_field);
2181
2182 /* We can't use build_component_ref here since the template type
2183 isn't complete yet. */
2184 gnu_orig_min = build3 (COMPONENT_REF, gnu_index_base_type,
2185 gnu_template_reference, gnu_lb_field,
2186 NULL_TREE);
2187 gnu_orig_max = build3 (COMPONENT_REF, gnu_index_base_type,
2188 gnu_template_reference, gnu_hb_field,
2189 NULL_TREE);
2190 TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1;
2191
2192 gnu_min = convert (sizetype, gnu_orig_min);
2193 gnu_max = convert (sizetype, gnu_orig_max);
2194
2195 /* Compute the size of this dimension. See the E_Array_Subtype
2196 case below for the rationale. */
2197 gnu_high
2198 = build3 (COND_EXPR, sizetype,
2199 build2 (GE_EXPR, boolean_type_node,
2200 gnu_orig_max, gnu_orig_min),
2201 gnu_max,
2202 size_binop (MINUS_EXPR, gnu_min, size_one_node));
2203
2204 /* Make a range type with the new range in the Ada base type.
2205 Then make an index type with the size range in sizetype. */
2206 gnu_index_types[index]
2207 = create_index_type (gnu_min, gnu_high,
2208 create_range_type (gnu_index_base_type,
2209 gnu_orig_min,
2210 gnu_orig_max),
2211 gnat_entity);
2212
2213 /* Update the maximum size of the array in elements. */
2214 if (gnu_max_size)
2215 {
2216 tree gnu_min
2217 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
2218 tree gnu_max
2219 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
2220 tree gnu_this_max
2221 = size_binop (PLUS_EXPR, size_one_node,
2222 size_binop (MINUS_EXPR, gnu_max, gnu_min));
2223
2224 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2225 && TREE_OVERFLOW (gnu_this_max))
2226 gnu_max_size = NULL_TREE;
2227 else
2228 gnu_max_size
2229 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2230 }
2231
2232 TYPE_NAME (gnu_index_types[index])
2233 = create_concat_name (gnat_entity, field_name);
2234 }
2235
2236 /* Install all the fields into the template. */
2237 TYPE_NAME (gnu_template_type)
2238 = create_concat_name (gnat_entity, "XUB");
2239 gnu_template_fields = NULL_TREE;
2240 for (index = 0; index < ndim; index++)
2241 gnu_template_fields
2242 = chainon (gnu_template_fields, gnu_temp_fields[index]);
2243 finish_record_type (gnu_template_type, gnu_template_fields, 0,
2244 debug_info_p);
2245 TYPE_READONLY (gnu_template_type) = 1;
2246
2247 /* If Component_Size is not already specified, annotate it with the
2248 size of the component. */
2249 if (Unknown_Component_Size (gnat_entity))
2250 Set_Component_Size (gnat_entity,
2251 annotate_value (TYPE_SIZE (comp_type)));
2252
2253 /* Compute the maximum size of the array in units and bits. */
2254 if (gnu_max_size)
2255 {
2256 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2257 TYPE_SIZE_UNIT (comp_type));
2258 gnu_max_size = size_binop (MULT_EXPR,
2259 convert (bitsizetype, gnu_max_size),
2260 TYPE_SIZE (comp_type));
2261 }
2262 else
2263 gnu_max_size_unit = NULL_TREE;
2264
2265 /* Now build the array type. */
2266 tem = comp_type;
2267 for (index = ndim - 1; index >= 0; index--)
2268 {
2269 tem = build_nonshared_array_type (tem, gnu_index_types[index]);
2270 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
2271 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2272 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2273 set_reverse_storage_order_on_array_type (tem);
2274 if (array_type_has_nonaliased_component (tem, gnat_entity))
2275 set_nonaliased_component_on_array_type (tem);
2276 }
2277
2278 /* If an alignment is specified, use it if valid. But ignore it
2279 for the original type of packed array types. If the alignment
2280 was requested with an explicit alignment clause, state so. */
2281 if (No (Packed_Array_Impl_Type (gnat_entity))
2282 && Known_Alignment (gnat_entity))
2283 {
2284 SET_TYPE_ALIGN (tem,
2285 validate_alignment (Alignment (gnat_entity),
2286 gnat_entity,
2287 TYPE_ALIGN (tem)));
2288 if (Present (Alignment_Clause (gnat_entity)))
2289 TYPE_USER_ALIGN (tem) = 1;
2290 }
2291
2292 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2293 implementation types as such so that the debug information back-end
2294 can output the appropriate description for them. */
2295 TYPE_PACKED (tem)
2296 = (Is_Packed (gnat_entity)
2297 || Is_Packed_Array_Impl_Type (gnat_entity));
2298
2299 if (Treat_As_Volatile (gnat_entity))
2300 tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE);
2301
2302 /* Adjust the type of the pointer-to-array field of the fat pointer
2303 and record the aliasing relationships if necessary. */
2304 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2305 if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
2306 record_component_aliases (gnu_fat_type);
2307
2308 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2309 corresponding fat pointer. */
2310 TREE_TYPE (gnu_type) = gnu_fat_type;
2311 TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
2312 TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2313 SET_TYPE_MODE (gnu_type, BLKmode);
2314 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
2315
2316 /* If the maximum size doesn't overflow, use it. */
2317 if (gnu_max_size
2318 && TREE_CODE (gnu_max_size) == INTEGER_CST
2319 && !TREE_OVERFLOW (gnu_max_size)
2320 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2321 && !TREE_OVERFLOW (gnu_max_size_unit))
2322 {
2323 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2324 TYPE_SIZE (tem));
2325 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2326 TYPE_SIZE_UNIT (tem));
2327 }
2328
2329 create_type_decl (create_concat_name (gnat_entity, "XUA"), tem,
2330 artificial_p, debug_info_p, gnat_entity);
2331
2332 /* If told to generate GNAT encodings for them (GDB rely on them at the
2333 moment): give the fat pointer type a name. If this is a packed
2334 array, tell the debugger how to interpret the underlying bits. */
2335 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2336 gnat_name = Packed_Array_Impl_Type (gnat_entity);
2337 else
2338 gnat_name = gnat_entity;
2339 tree xup_name
2340 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2341 ? get_entity_name (gnat_name)
2342 : create_concat_name (gnat_name, "XUP");
2343 create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
2344 gnat_entity);
2345
2346 /* Create the type to be designated by thin pointers: a record type for
2347 the array and its template. We used to shift the fields to have the
2348 template at a negative offset, but this was somewhat of a kludge; we
2349 now shift thin pointer values explicitly but only those which have a
2350 TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE.
2351 Note that GDB can handle standard DWARF information for them, so we
2352 don't have to name them as a GNAT encoding, except if specifically
2353 asked to. */
2354 tree xut_name
2355 = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2356 ? get_entity_name (gnat_name)
2357 : create_concat_name (gnat_name, "XUT");
2358 tem = build_unc_object_type (gnu_template_type, tem, xut_name,
2359 debug_info_p);
2360
2361 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2362 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2363 }
2364 break;
2365
2366 case E_Array_Subtype:
2367
2368 /* This is the actual data type for array variables. Multidimensional
2369 arrays are implemented as arrays of arrays. Note that arrays which
2370 have sparse enumeration subtypes as index components create sparse
2371 arrays, which is obviously space inefficient but so much easier to
2372 code for now.
2373
2374 Also note that the subtype never refers to the unconstrained array
2375 type, which is somewhat at variance with Ada semantics.
2376
2377 First check to see if this is simply a renaming of the array type.
2378 If so, the result is the array type. */
2379
2380 gnu_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity)));
2381 if (!Is_Constrained (gnat_entity))
2382 ;
2383 else
2384 {
2385 Entity_Id gnat_index, gnat_base_index;
2386 const bool convention_fortran_p
2387 = (Convention (gnat_entity) == Convention_Fortran);
2388 const int ndim = Number_Dimensions (gnat_entity);
2389 tree gnu_base_type = gnu_type;
2390 tree *gnu_index_types = XALLOCAVEC (tree, ndim);
2391 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2392 bool need_index_type_struct = false;
2393 int index;
2394
2395 /* First create the GCC type for each index and find out whether
2396 special types are needed for debugging information. */
2397 for (index = (convention_fortran_p ? ndim - 1 : 0),
2398 gnat_index = First_Index (gnat_entity),
2399 gnat_base_index
2400 = First_Index (Implementation_Base_Type (gnat_entity));
2401 IN_RANGE (index, 0, ndim - 1);
2402 index += (convention_fortran_p ? - 1 : 1),
2403 gnat_index = Next_Index (gnat_index),
2404 gnat_base_index = Next_Index (gnat_base_index))
2405 {
2406 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2407 tree gnu_index_base_type
2408 = maybe_character_type (get_base_type (gnu_index_type));
2409 tree gnu_orig_min
2410 = convert (gnu_index_base_type,
2411 TYPE_MIN_VALUE (gnu_index_type));
2412 tree gnu_orig_max
2413 = convert (gnu_index_base_type,
2414 TYPE_MAX_VALUE (gnu_index_type));
2415 tree gnu_min = convert (sizetype, gnu_orig_min);
2416 tree gnu_max = convert (sizetype, gnu_orig_max);
2417 tree gnu_base_index_type
2418 = get_unpadded_type (Etype (gnat_base_index));
2419 tree gnu_base_index_base_type
2420 = maybe_character_type (get_base_type (gnu_base_index_type));
2421 tree gnu_base_orig_min
2422 = convert (gnu_base_index_base_type,
2423 TYPE_MIN_VALUE (gnu_base_index_type));
2424 tree gnu_base_orig_max
2425 = convert (gnu_base_index_base_type,
2426 TYPE_MAX_VALUE (gnu_base_index_type));
2427 tree gnu_high;
2428
2429 /* See if the base array type is already flat. If it is, we
2430 are probably compiling an ACATS test but it will cause the
2431 code below to malfunction if we don't handle it specially. */
2432 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2433 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2434 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2435 {
2436 gnu_min = size_one_node;
2437 gnu_max = size_zero_node;
2438 gnu_high = gnu_max;
2439 }
2440
2441 /* Similarly, if one of the values overflows in sizetype and the
2442 range is null, use 1..0 for the sizetype bounds. */
2443 else if (TREE_CODE (gnu_min) == INTEGER_CST
2444 && TREE_CODE (gnu_max) == INTEGER_CST
2445 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2446 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2447 {
2448 gnu_min = size_one_node;
2449 gnu_max = size_zero_node;
2450 gnu_high = gnu_max;
2451 }
2452
2453 /* If the minimum and maximum values both overflow in sizetype,
2454 but the difference in the original type does not overflow in
2455 sizetype, ignore the overflow indication. */
2456 else if (TREE_CODE (gnu_min) == INTEGER_CST
2457 && TREE_CODE (gnu_max) == INTEGER_CST
2458 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2459 && !TREE_OVERFLOW
2460 (convert (sizetype,
2461 fold_build2 (MINUS_EXPR, gnu_index_type,
2462 gnu_orig_max,
2463 gnu_orig_min))))
2464 {
2465 TREE_OVERFLOW (gnu_min) = 0;
2466 TREE_OVERFLOW (gnu_max) = 0;
2467 gnu_high = gnu_max;
2468 }
2469
2470 /* Compute the size of this dimension in the general case. We
2471 need to provide GCC with an upper bound to use but have to
2472 deal with the "superflat" case. There are three ways to do
2473 this. If we can prove that the array can never be superflat,
2474 we can just use the high bound of the index type. */
2475 else if ((Nkind (gnat_index) == N_Range
2476 && cannot_be_superflat (gnat_index))
2477 /* Bit-Packed Array Impl. Types are never superflat. */
2478 || (Is_Packed_Array_Impl_Type (gnat_entity)
2479 && Is_Bit_Packed_Array
2480 (Original_Array_Type (gnat_entity))))
2481 gnu_high = gnu_max;
2482
2483 /* Otherwise, if the high bound is constant but the low bound is
2484 not, we use the expression (hb >= lb) ? lb : hb + 1 for the
2485 lower bound. Note that the comparison must be done in the
2486 original type to avoid any overflow during the conversion. */
2487 else if (TREE_CODE (gnu_max) == INTEGER_CST
2488 && TREE_CODE (gnu_min) != INTEGER_CST)
2489 {
2490 gnu_high = gnu_max;
2491 gnu_min
2492 = build_cond_expr (sizetype,
2493 build_binary_op (GE_EXPR,
2494 boolean_type_node,
2495 gnu_orig_max,
2496 gnu_orig_min),
2497 gnu_min,
2498 int_const_binop (PLUS_EXPR, gnu_max,
2499 size_one_node));
2500 }
2501
2502 /* Finally we use (hb >= lb) ? hb : lb - 1 for the upper bound
2503 in all the other cases. Note that, here as well as above,
2504 the condition used in the comparison must be equivalent to
2505 the condition (length != 0). This is relied upon in order
2506 to optimize array comparisons in compare_arrays. Moreover
2507 we use int_const_binop for the shift by 1 if the bound is
2508 constant to avoid any unwanted overflow. */
2509 else
2510 gnu_high
2511 = build_cond_expr (sizetype,
2512 build_binary_op (GE_EXPR,
2513 boolean_type_node,
2514 gnu_orig_max,
2515 gnu_orig_min),
2516 gnu_max,
2517 TREE_CODE (gnu_min) == INTEGER_CST
2518 ? int_const_binop (MINUS_EXPR, gnu_min,
2519 size_one_node)
2520 : size_binop (MINUS_EXPR, gnu_min,
2521 size_one_node));
2522
2523 /* Reuse the index type for the range type. Then make an index
2524 type with the size range in sizetype. */
2525 gnu_index_types[index]
2526 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2527 gnat_entity);
2528
2529 /* Update the maximum size of the array in elements. Here we
2530 see if any constraint on the index type of the base type
2531 can be used in the case of self-referential bound on the
2532 index type of the subtype. We look for a non-"infinite"
2533 and non-self-referential bound from any type involved and
2534 handle each bound separately. */
2535 if (gnu_max_size)
2536 {
2537 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2538 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2539 tree gnu_base_base_min
2540 = convert (sizetype,
2541 TYPE_MIN_VALUE (gnu_base_index_base_type));
2542 tree gnu_base_base_max
2543 = convert (sizetype,
2544 TYPE_MAX_VALUE (gnu_base_index_base_type));
2545
2546 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2547 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2548 && !TREE_OVERFLOW (gnu_base_min)))
2549 gnu_base_min = gnu_min;
2550
2551 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2552 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2553 && !TREE_OVERFLOW (gnu_base_max)))
2554 gnu_base_max = gnu_max;
2555
2556 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2557 && TREE_OVERFLOW (gnu_base_min))
2558 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2559 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2560 && TREE_OVERFLOW (gnu_base_max))
2561 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2562 gnu_max_size = NULL_TREE;
2563 else
2564 {
2565 tree gnu_this_max;
2566
2567 /* Use int_const_binop if the bounds are constant to
2568 avoid any unwanted overflow. */
2569 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2570 && TREE_CODE (gnu_base_max) == INTEGER_CST)
2571 gnu_this_max
2572 = int_const_binop (PLUS_EXPR, size_one_node,
2573 int_const_binop (MINUS_EXPR,
2574 gnu_base_max,
2575 gnu_base_min));
2576 else
2577 gnu_this_max
2578 = size_binop (PLUS_EXPR, size_one_node,
2579 size_binop (MINUS_EXPR,
2580 gnu_base_max,
2581 gnu_base_min));
2582
2583 gnu_max_size
2584 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2585 }
2586 }
2587
2588 /* We need special types for debugging information to point to
2589 the index types if they have variable bounds, are not integer
2590 types, are biased or are wider than sizetype. These are GNAT
2591 encodings, so we have to include them only when all encodings
2592 are requested. */
2593 if ((TREE_CODE (gnu_orig_min) != INTEGER_CST
2594 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2595 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2596 || (TREE_TYPE (gnu_index_type)
2597 && TREE_CODE (TREE_TYPE (gnu_index_type))
2598 != INTEGER_TYPE)
2599 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
2600 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2601 need_index_type_struct = true;
2602 }
2603
2604 /* Then flatten: create the array of arrays. For an array type
2605 used to implement a packed array, get the component type from
2606 the original array type since the representation clauses that
2607 can affect it are on the latter. */
2608 if (Is_Packed_Array_Impl_Type (gnat_entity)
2609 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2610 {
2611 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2612 for (index = ndim - 1; index >= 0; index--)
2613 gnu_type = TREE_TYPE (gnu_type);
2614
2615 /* One of the above calls might have caused us to be elaborated,
2616 so don't blow up if so. */
2617 if (present_gnu_tree (gnat_entity))
2618 {
2619 maybe_present = true;
2620 break;
2621 }
2622 }
2623 else
2624 {
2625 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2626 debug_info_p);
2627
2628 /* One of the above calls might have caused us to be elaborated,
2629 so don't blow up if so. */
2630 if (present_gnu_tree (gnat_entity))
2631 {
2632 maybe_present = true;
2633 break;
2634 }
2635 }
2636
2637 /* Compute the maximum size of the array in units and bits. */
2638 if (gnu_max_size)
2639 {
2640 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2641 TYPE_SIZE_UNIT (gnu_type));
2642 gnu_max_size = size_binop (MULT_EXPR,
2643 convert (bitsizetype, gnu_max_size),
2644 TYPE_SIZE (gnu_type));
2645 }
2646 else
2647 gnu_max_size_unit = NULL_TREE;
2648
2649 /* Now build the array type. */
2650 for (index = ndim - 1; index >= 0; index --)
2651 {
2652 gnu_type = build_nonshared_array_type (gnu_type,
2653 gnu_index_types[index]);
2654 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2655 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2656 if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
2657 set_reverse_storage_order_on_array_type (gnu_type);
2658 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2659 set_nonaliased_component_on_array_type (gnu_type);
2660 }
2661
2662 /* Strip the ___XP suffix for standard DWARF. */
2663 if (Is_Packed_Array_Impl_Type (gnat_entity)
2664 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
2665 {
2666 Entity_Id gnat_original_array_type
2667 = Underlying_Type (Original_Array_Type (gnat_entity));
2668
2669 gnu_entity_name
2670 = get_entity_name (gnat_original_array_type);
2671 }
2672
2673 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2674 TYPE_STUB_DECL (gnu_type)
2675 = create_type_stub_decl (gnu_entity_name, gnu_type);
2676
2677 /* If this is a multi-dimensional array and we are at global level,
2678 we need to make a variable corresponding to the stride of the
2679 inner dimensions. */
2680 if (ndim > 1 && global_bindings_p ())
2681 {
2682 tree gnu_arr_type;
2683
2684 for (gnu_arr_type = TREE_TYPE (gnu_type), index = 1;
2685 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2686 gnu_arr_type = TREE_TYPE (gnu_arr_type), index++)
2687 {
2688 tree eltype = TREE_TYPE (gnu_arr_type);
2689 char stride_name[32];
2690
2691 sprintf (stride_name, "ST%d", index);
2692 TYPE_SIZE (gnu_arr_type)
2693 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2694 gnat_entity, stride_name,
2695 definition, false);
2696
2697 /* ??? For now, store the size as a multiple of the
2698 alignment of the element type in bytes so that we
2699 can see the alignment from the tree. */
2700 sprintf (stride_name, "ST%d_A_UNIT", index);
2701 TYPE_SIZE_UNIT (gnu_arr_type)
2702 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type),
2703 gnat_entity, stride_name,
2704 definition, false,
2705 TYPE_ALIGN (eltype));
2706
2707 /* ??? create_type_decl is not invoked on the inner types so
2708 the MULT_EXPR node built above will never be marked. */
2709 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2710 }
2711 }
2712
2713 /* If we need to write out a record type giving the names of the
2714 bounds for debugging purposes, do it now and make the record
2715 type a parallel type. This is not needed for a packed array
2716 since the bounds are conveyed by the original array type. */
2717 if (need_index_type_struct
2718 && debug_info_p
2719 && !Is_Packed_Array_Impl_Type (gnat_entity))
2720 {
2721 tree gnu_bound_rec = make_node (RECORD_TYPE);
2722 tree gnu_field_list = NULL_TREE;
2723 tree gnu_field;
2724
2725 TYPE_NAME (gnu_bound_rec)
2726 = create_concat_name (gnat_entity, "XA");
2727
2728 for (index = ndim - 1; index >= 0; index--)
2729 {
2730 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2731 tree gnu_index_name = TYPE_IDENTIFIER (gnu_index);
2732
2733 /* Make sure to reference the types themselves, and not just
2734 their names, as the debugger may fall back on them. */
2735 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2736 gnu_bound_rec, NULL_TREE,
2737 NULL_TREE, 0, 0);
2738 DECL_CHAIN (gnu_field) = gnu_field_list;
2739 gnu_field_list = gnu_field;
2740 }
2741
2742 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2743 add_parallel_type (gnu_type, gnu_bound_rec);
2744 }
2745
2746 /* If this is a packed array type, make the original array type a
2747 parallel/debug type. Otherwise, if such GNAT encodings are
2748 required, do it for the base array type if it isn't artificial to
2749 make sure it is kept in the debug info. */
2750 if (debug_info_p)
2751 {
2752 if (Is_Packed_Array_Impl_Type (gnat_entity))
2753 associate_original_type_to_packed_array (gnu_type,
2754 gnat_entity);
2755 else
2756 {
2757 tree gnu_base_decl
2758 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
2759 false);
2760 if (!DECL_ARTIFICIAL (gnu_base_decl)
2761 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
2762 add_parallel_type (gnu_type,
2763 TREE_TYPE (TREE_TYPE (gnu_base_decl)));
2764 }
2765 }
2766
2767 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2768 = (Is_Packed_Array_Impl_Type (gnat_entity)
2769 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2770
2771 /* Tag top-level ARRAY_TYPE nodes for packed arrays and their
2772 implementation types as such so that the debug information back-end
2773 can output the appropriate description for them. */
2774 TYPE_PACKED (gnu_type)
2775 = (Is_Packed (gnat_entity)
2776 || Is_Packed_Array_Impl_Type (gnat_entity));
2777
2778 /* If the size is self-referential and the maximum size doesn't
2779 overflow, use it. */
2780 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2781 && gnu_max_size
2782 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2783 && TREE_OVERFLOW (gnu_max_size))
2784 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2785 && TREE_OVERFLOW (gnu_max_size_unit)))
2786 {
2787 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2788 TYPE_SIZE (gnu_type));
2789 TYPE_SIZE_UNIT (gnu_type)
2790 = size_binop (MIN_EXPR, gnu_max_size_unit,
2791 TYPE_SIZE_UNIT (gnu_type));
2792 }
2793
2794 /* Set our alias set to that of our base type. This gives all
2795 array subtypes the same alias set. */
2796 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2797
2798 /* If this is a packed type, make this type the same as the packed
2799 array type, but do some adjusting in the type first. */
2800 if (Present (Packed_Array_Impl_Type (gnat_entity)))
2801 {
2802 Entity_Id gnat_index;
2803 tree gnu_inner;
2804
2805 /* First finish the type we had been making so that we output
2806 debugging information for it. */
2807 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
2808 if (Treat_As_Volatile (gnat_entity))
2809 {
2810 const int quals
2811 = TYPE_QUAL_VOLATILE
2812 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
2813 gnu_type = change_qualified_type (gnu_type, quals);
2814 }
2815 /* Make it artificial only if the base type was artificial too.
2816 That's sort of "morally" true and will make it possible for
2817 the debugger to look it up by name in DWARF, which is needed
2818 in order to decode the packed array type. */
2819 gnu_decl
2820 = create_type_decl (gnu_entity_name, gnu_type,
2821 !Comes_From_Source (Etype (gnat_entity))
2822 && artificial_p, debug_info_p,
2823 gnat_entity);
2824
2825 /* Save it as our equivalent in case the call below elaborates
2826 this type again. */
2827 save_gnu_tree (gnat_entity, gnu_decl, false);
2828
2829 gnu_decl
2830 = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
2831 NULL_TREE, false);
2832 this_made_decl = true;
2833 gnu_type = TREE_TYPE (gnu_decl);
2834 save_gnu_tree (gnat_entity, NULL_TREE, false);
2835 save_gnu_tree (gnat_entity, gnu_decl, false);
2836 saved = true;
2837
2838 gnu_inner = gnu_type;
2839 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2840 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2841 || TYPE_PADDING_P (gnu_inner)))
2842 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2843
2844 /* We need to attach the index type to the type we just made so
2845 that the actual bounds can later be put into a template. */
2846 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2847 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2848 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2849 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2850 {
2851 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2852 {
2853 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2854 TYPE_MODULUS for modular types so we make an extra
2855 subtype if necessary. */
2856 if (TYPE_MODULAR_P (gnu_inner))
2857 {
2858 tree gnu_subtype
2859 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2860 TREE_TYPE (gnu_subtype) = gnu_inner;
2861 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2862 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2863 TYPE_MIN_VALUE (gnu_inner));
2864 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2865 TYPE_MAX_VALUE (gnu_inner));
2866 gnu_inner = gnu_subtype;
2867 }
2868
2869 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2870
2871 /* Check for other cases of overloading. */
2872 gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2873 }
2874
2875 for (gnat_index = First_Index (gnat_entity);
2876 Present (gnat_index);
2877 gnat_index = Next_Index (gnat_index))
2878 SET_TYPE_ACTUAL_BOUNDS
2879 (gnu_inner,
2880 tree_cons (NULL_TREE,
2881 get_unpadded_type (Etype (gnat_index)),
2882 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2883
2884 if (Convention (gnat_entity) != Convention_Fortran)
2885 SET_TYPE_ACTUAL_BOUNDS
2886 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2887
2888 if (TREE_CODE (gnu_type) == RECORD_TYPE
2889 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2890 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2891 }
2892 }
2893 }
2894 break;
2895
2896 case E_String_Literal_Subtype:
2897 /* Create the type for a string literal. */
2898 {
2899 Entity_Id gnat_full_type
2900 = (Is_Private_Type (Etype (gnat_entity))
2901 && Present (Full_View (Etype (gnat_entity)))
2902 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2903 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2904 tree gnu_string_array_type
2905 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2906 tree gnu_string_index_type
2907 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2908 (TYPE_DOMAIN (gnu_string_array_type))));
2909 tree gnu_lower_bound
2910 = convert (gnu_string_index_type,
2911 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2912 tree gnu_length
2913 = UI_To_gnu (String_Literal_Length (gnat_entity),
2914 gnu_string_index_type);
2915 tree gnu_upper_bound
2916 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2917 gnu_lower_bound,
2918 int_const_binop (MINUS_EXPR, gnu_length,
2919 convert (gnu_string_index_type,
2920 integer_one_node)));
2921 tree gnu_index_type
2922 = create_index_type (convert (sizetype, gnu_lower_bound),
2923 convert (sizetype, gnu_upper_bound),
2924 create_range_type (gnu_string_index_type,
2925 gnu_lower_bound,
2926 gnu_upper_bound),
2927 gnat_entity);
2928
2929 gnu_type
2930 = build_nonshared_array_type (gnat_to_gnu_type
2931 (Component_Type (gnat_entity)),
2932 gnu_index_type);
2933 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2934 set_nonaliased_component_on_array_type (gnu_type);
2935 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2936 }
2937 break;
2938
2939 /* Record Types and Subtypes
2940
2941 The following fields are defined on record types:
2942
2943 Has_Discriminants True if the record has discriminants
2944 First_Discriminant Points to head of list of discriminants
2945 First_Entity Points to head of list of fields
2946 Is_Tagged_Type True if the record is tagged
2947
2948 Implementation of Ada records and discriminated records:
2949
2950 A record type definition is transformed into the equivalent of a C
2951 struct definition. The fields that are the discriminants which are
2952 found in the Full_Type_Declaration node and the elements of the
2953 Component_List found in the Record_Type_Definition node. The
2954 Component_List can be a recursive structure since each Variant of
2955 the Variant_Part of the Component_List has a Component_List.
2956
2957 Processing of a record type definition comprises starting the list of
2958 field declarations here from the discriminants and the calling the
2959 function components_to_record to add the rest of the fields from the
2960 component list and return the gnu type node. The function
2961 components_to_record will call itself recursively as it traverses
2962 the tree. */
2963
2964 case E_Record_Type:
2965 if (Has_Complex_Representation (gnat_entity))
2966 {
2967 gnu_type
2968 = build_complex_type
2969 (get_unpadded_type
2970 (Etype (Defining_Entity
2971 (First (Component_Items
2972 (Component_List
2973 (Type_Definition
2974 (Declaration_Node (gnat_entity)))))))));
2975
2976 break;
2977 }
2978
2979 {
2980 Node_Id full_definition = Declaration_Node (gnat_entity);
2981 Node_Id record_definition = Type_Definition (full_definition);
2982 Node_Id gnat_constr;
2983 Entity_Id gnat_field, gnat_parent_type;
2984 tree gnu_field, gnu_field_list = NULL_TREE;
2985 tree gnu_get_parent;
2986 /* Set PACKED in keeping with gnat_to_gnu_field. */
2987 const int packed
2988 = Is_Packed (gnat_entity)
2989 ? 1
2990 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2991 ? -1
2992 : 0;
2993 const bool has_align = Known_Alignment (gnat_entity);
2994 const bool has_discr = Has_Discriminants (gnat_entity);
2995 const bool has_rep = Has_Specified_Layout (gnat_entity);
2996 const bool is_extension
2997 = (Is_Tagged_Type (gnat_entity)
2998 && Nkind (record_definition) == N_Derived_Type_Definition);
2999 const bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
3000 bool all_rep = has_rep;
3001
3002 /* See if all fields have a rep clause. Stop when we find one
3003 that doesn't. */
3004 if (all_rep)
3005 for (gnat_field = First_Entity (gnat_entity);
3006 Present (gnat_field);
3007 gnat_field = Next_Entity (gnat_field))
3008 if ((Ekind (gnat_field) == E_Component
3009 || Ekind (gnat_field) == E_Discriminant)
3010 && No (Component_Clause (gnat_field)))
3011 {
3012 all_rep = false;
3013 break;
3014 }
3015
3016 /* If this is a record extension, go a level further to find the
3017 record definition. Also, verify we have a Parent_Subtype. */
3018 if (is_extension)
3019 {
3020 if (!type_annotate_only
3021 || Present (Record_Extension_Part (record_definition)))
3022 record_definition = Record_Extension_Part (record_definition);
3023
3024 gcc_assert (type_annotate_only
3025 || Present (Parent_Subtype (gnat_entity)));
3026 }
3027
3028 /* Make a node for the record. If we are not defining the record,
3029 suppress expanding incomplete types. */
3030 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
3031 TYPE_NAME (gnu_type) = gnu_entity_name;
3032 TYPE_PACKED (gnu_type) = (packed != 0) || has_align || has_rep;
3033 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3034 = Reverse_Storage_Order (gnat_entity);
3035 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3036
3037 if (!definition)
3038 {
3039 defer_incomplete_level++;
3040 this_deferred = true;
3041 }
3042
3043 /* If both a size and rep clause were specified, put the size on
3044 the record type now so that it can get the proper layout. */
3045 if (has_rep && Known_RM_Size (gnat_entity))
3046 TYPE_SIZE (gnu_type)
3047 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
3048
3049 /* Always set the alignment on the record type here so that it can
3050 get the proper layout. */
3051 if (has_align)
3052 SET_TYPE_ALIGN (gnu_type,
3053 validate_alignment (Alignment (gnat_entity),
3054 gnat_entity, 0));
3055 else
3056 {
3057 SET_TYPE_ALIGN (gnu_type, 0);
3058
3059 /* If a type needs strict alignment, the minimum size will be the
3060 type size instead of the RM size (see validate_size). Cap the
3061 alignment lest it causes this type size to become too large. */
3062 if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity))
3063 {
3064 unsigned int max_size = UI_To_Int (RM_Size (gnat_entity));
3065 unsigned int max_align = max_size & -max_size;
3066 if (max_align < BIGGEST_ALIGNMENT)
3067 TYPE_MAX_ALIGN (gnu_type) = max_align;
3068 }
3069 }
3070
3071 /* If we have a Parent_Subtype, make a field for the parent. If
3072 this record has rep clauses, force the position to zero. */
3073 if (Present (Parent_Subtype (gnat_entity)))
3074 {
3075 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
3076 tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
3077 tree gnu_parent;
3078 int parent_packed = 0;
3079
3080 /* A major complexity here is that the parent subtype will
3081 reference our discriminants in its Stored_Constraint list.
3082 But those must reference the parent component of this record
3083 which is precisely of the parent subtype we have not built yet!
3084 To break the circle we first build a dummy COMPONENT_REF which
3085 represents the "get to the parent" operation and initialize
3086 each of those discriminants to a COMPONENT_REF of the above
3087 dummy parent referencing the corresponding discriminant of the
3088 base type of the parent subtype. */
3089 gnu_get_parent = build3 (COMPONENT_REF, gnu_dummy_parent_type,
3090 build0 (PLACEHOLDER_EXPR, gnu_type),
3091 build_decl (input_location,
3092 FIELD_DECL, NULL_TREE,
3093 gnu_dummy_parent_type),
3094 NULL_TREE);
3095
3096 if (has_discr)
3097 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3098 Present (gnat_field);
3099 gnat_field = Next_Stored_Discriminant (gnat_field))
3100 if (Present (Corresponding_Discriminant (gnat_field)))
3101 {
3102 tree gnu_field
3103 = gnat_to_gnu_field_decl (Corresponding_Discriminant
3104 (gnat_field));
3105 save_gnu_tree
3106 (gnat_field,
3107 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3108 gnu_get_parent, gnu_field, NULL_TREE),
3109 true);
3110 }
3111
3112 /* Then we build the parent subtype. If it has discriminants but
3113 the type itself has unknown discriminants, this means that it
3114 doesn't contain information about how the discriminants are
3115 derived from those of the ancestor type, so it cannot be used
3116 directly. Instead it is built by cloning the parent subtype
3117 of the underlying record view of the type, for which the above
3118 derivation of discriminants has been made explicit. */
3119 if (Has_Discriminants (gnat_parent)
3120 && Has_Unknown_Discriminants (gnat_entity))
3121 {
3122 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
3123
3124 /* If we are defining the type, the underlying record
3125 view must already have been elaborated at this point.
3126 Otherwise do it now as its parent subtype cannot be
3127 technically elaborated on its own. */
3128 if (definition)
3129 gcc_assert (present_gnu_tree (gnat_uview));
3130 else
3131 gnat_to_gnu_entity (gnat_uview, NULL_TREE, false);
3132
3133 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
3134
3135 /* Substitute the "get to the parent" of the type for that
3136 of its underlying record view in the cloned type. */
3137 for (gnat_field = First_Stored_Discriminant (gnat_uview);
3138 Present (gnat_field);
3139 gnat_field = Next_Stored_Discriminant (gnat_field))
3140 if (Present (Corresponding_Discriminant (gnat_field)))
3141 {
3142 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
3143 tree gnu_ref
3144 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3145 gnu_get_parent, gnu_field, NULL_TREE);
3146 gnu_parent
3147 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
3148 }
3149 }
3150 else
3151 gnu_parent = gnat_to_gnu_type (gnat_parent);
3152
3153 /* The parent field needs strict alignment so, if it is to
3154 be created with a component clause below, then we need
3155 to apply the same adjustment as in gnat_to_gnu_field. */
3156 if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
3157 {
3158 /* ??? For historical reasons, we do it on strict-alignment
3159 platforms only, where it is really required. This means
3160 that a confirming representation clause will change the
3161 behavior of the compiler on the other platforms. */
3162 if (STRICT_ALIGNMENT)
3163 SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
3164 else
3165 parent_packed
3166 = adjust_packed (gnu_parent, gnu_type, parent_packed);
3167 }
3168
3169 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
3170 initially built. The discriminants must reference the fields
3171 of the parent subtype and not those of its base type for the
3172 placeholder machinery to properly work. */
3173 if (has_discr)
3174 {
3175 /* The actual parent subtype is the full view. */
3176 if (Is_Private_Type (gnat_parent))
3177 {
3178 if (Present (Full_View (gnat_parent)))
3179 gnat_parent = Full_View (gnat_parent);
3180 else
3181 gnat_parent = Underlying_Full_View (gnat_parent);
3182 }
3183
3184 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3185 Present (gnat_field);
3186 gnat_field = Next_Stored_Discriminant (gnat_field))
3187 if (Present (Corresponding_Discriminant (gnat_field)))
3188 {
3189 Entity_Id field;
3190 for (field = First_Stored_Discriminant (gnat_parent);
3191 Present (field);
3192 field = Next_Stored_Discriminant (field))
3193 if (same_discriminant_p (gnat_field, field))
3194 break;
3195 gcc_assert (Present (field));
3196 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
3197 = gnat_to_gnu_field_decl (field);
3198 }
3199 }
3200
3201 /* The "get to the parent" COMPONENT_REF must be given its
3202 proper type... */
3203 TREE_TYPE (gnu_get_parent) = gnu_parent;
3204
3205 /* ...and reference the _Parent field of this record. */
3206 gnu_field
3207 = create_field_decl (parent_name_id,
3208 gnu_parent, gnu_type,
3209 has_rep
3210 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
3211 has_rep
3212 ? bitsize_zero_node : NULL_TREE,
3213 parent_packed, 1);
3214 DECL_INTERNAL_P (gnu_field) = 1;
3215 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
3216 TYPE_FIELDS (gnu_type) = gnu_field;
3217 }
3218
3219 /* Make the fields for the discriminants and put them into the record
3220 unless it's an Unchecked_Union. */
3221 if (has_discr)
3222 for (gnat_field = First_Stored_Discriminant (gnat_entity);
3223 Present (gnat_field);
3224 gnat_field = Next_Stored_Discriminant (gnat_field))
3225 {
3226 /* If this is a record extension and this discriminant is the
3227 renaming of another discriminant, we've handled it above. */
3228 if (is_extension
3229 && Present (Corresponding_Discriminant (gnat_field)))
3230 continue;
3231
3232 gnu_field
3233 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
3234 debug_info_p);
3235
3236 /* Make an expression using a PLACEHOLDER_EXPR from the
3237 FIELD_DECL node just created and link that with the
3238 corresponding GNAT defining identifier. */
3239 save_gnu_tree (gnat_field,
3240 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
3241 build0 (PLACEHOLDER_EXPR, gnu_type),
3242 gnu_field, NULL_TREE),
3243 true);
3244
3245 if (!is_unchecked_union)
3246 {
3247 DECL_CHAIN (gnu_field) = gnu_field_list;
3248 gnu_field_list = gnu_field;
3249 }
3250 }
3251
3252 /* If we have a derived untagged type that renames discriminants in
3253 the parent type, the (stored) discriminants are just a copy of the
3254 discriminants of the parent type. This means that any constraints
3255 added by the renaming in the derivation are disregarded as far as
3256 the layout of the derived type is concerned. To rescue them, we
3257 change the type of the (stored) discriminants to a subtype with
3258 the bounds of the type of the visible discriminants. */
3259 if (has_discr
3260 && !is_extension
3261 && Stored_Constraint (gnat_entity) != No_Elist)
3262 for (gnat_constr = First_Elmt (Stored_Constraint (gnat_entity));
3263 gnat_constr != No_Elmt;
3264 gnat_constr = Next_Elmt (gnat_constr))
3265 if (Nkind (Node (gnat_constr)) == N_Identifier
3266 /* Ignore access discriminants. */
3267 && !Is_Access_Type (Etype (Node (gnat_constr)))
3268 && Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
3269 {
3270 Entity_Id gnat_discr = Entity (Node (gnat_constr));
3271 tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
3272 tree gnu_ref
3273 = gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
3274 NULL_TREE, false);
3275
3276 /* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
3277 just above for one of the stored discriminants. */
3278 gcc_assert (TREE_TYPE (TREE_OPERAND (gnu_ref, 0)) == gnu_type);
3279
3280 if (gnu_discr_type != TREE_TYPE (gnu_ref))
3281 {
3282 const unsigned prec = TYPE_PRECISION (TREE_TYPE (gnu_ref));
3283 tree gnu_subtype
3284 = TYPE_UNSIGNED (TREE_TYPE (gnu_ref))
3285 ? make_unsigned_type (prec) : make_signed_type (prec);
3286 TREE_TYPE (gnu_subtype) = TREE_TYPE (gnu_ref);
3287 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
3288 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
3289 TYPE_MIN_VALUE (gnu_discr_type));
3290 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
3291 TYPE_MAX_VALUE (gnu_discr_type));
3292 TREE_TYPE (gnu_ref)
3293 = TREE_TYPE (TREE_OPERAND (gnu_ref, 1)) = gnu_subtype;
3294 }
3295 }
3296
3297 /* If this is a derived type with discriminants and these discriminants
3298 affect the initial shape it has inherited, factor them in. */
3299 if (has_discr
3300 && !is_extension
3301 && !Has_Record_Rep_Clause (gnat_entity)
3302 && Stored_Constraint (gnat_entity) != No_Elist
3303 && (gnat_parent_type = Underlying_Type (Etype (gnat_entity)))
3304 && Is_Record_Type (gnat_parent_type)
3305 && Is_Unchecked_Union (gnat_entity)
3306 == Is_Unchecked_Union (gnat_parent_type)
3307 && No_Reordering (gnat_entity) == No_Reordering (gnat_parent_type))
3308 {
3309 tree gnu_parent_type
3310 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type));
3311
3312 if (TYPE_IS_PADDING_P (gnu_parent_type))
3313 gnu_parent_type = TREE_TYPE (TYPE_FIELDS (gnu_parent_type));
3314
3315 vec<subst_pair> gnu_subst_list
3316 = build_subst_list (gnat_entity, gnat_parent_type, definition);
3317
3318 /* Set the layout of the type to match that of the parent type,
3319 doing required substitutions. If we are in minimal GNAT
3320 encodings mode, we don't need debug info for the inner record
3321 types, as they will be part of the embedding variant record's
3322 debug info. */
3323 copy_and_substitute_in_layout
3324 (gnat_entity, gnat_parent_type, gnu_type, gnu_parent_type,
3325 gnu_subst_list,
3326 debug_info_p && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL);
3327 }
3328 else
3329 {
3330 /* Add the fields into the record type and finish it up. */
3331 components_to_record (Component_List (record_definition),
3332 gnat_entity, gnu_field_list, gnu_type,
3333 packed, definition, false, all_rep,
3334 is_unchecked_union, artificial_p,
3335 debug_info_p, false,
3336 all_rep ? NULL_TREE : bitsize_zero_node,
3337 NULL);
3338
3339 /* If there are entities in the chain corresponding to components
3340 that we did not elaborate, ensure we elaborate their types if
3341 they are Itypes. */
3342 for (gnat_temp = First_Entity (gnat_entity);
3343 Present (gnat_temp);
3344 gnat_temp = Next_Entity (gnat_temp))
3345 if ((Ekind (gnat_temp) == E_Component
3346 || Ekind (gnat_temp) == E_Discriminant)
3347 && Is_Itype (Etype (gnat_temp))
3348 && !present_gnu_tree (gnat_temp))
3349 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
3350 }
3351
3352 /* Fill in locations of fields. */
3353 annotate_rep (gnat_entity, gnu_type);
3354
3355 /* If this is a record type associated with an exception definition,
3356 equate its fields to those of the standard exception type. This
3357 will make it possible to convert between them. */
3358 if (gnu_entity_name == exception_data_name_id)
3359 {
3360 tree gnu_std_field;
3361 for (gnu_field = TYPE_FIELDS (gnu_type),
3362 gnu_std_field = TYPE_FIELDS (except_type_node);
3363 gnu_field;
3364 gnu_field = DECL_CHAIN (gnu_field),
3365 gnu_std_field = DECL_CHAIN (gnu_std_field))
3366 SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
3367 gcc_assert (!gnu_std_field);
3368 }
3369 }
3370 break;
3371
3372 case E_Class_Wide_Subtype:
3373 /* If an equivalent type is present, that is what we should use.
3374 Otherwise, fall through to handle this like a record subtype
3375 since it may have constraints. */
3376 if (gnat_equiv_type != gnat_entity)
3377 {
3378 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
3379 maybe_present = true;
3380 break;
3381 }
3382
3383 /* ... fall through ... */
3384
3385 case E_Record_Subtype:
3386 /* If Cloned_Subtype is Present it means this record subtype has
3387 identical layout to that type or subtype and we should use
3388 that GCC type for this one. The front-end guarantees that
3389 the component list is shared. */
3390 if (Present (Cloned_Subtype (gnat_entity)))
3391 {
3392 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
3393 NULL_TREE, false);
3394 maybe_present = true;
3395 break;
3396 }
3397
3398 /* Otherwise, first ensure the base type is elaborated. Then, if we are
3399 changing the type, make a new type with each field having the type of
3400 the field in the new subtype but the position computed by transforming
3401 every discriminant reference according to the constraints. We don't
3402 see any difference between private and non-private type here since
3403 derivations from types should have been deferred until the completion
3404 of the private type. */
3405 else
3406 {
3407 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
3408
3409 if (!definition)
3410 {
3411 defer_incomplete_level++;
3412 this_deferred = true;
3413 }
3414
3415 tree gnu_base_type
3416 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type));
3417
3418 if (present_gnu_tree (gnat_entity))
3419 {
3420 maybe_present = true;
3421 break;
3422 }
3423
3424 /* When the subtype has discriminants and these discriminants affect
3425 the initial shape it has inherited, factor them in. But for an
3426 Unchecked_Union (it must be an Itype), just return the type. */
3427 if (Has_Discriminants (gnat_entity)
3428 && Stored_Constraint (gnat_entity) != No_Elist
3429 && !Is_For_Access_Subtype (gnat_entity)
3430 && Is_Record_Type (gnat_base_type)
3431 && !Is_Unchecked_Union (gnat_base_type))
3432 {
3433 vec<subst_pair> gnu_subst_list
3434 = build_subst_list (gnat_entity, gnat_base_type, definition);
3435 tree gnu_unpad_base_type;
3436
3437 gnu_type = make_node (RECORD_TYPE);
3438 TYPE_NAME (gnu_type) = gnu_entity_name;
3439 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
3440 {
3441 /* Use the ultimate base record type as the debug type.
3442 Subtypes and derived types bring no useful
3443 information. */
3444 Entity_Id gnat_debug_type = gnat_entity;
3445 while (Etype (gnat_debug_type) != gnat_debug_type)
3446 gnat_debug_type = Etype (gnat_debug_type);
3447 tree gnu_debug_type
3448 = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_debug_type));
3449 SET_TYPE_DEBUG_TYPE (gnu_type, gnu_debug_type);
3450 }
3451 TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
3452 TYPE_REVERSE_STORAGE_ORDER (gnu_type)
3453 = Reverse_Storage_Order (gnat_entity);
3454 process_attributes (&gnu_type, &attr_list, true, gnat_entity);
3455
3456 /* Set the size, alignment and alias set of the type to match
3457 those of the base type, doing required substitutions. */
3458 copy_and_substitute_in_size (gnu_type, gnu_base_type,
3459 gnu_subst_list);
3460
3461 if (TYPE_IS_PADDING_P (gnu_base_type))
3462 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
3463 else
3464 gnu_unpad_base_type = gnu_base_type;
3465
3466 /* Set the layout of the type to match that of the base type,
3467 doing required substitutions. We will output debug info
3468 manually below so pass false as last argument. */
3469 copy_and_substitute_in_layout (gnat_entity, gnat_base_type,
3470 gnu_type, gnu_unpad_base_type,
3471 gnu_subst_list, false);
3472
3473 /* Fill in locations of fields. */
3474 annotate_rep (gnat_entity, gnu_type);
3475
3476 /* If debugging information is being written for the type and if
3477 we are asked to output such encodings, write a record that
3478 shows what we are a subtype of and also make a variable that
3479 indicates our size, if still variable. */
3480 if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
3481 {
3482 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3483 tree gnu_unpad_base_name
3484 = TYPE_IDENTIFIER (gnu_unpad_base_type);
3485 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3486
3487 TYPE_NAME (gnu_subtype_marker)
3488 = create_concat_name (gnat_entity, "XVS");
3489 finish_record_type (gnu_subtype_marker,
3490 create_field_decl (gnu_unpad_base_name,
3491 build_reference_type
3492 (gnu_unpad_base_type),
3493 gnu_subtype_marker,
3494 NULL_TREE, NULL_TREE,
3495 0, 0),
3496 0, true);
3497
3498 add_parallel_type (gnu_type, gnu_subtype_marker);
3499
3500 if (definition
3501 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3502 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3503 TYPE_SIZE_UNIT (gnu_subtype_marker)
3504 = create_var_decl (create_concat_name (gnat_entity,
3505 "XVZ"),
3506 NULL_TREE, sizetype, gnu_size_unit,
3507 false, false, false, false, false,
3508 true, debug_info_p,
3509 NULL, gnat_entity);
3510 }
3511 }
3512
3513 /* Otherwise, go down all the components in the new type and make
3514 them equivalent to those in the base type. */
3515 else
3516 {
3517 gnu_type = gnu_base_type;
3518
3519 for (gnat_temp = First_Entity (gnat_entity);
3520 Present (gnat_temp);
3521 gnat_temp = Next_Entity (gnat_temp))
3522 if ((Ekind (gnat_temp) == E_Discriminant
3523 && !Is_Unchecked_Union (gnat_base_type))
3524 || Ekind (gnat_temp) == E_Component)
3525 save_gnu_tree (gnat_temp,
3526 gnat_to_gnu_field_decl
3527 (Original_Record_Component (gnat_temp)),
3528 false);
3529 }
3530 }
3531 break;
3532
3533 case E_Access_Subprogram_Type:
3534 case E_Anonymous_Access_Subprogram_Type:
3535 /* Use the special descriptor type for dispatch tables if needed,
3536 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3537 Note that we are only required to do so for static tables in
3538 order to be compatible with the C++ ABI, but Ada 2005 allows
3539 to extend library level tagged types at the local level so
3540 we do it in the non-static case as well. */
3541 if (TARGET_VTABLE_USES_DESCRIPTORS
3542 && Is_Dispatch_Table_Entity (gnat_entity))
3543 {
3544 gnu_type = fdesc_type_node;
3545 gnu_size = TYPE_SIZE (gnu_type);
3546 break;
3547 }
3548
3549 /* ... fall through ... */
3550
3551 case E_Allocator_Type:
3552 case E_Access_Type:
3553 case E_Access_Attribute_Type:
3554 case E_Anonymous_Access_Type:
3555 case E_General_Access_Type:
3556 {
3557 /* The designated type and its equivalent type for gigi. */
3558 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3559 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3560 /* Whether it comes from a limited with. */
3561 const bool is_from_limited_with
3562 = (Is_Incomplete_Type (gnat_desig_equiv)
3563 && From_Limited_With (gnat_desig_equiv));
3564 /* Whether it is a completed Taft Amendment type. Such a type is to
3565 be treated as coming from a limited with clause if it is not in
3566 the main unit, i.e. we break potential circularities here in case
3567 the body of an external unit is loaded for inter-unit inlining. */
3568 const bool is_completed_taft_type
3569 = (Is_Incomplete_Type (gnat_desig_equiv)
3570 && Has_Completion_In_Body (gnat_desig_equiv)
3571 && Present (Full_View (gnat_desig_equiv)));
3572 /* The "full view" of the designated type. If this is an incomplete
3573 entity from a limited with, treat its non-limited view as the full
3574 view. Otherwise, if this is an incomplete or private type, use the
3575 full view. In the former case, we might point to a private type,
3576 in which case, we need its full view. Also, we want to look at the
3577 actual type used for the representation, so this takes a total of
3578 three steps. */
3579 Entity_Id gnat_desig_full_direct_first
3580 = (is_from_limited_with
3581 ? Non_Limited_View (gnat_desig_equiv)
3582 : (Is_Incomplete_Or_Private_Type (gnat_desig_equiv)
3583 ? Full_View (gnat_desig_equiv) : Empty));
3584 Entity_Id gnat_desig_full_direct
3585 = ((is_from_limited_with
3586 && Present (gnat_desig_full_direct_first)
3587 && Is_Private_Type (gnat_desig_full_direct_first))
3588 ? Full_View (gnat_desig_full_direct_first)
3589 : gnat_desig_full_direct_first);
3590 Entity_Id gnat_desig_full
3591 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3592 /* The type actually used to represent the designated type, either
3593 gnat_desig_full or gnat_desig_equiv. */
3594 Entity_Id gnat_desig_rep;
3595 /* We want to know if we'll be seeing the freeze node for any
3596 incomplete type we may be pointing to. */
3597 const bool in_main_unit
3598 = (Present (gnat_desig_full)
3599 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3600 : In_Extended_Main_Code_Unit (gnat_desig_type));
3601 /* True if we make a dummy type here. */
3602 bool made_dummy = false;
3603 /* The mode to be used for the pointer type. */
3604 scalar_int_mode p_mode;
3605 /* The GCC type used for the designated type. */
3606 tree gnu_desig_type = NULL_TREE;
3607
3608 if (!int_mode_for_size (esize, 0).exists (&p_mode)
3609 || !targetm.valid_pointer_mode (p_mode))
3610 p_mode = ptr_mode;
3611
3612 /* If either the designated type or its full view is an unconstrained
3613 array subtype, replace it with the type it's a subtype of. This
3614 avoids problems with multiple copies of unconstrained array types.
3615 Likewise, if the designated type is a subtype of an incomplete
3616 record type, use the parent type to avoid order of elaboration
3617 issues. This can lose some code efficiency, but there is no
3618 alternative. */
3619 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3620 && !Is_Constrained (gnat_desig_equiv))
3621 gnat_desig_equiv = Etype (gnat_desig_equiv);
3622 if (Present (gnat_desig_full)
3623 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3624 && !Is_Constrained (gnat_desig_full))
3625 || (Ekind (gnat_desig_full) == E_Record_Subtype
3626 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3627 gnat_desig_full = Etype (gnat_desig_full);
3628
3629 /* Set the type that's the representation of the designated type. */
3630 gnat_desig_rep
3631 = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
3632
3633 /* If we already know what the full type is, use it. */
3634 if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full))
3635 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3636
3637 /* Get the type of the thing we are to point to and build a pointer to
3638 it. If it is a reference to an incomplete or private type with a
3639 full view that is a record, an array or an access, make a dummy type
3640 and get the actual type later when we have verified it is safe. */
3641 else if ((!in_main_unit
3642 && !present_gnu_tree (gnat_desig_equiv)
3643 && Present (gnat_desig_full)
3644 && (Is_Record_Type (gnat_desig_full)
3645 || Is_Array_Type (gnat_desig_full)
3646 || Is_Access_Type (gnat_desig_full)))
3647 /* Likewise if this is a reference to a record, an array or a
3648 subprogram type and we are to defer elaborating incomplete
3649 types. We do this because this access type may be the full
3650 view of a private type. */
3651 || ((!in_main_unit || imported_p)
3652 && defer_incomplete_level != 0
3653 && !present_gnu_tree (gnat_desig_equiv)
3654 && (Is_Record_Type (gnat_desig_rep)
3655 || Is_Array_Type (gnat_desig_rep)
3656 || Ekind (gnat_desig_rep) == E_Subprogram_Type))
3657 /* If this is a reference from a limited_with type back to our
3658 main unit and there's a freeze node for it, either we have
3659 already processed the declaration and made the dummy type,
3660 in which case we just reuse the latter, or we have not yet,
3661 in which case we make the dummy type and it will be reused
3662 when the declaration is finally processed. In both cases,
3663 the pointer eventually created below will be automatically
3664 adjusted when the freeze node is processed. */
3665 || (in_main_unit
3666 && is_from_limited_with
3667 && Present (Freeze_Node (gnat_desig_rep))))
3668 {
3669 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3670 made_dummy = true;
3671 }
3672
3673 /* Otherwise handle the case of a pointer to itself. */
3674 else if (gnat_desig_equiv == gnat_entity)
3675 {
3676 gnu_type
3677 = build_pointer_type_for_mode (void_type_node, p_mode,
3678 No_Strict_Aliasing (gnat_entity));
3679 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3680 }
3681
3682 /* If expansion is disabled, the equivalent type of a concurrent type
3683 is absent, so we use the void pointer type. */
3684 else if (type_annotate_only && No (gnat_desig_equiv))
3685 gnu_type = ptr_type_node;
3686
3687 /* If the ultimately designated type is an incomplete type with no full
3688 view, we use the void pointer type in LTO mode to avoid emitting a
3689 dummy type in the GIMPLE IR. We cannot do that in regular mode as
3690 the name of the dummy type in used by GDB for a global lookup. */
3691 else if (Ekind (gnat_desig_rep) == E_Incomplete_Type
3692 && No (Full_View (gnat_desig_rep))
3693 && flag_generate_lto)
3694 gnu_type = ptr_type_node;
3695
3696 /* Finally, handle the default case where we can just elaborate our
3697 designated type. */
3698 else
3699 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3700
3701 /* It is possible that a call to gnat_to_gnu_type above resolved our
3702 type. If so, just return it. */
3703 if (present_gnu_tree (gnat_entity))
3704 {
3705 maybe_present = true;
3706 break;
3707 }
3708
3709 /* Access-to-unconstrained-array types need a special treatment. */
3710 if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
3711 {
3712 /* If the processing above got something that has a pointer, then
3713 we are done. This could have happened either because the type
3714 was elaborated or because somebody else executed the code. */
3715 if (!TYPE_POINTER_TO (gnu_desig_type))
3716 build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
3717
3718 gnu_type = TYPE_POINTER_TO (gnu_desig_type);
3719 }
3720
3721 /* If we haven't done it yet, build the pointer type the usual way. */
3722 else if (!gnu_type)
3723 {
3724 /* Modify the designated type if we are pointing only to constant
3725 objects, but don't do it for a dummy type. */
3726 if (Is_Access_Constant (gnat_entity)
3727 && !TYPE_IS_DUMMY_P (gnu_desig_type))
3728 gnu_desig_type
3729 = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
3730
3731 gnu_type
3732 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3733 No_Strict_Aliasing (gnat_entity));
3734 }
3735
3736 /* If the designated type is not declared in the main unit and we made
3737 a dummy node for it, save our definition, elaborate the actual type
3738 and replace the dummy type we made with the actual one. But if we
3739 are to defer actually looking up the actual type, make an entry in
3740 the deferred list instead. If this is from a limited with, we may
3741 have to defer until the end of the current unit. */
3742 if (!in_main_unit && made_dummy)
3743 {
3744 if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
3745 gnu_type
3746 = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
3747
3748 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
3749 gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
3750 artificial_p, debug_info_p,
3751 gnat_entity);
3752 this_made_decl = true;
3753 gnu_type = TREE_TYPE (gnu_decl);
3754 save_gnu_tree (gnat_entity, gnu_decl, false);
3755 saved = true;
3756
3757 if (defer_incomplete_level == 0
3758 && !is_from_limited_with
3759 && !is_completed_taft_type)
3760 {
3761 update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
3762 gnat_to_gnu_type (gnat_desig_equiv));
3763 }
3764 else
3765 {
3766 struct incomplete *p = XNEW (struct incomplete);
3767 struct incomplete **head
3768 = (is_from_limited_with || is_completed_taft_type
3769 ? &defer_limited_with_list : &defer_incomplete_list);
3770
3771 p->old_type = gnu_desig_type;
3772 p->full_type = gnat_desig_equiv;
3773 p->next = *head;
3774 *head = p;
3775 }
3776 }
3777 }
3778 break;
3779
3780 case E_Access_Protected_Subprogram_Type:
3781 case E_Anonymous_Access_Protected_Subprogram_Type:
3782 /* If we are just annotating types and have no equivalent record type,
3783 just use the void pointer type. */
3784 if (type_annotate_only && gnat_equiv_type == gnat_entity)
3785 gnu_type = ptr_type_node;
3786
3787 /* The run-time representation is the equivalent type. */
3788 else
3789 {
3790 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3791 maybe_present = true;
3792 }
3793
3794 /* The designated subtype must be elaborated as well, if it does
3795 not have its own freeze node. */
3796 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3797 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3798 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3799 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3800 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3801 NULL_TREE, false);
3802
3803 break;
3804
3805 case E_Access_Subtype:
3806 /* We treat this as identical to its base type; any constraint is
3807 meaningful only to the front-end. */
3808 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
3809 maybe_present = true;
3810
3811 /* The designated subtype must be elaborated as well, if it does
3812 not have its own freeze node. But designated subtypes created
3813 for constrained components of records with discriminants are
3814 not frozen by the front-end and not elaborated here, because
3815 their use may appear before the base type is frozen and it is
3816 not clear that they are needed in gigi. With the current model,
3817 there is no correct place where they could be elaborated. */
3818 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3819 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3820 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3821 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3822 {
3823 /* If we are to defer elaborating incomplete types, make a dummy
3824 type node and elaborate it later. */
3825 if (defer_incomplete_level != 0)
3826 {
3827 struct incomplete *p = XNEW (struct incomplete);
3828
3829 p->old_type
3830 = make_dummy_type (Directly_Designated_Type (gnat_entity));
3831 p->full_type = Directly_Designated_Type (gnat_entity);
3832 p->next = defer_incomplete_list;
3833 defer_incomplete_list = p;
3834 }
3835 else if (!Is_Incomplete_Or_Private_Type
3836 (Base_Type (Directly_Designated_Type (gnat_entity))))
3837 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3838 NULL_TREE, false);
3839 }
3840 break;
3841
3842 /* Subprogram Entities
3843
3844 The following access functions are defined for subprograms:
3845
3846 Etype Return type or Standard_Void_Type.
3847 First_Formal The first formal parameter.
3848 Is_Imported Indicates that the subprogram has appeared in
3849 an INTERFACE or IMPORT pragma. For now we
3850 assume that the external language is C.
3851 Is_Exported Likewise but for an EXPORT pragma.
3852 Is_Inlined True if the subprogram is to be inlined.
3853
3854 Each parameter is first checked by calling must_pass_by_ref on its
3855 type to determine if it is passed by reference. For parameters which
3856 are copied in, if they are Ada In Out or Out parameters, their return
3857 value becomes part of a record which becomes the return type of the
3858 function (C function - note that this applies only to Ada procedures
3859 so there is no Ada return type). Additional code to store back the
3860 parameters will be generated on the caller side. This transformation
3861 is done here, not in the front-end.
3862
3863 The intended result of the transformation can be seen from the
3864 equivalent source rewritings that follow:
3865
3866 struct temp {int a,b};
3867 procedure P (A,B: In Out ...) is temp P (int A,B)
3868 begin {
3869 .. ..
3870 end P; return {A,B};
3871 }
3872
3873 temp t;
3874 P(X,Y); t = P(X,Y);
3875 X = t.a , Y = t.b;
3876
3877 For subprogram types we need to perform mainly the same conversions to
3878 GCC form that are needed for procedures and function declarations. The
3879 only difference is that at the end, we make a type declaration instead
3880 of a function declaration. */
3881
3882 case E_Subprogram_Type:
3883 case E_Function:
3884 case E_Procedure:
3885 {
3886 tree gnu_ext_name
3887 = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name);
3888 enum inline_status_t inline_status
3889 = Has_Pragma_No_Inline (gnat_entity)
3890 ? is_suppressed
3891 : Has_Pragma_Inline_Always (gnat_entity)
3892 ? is_required
3893 : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled);
3894 bool public_flag = Is_Public (gnat_entity) || imported_p;
3895 /* Subprograms marked both Intrinsic and Always_Inline need not
3896 have a body of their own. */
3897 bool extern_flag
3898 = ((Is_Public (gnat_entity) && !definition)
3899 || imported_p
3900 || (Convention (gnat_entity) == Convention_Intrinsic
3901 && Has_Pragma_Inline_Always (gnat_entity)));
3902 tree gnu_param_list;
3903
3904 /* A parameter may refer to this type, so defer completion of any
3905 incomplete types. */
3906 if (kind == E_Subprogram_Type && !definition)
3907 {
3908 defer_incomplete_level++;
3909 this_deferred = true;
3910 }
3911
3912 /* If the subprogram has an alias, it is probably inherited, so
3913 we can use the original one. If the original "subprogram"
3914 is actually an enumeration literal, it may be the first use
3915 of its type, so we must elaborate that type now. */
3916 if (Present (Alias (gnat_entity)))
3917 {
3918 const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
3919
3920 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3921 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
3922 false);
3923
3924 gnu_decl
3925 = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
3926
3927 /* Elaborate any Itypes in the parameters of this entity. */
3928 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3929 Present (gnat_temp);
3930 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3931 if (Is_Itype (Etype (gnat_temp)))
3932 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
3933
3934 /* Materialize renamed subprograms in the debugging information
3935 when the renamed object is compile time known. We can consider
3936 such renamings as imported declarations.
3937
3938 Because the parameters in generics instantiation are generally
3939 materialized as renamings, we ofter end up having both the
3940 renamed subprogram and the renaming in the same context and with
3941 the same name: in this case, renaming is both useless debug-wise
3942 and potentially harmful as name resolution in the debugger could
3943 return twice the same entity! So avoid this case. */
3944 if (debug_info_p && !artificial_p
3945 && !(get_debug_scope (gnat_entity, NULL)
3946 == get_debug_scope (gnat_renamed, NULL)
3947 && Name_Equals (Chars (gnat_entity),
3948 Chars (gnat_renamed)))
3949 && Present (gnat_renamed)
3950 && (Ekind (gnat_renamed) == E_Function
3951 || Ekind (gnat_renamed) == E_Procedure)
3952 && gnu_decl
3953 && TREE_CODE (gnu_decl) == FUNCTION_DECL)
3954 {
3955 tree decl = build_decl (input_location, IMPORTED_DECL,
3956 gnu_entity_name, void_type_node);
3957 IMPORTED_DECL_ASSOCIATED_DECL (decl) = gnu_decl;
3958 gnat_pushdecl (decl, gnat_entity);
3959 }
3960
3961 break;
3962 }
3963
3964 /* Get the GCC tree for the (underlying) subprogram type. If the
3965 entity is an actual subprogram, also get the parameter list. */
3966 gnu_type
3967 = gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
3968 &gnu_param_list);
3969 if (DECL_P (gnu_type))
3970 {
3971 gnu_decl = gnu_type;
3972 gnu_type = TREE_TYPE (gnu_decl);
3973 break;
3974 }
3975
3976 /* Deal with platform-specific calling conventions. */
3977 if (Has_Stdcall_Convention (gnat_entity))
3978 prepend_one_attribute
3979 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3980 get_identifier ("stdcall"), NULL_TREE,
3981 gnat_entity);
3982 else if (Has_Thiscall_Convention (gnat_entity))
3983 prepend_one_attribute
3984 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3985 get_identifier ("thiscall"), NULL_TREE,
3986 gnat_entity);
3987
3988 /* If we should request stack realignment for a foreign convention
3989 subprogram, do so. Note that this applies to task entry points
3990 in particular. */
3991 if (FOREIGN_FORCE_REALIGN_STACK
3992 && Has_Foreign_Convention (gnat_entity))
3993 prepend_one_attribute
3994 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3995 get_identifier ("force_align_arg_pointer"), NULL_TREE,
3996 gnat_entity);
3997
3998 /* Deal with a pragma Linker_Section on a subprogram. */
3999 if ((kind == E_Function || kind == E_Procedure)
4000 && Present (Linker_Section_Pragma (gnat_entity)))
4001 prepend_one_attribute_pragma (&attr_list,
4002 Linker_Section_Pragma (gnat_entity));
4003
4004 /* If we are defining the subprogram and it has an Address clause
4005 we must get the address expression from the saved GCC tree for the
4006 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4007 the address expression here since the front-end has guaranteed
4008 in that case that the elaboration has no effects. If there is
4009 an Address clause and we are not defining the object, just
4010 make it a constant. */
4011 if (Present (Address_Clause (gnat_entity)))
4012 {
4013 tree gnu_address = NULL_TREE;
4014
4015 if (definition)
4016 gnu_address
4017 = (present_gnu_tree (gnat_entity)
4018 ? get_gnu_tree (gnat_entity)
4019 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4020
4021 save_gnu_tree (gnat_entity, NULL_TREE, false);
4022
4023 /* Convert the type of the object to a reference type that can
4024 alias everything as per RM 13.3(19). */
4025 gnu_type
4026 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4027 if (gnu_address)
4028 gnu_address = convert (gnu_type, gnu_address);
4029
4030 gnu_decl
4031 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4032 gnu_address, false, Is_Public (gnat_entity),
4033 extern_flag, false, false, artificial_p,
4034 debug_info_p, NULL, gnat_entity);
4035 DECL_BY_REF_P (gnu_decl) = 1;
4036 }
4037
4038 /* If this is a mere subprogram type, just create the declaration. */
4039 else if (kind == E_Subprogram_Type)
4040 {
4041 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4042
4043 gnu_decl
4044 = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4045 debug_info_p, gnat_entity);
4046 }
4047
4048 /* Otherwise create the subprogram declaration with the external name,
4049 the type and the parameter list. However, if this a reference to
4050 the allocation routines, reuse the canonical declaration nodes as
4051 they come with special properties. */
4052 else
4053 {
4054 if (extern_flag && gnu_ext_name == DECL_NAME (malloc_decl))
4055 gnu_decl = malloc_decl;
4056 else if (extern_flag && gnu_ext_name == DECL_NAME (realloc_decl))
4057 gnu_decl = realloc_decl;
4058 else
4059 {
4060 gnu_decl
4061 = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4062 gnu_type, gnu_param_list,
4063 inline_status, public_flag,
4064 extern_flag, artificial_p,
4065 debug_info_p,
4066 definition && imported_p, attr_list,
4067 gnat_entity);
4068
4069 DECL_STUBBED_P (gnu_decl)
4070 = (Convention (gnat_entity) == Convention_Stubbed);
4071 }
4072 }
4073 }
4074 break;
4075
4076 case E_Incomplete_Type:
4077 case E_Incomplete_Subtype:
4078 case E_Private_Type:
4079 case E_Private_Subtype:
4080 case E_Limited_Private_Type:
4081 case E_Limited_Private_Subtype:
4082 case E_Record_Type_With_Private:
4083 case E_Record_Subtype_With_Private:
4084 {
4085 const bool is_from_limited_with
4086 = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
4087 /* Get the "full view" of this entity. If this is an incomplete
4088 entity from a limited with, treat its non-limited view as the
4089 full view. Otherwise, use either the full view or the underlying
4090 full view, whichever is present. This is used in all the tests
4091 below. */
4092 const Entity_Id full_view
4093 = is_from_limited_with
4094 ? Non_Limited_View (gnat_entity)
4095 : Present (Full_View (gnat_entity))
4096 ? Full_View (gnat_entity)
4097 : IN (kind, Private_Kind)
4098 ? Underlying_Full_View (gnat_entity)
4099 : Empty;
4100
4101 /* If this is an incomplete type with no full view, it must be a Taft
4102 Amendment type or an incomplete type coming from a limited context,
4103 in which cases we return a dummy type. Otherwise, we just get the
4104 type from its Etype. */
4105 if (No (full_view))
4106 {
4107 if (kind == E_Incomplete_Type)
4108 {
4109 gnu_type = make_dummy_type (gnat_entity);
4110 gnu_decl = TYPE_STUB_DECL (gnu_type);
4111 }
4112 else
4113 {
4114 gnu_decl
4115 = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
4116 maybe_present = true;
4117 }
4118 }
4119
4120 /* Or else, if we already made a type for the full view, reuse it. */
4121 else if (present_gnu_tree (full_view))
4122 gnu_decl = get_gnu_tree (full_view);
4123
4124 /* Or else, if we are not defining the type or there is no freeze
4125 node on it, get the type for the full view. Likewise if this is
4126 a limited_with'ed type not declared in the main unit, which can
4127 happen for incomplete formal types instantiated on a type coming
4128 from a limited_with clause. */
4129 else if (!definition
4130 || No (Freeze_Node (full_view))
4131 || (is_from_limited_with
4132 && !In_Extended_Main_Code_Unit (full_view)))
4133 {
4134 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
4135 maybe_present = true;
4136 }
4137
4138 /* Otherwise, make a dummy type entry which will be replaced later.
4139 Save it as the full declaration's type so we can do any needed
4140 updates when we see it. */
4141 else
4142 {
4143 gnu_type = make_dummy_type (gnat_entity);
4144 gnu_decl = TYPE_STUB_DECL (gnu_type);
4145 if (Has_Completion_In_Body (gnat_entity))
4146 DECL_TAFT_TYPE_P (gnu_decl) = 1;
4147 save_gnu_tree (full_view, gnu_decl, false);
4148 }
4149 }
4150 break;
4151
4152 case E_Class_Wide_Type:
4153 /* Class-wide types are always transformed into their root type. */
4154 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4155 maybe_present = true;
4156 break;
4157
4158 case E_Protected_Type:
4159 case E_Protected_Subtype:
4160 case E_Task_Type:
4161 case E_Task_Subtype:
4162 /* If we are just annotating types and have no equivalent record type,
4163 just return void_type, except for root types that have discriminants
4164 because the discriminants will very likely be used in the declarative
4165 part of the associated body so they need to be translated. */
4166 if (type_annotate_only && gnat_equiv_type == gnat_entity)
4167 {
4168 if (Has_Discriminants (gnat_entity)
4169 && Root_Type (gnat_entity) == gnat_entity)
4170 {
4171 tree gnu_field_list = NULL_TREE;
4172 Entity_Id gnat_field;
4173
4174 /* This is a minimal version of the E_Record_Type handling. */
4175 gnu_type = make_node (RECORD_TYPE);
4176 TYPE_NAME (gnu_type) = gnu_entity_name;
4177
4178 for (gnat_field = First_Stored_Discriminant (gnat_entity);
4179 Present (gnat_field);
4180 gnat_field = Next_Stored_Discriminant (gnat_field))
4181 {
4182 tree gnu_field
4183 = gnat_to_gnu_field (gnat_field, gnu_type, false,
4184 definition, debug_info_p);
4185
4186 save_gnu_tree (gnat_field,
4187 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
4188 build0 (PLACEHOLDER_EXPR, gnu_type),
4189 gnu_field, NULL_TREE),
4190 true);
4191
4192 DECL_CHAIN (gnu_field) = gnu_field_list;
4193 gnu_field_list = gnu_field;
4194 }
4195
4196 finish_record_type (gnu_type, nreverse (gnu_field_list), 0,
4197 false);
4198 }
4199 else
4200 gnu_type = void_type_node;
4201 }
4202
4203 /* Concurrent types are always transformed into their record type. */
4204 else
4205 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
4206 maybe_present = true;
4207 break;
4208
4209 case E_Label:
4210 gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
4211 break;
4212
4213 case E_Block:
4214 case E_Loop:
4215 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4216 we've already saved it, so we don't try to. */
4217 gnu_decl = error_mark_node;
4218 saved = true;
4219 break;
4220
4221 case E_Abstract_State:
4222 /* This is a SPARK annotation that only reaches here when compiling in
4223 ASIS mode. */
4224 gcc_assert (type_annotate_only);
4225 gnu_decl = error_mark_node;
4226 saved = true;
4227 break;
4228
4229 default:
4230 gcc_unreachable ();
4231 }
4232
4233 /* If we had a case where we evaluated another type and it might have
4234 defined this one, handle it here. */
4235 if (maybe_present && present_gnu_tree (gnat_entity))
4236 {
4237 gnu_decl = get_gnu_tree (gnat_entity);
4238 saved = true;
4239 }
4240
4241 /* If we are processing a type and there is either no decl for it or
4242 we just made one, do some common processing for the type, such as
4243 handling alignment and possible padding. */
4244 if (is_type && (!gnu_decl || this_made_decl))
4245 {
4246 gcc_assert (!TYPE_IS_DUMMY_P (gnu_type));
4247
4248 /* Process the attributes, if not already done. Note that the type is
4249 already defined so we cannot pass true for IN_PLACE here. */
4250 process_attributes (&gnu_type, &attr_list, false, gnat_entity);
4251
4252 /* ??? Don't set the size for a String_Literal since it is either
4253 confirming or we don't handle it properly (if the low bound is
4254 non-constant). */
4255 if (!gnu_size && kind != E_String_Literal_Subtype)
4256 {
4257 Uint gnat_size = Known_Esize (gnat_entity)
4258 ? Esize (gnat_entity) : RM_Size (gnat_entity);
4259 gnu_size
4260 = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
4261 false, Has_Size_Clause (gnat_entity));
4262 }
4263
4264 /* If a size was specified, see if we can make a new type of that size
4265 by rearranging the type, for example from a fat to a thin pointer. */
4266 if (gnu_size)
4267 {
4268 gnu_type
4269 = make_type_from_size (gnu_type, gnu_size,
4270 Has_Biased_Representation (gnat_entity));
4271
4272 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4273 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4274 gnu_size = NULL_TREE;
4275 }
4276
4277 /* If the alignment has not already been processed and this is not
4278 an unconstrained array type, see if an alignment is specified.
4279 If not, we pick a default alignment for atomic objects. */
4280 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4281 ;
4282 else if (Known_Alignment (gnat_entity))
4283 {
4284 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4285 TYPE_ALIGN (gnu_type));
4286
4287 /* Warn on suspiciously large alignments. This should catch
4288 errors about the (alignment,byte)/(size,bit) discrepancy. */
4289 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4290 {
4291 tree size;
4292
4293 /* If a size was specified, take it into account. Otherwise
4294 use the RM size for records or unions as the type size has
4295 already been adjusted to the alignment. */
4296 if (gnu_size)
4297 size = gnu_size;
4298 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
4299 && !TYPE_FAT_POINTER_P (gnu_type))
4300 size = rm_size (gnu_type);
4301 else
4302 size = TYPE_SIZE (gnu_type);
4303
4304 /* Consider an alignment as suspicious if the alignment/size
4305 ratio is greater or equal to the byte/bit ratio. */
4306 if (tree_fits_uhwi_p (size)
4307 && align >= tree_to_uhwi (size) * BITS_PER_UNIT)
4308 post_error_ne ("?suspiciously large alignment specified for&",
4309 Expression (Alignment_Clause (gnat_entity)),
4310 gnat_entity);
4311 }
4312 }
4313 else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size
4314 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
4315 && integer_pow2p (TYPE_SIZE (gnu_type)))
4316 align = MIN (BIGGEST_ALIGNMENT,
4317 tree_to_uhwi (TYPE_SIZE (gnu_type)));
4318 else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size
4319 && tree_fits_uhwi_p (gnu_size)
4320 && integer_pow2p (gnu_size))
4321 align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
4322
4323 /* See if we need to pad the type. If we did, and made a record,
4324 the name of the new type may be changed. So get it back for
4325 us when we make the new TYPE_DECL below. */
4326 if (gnu_size || align > 0)
4327 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4328 false, !gnu_decl, definition, false);
4329
4330 if (TYPE_IS_PADDING_P (gnu_type))
4331 gnu_entity_name = TYPE_IDENTIFIER (gnu_type);
4332
4333 /* Now set the RM size of the type. We cannot do it before padding
4334 because we need to accept arbitrary RM sizes on integral types. */
4335 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4336
4337 /* If we are at global level, GCC will have applied variable_size to
4338 the type, but that won't have done anything. So, if it's not
4339 a constant or self-referential, call elaborate_expression_1 to
4340 make a variable for the size rather than calculating it each time.
4341 Handle both the RM size and the actual size. */
4342 if (TYPE_SIZE (gnu_type)
4343 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4344 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
4345 && global_bindings_p ())
4346 {
4347 tree size = TYPE_SIZE (gnu_type);
4348
4349 TYPE_SIZE (gnu_type)
4350 = elaborate_expression_1 (size, gnat_entity, "SIZE", definition,
4351 false);
4352
4353 /* ??? For now, store the size as a multiple of the alignment in
4354 bytes so that we can see the alignment from the tree. */
4355 TYPE_SIZE_UNIT (gnu_type)
4356 = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity,
4357 "SIZE_A_UNIT", definition, false,
4358 TYPE_ALIGN (gnu_type));
4359
4360 /* ??? gnu_type may come from an existing type so the MULT_EXPR node
4361 may not be marked by the call to create_type_decl below. */
4362 MARK_VISITED (TYPE_SIZE_UNIT (gnu_type));
4363
4364 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4365 {
4366 tree variant_part = get_variant_part (gnu_type);
4367 tree ada_size = TYPE_ADA_SIZE (gnu_type);
4368
4369 if (variant_part)
4370 {
4371 tree union_type = TREE_TYPE (variant_part);
4372 tree offset = DECL_FIELD_OFFSET (variant_part);
4373
4374 /* If the position of the variant part is constant, subtract
4375 it from the size of the type of the parent to get the new
4376 size. This manual CSE reduces the data size. */
4377 if (TREE_CODE (offset) == INTEGER_CST)
4378 {
4379 tree bitpos = DECL_FIELD_BIT_OFFSET (variant_part);
4380 TYPE_SIZE (union_type)
4381 = size_binop (MINUS_EXPR, TYPE_SIZE (gnu_type),
4382 bit_from_pos (offset, bitpos));
4383 TYPE_SIZE_UNIT (union_type)
4384 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (gnu_type),
4385 byte_from_pos (offset, bitpos));
4386 }
4387 else
4388 {
4389 TYPE_SIZE (union_type)
4390 = elaborate_expression_1 (TYPE_SIZE (union_type),
4391 gnat_entity, "VSIZE",
4392 definition, false);
4393
4394 /* ??? For now, store the size as a multiple of the
4395 alignment in bytes so that we can see the alignment
4396 from the tree. */
4397 TYPE_SIZE_UNIT (union_type)
4398 = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type),
4399 gnat_entity, "VSIZE_A_UNIT",
4400 definition, false,
4401 TYPE_ALIGN (union_type));
4402
4403 /* ??? For now, store the offset as a multiple of the
4404 alignment in bytes so that we can see the alignment
4405 from the tree. */
4406 DECL_FIELD_OFFSET (variant_part)
4407 = elaborate_expression_2 (offset, gnat_entity,
4408 "VOFFSET", definition, false,
4409 DECL_OFFSET_ALIGN
4410 (variant_part));
4411 }
4412
4413 DECL_SIZE (variant_part) = TYPE_SIZE (union_type);
4414 DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type);
4415 }
4416
4417 if (operand_equal_p (ada_size, size, 0))
4418 ada_size = TYPE_SIZE (gnu_type);
4419 else
4420 ada_size
4421 = elaborate_expression_1 (ada_size, gnat_entity, "RM_SIZE",
4422 definition, false);
4423 SET_TYPE_ADA_SIZE (gnu_type, ada_size);
4424 }
4425 }
4426
4427 /* Similarly, if this is a record type or subtype at global level, call
4428 elaborate_expression_2 on any field position. Skip any fields that
4429 we haven't made trees for to avoid problems with class-wide types. */
4430 if (IN (kind, Record_Kind) && global_bindings_p ())
4431 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4432 gnat_temp = Next_Entity (gnat_temp))
4433 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4434 {
4435 tree gnu_field = get_gnu_tree (gnat_temp);
4436
4437 /* ??? For now, store the offset as a multiple of the alignment
4438 in bytes so that we can see the alignment from the tree. */
4439 if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field))
4440 && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4441 {
4442 DECL_FIELD_OFFSET (gnu_field)
4443 = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
4444 gnat_temp, "OFFSET", definition,
4445 false,
4446 DECL_OFFSET_ALIGN (gnu_field));
4447
4448 /* ??? The context of gnu_field is not necessarily gnu_type
4449 so the MULT_EXPR node built above may not be marked by
4450 the call to create_type_decl below. */
4451 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4452 }
4453 }
4454
4455 if (Is_Atomic_Or_VFA (gnat_entity))
4456 check_ok_for_atomic_type (gnu_type, gnat_entity, false);
4457
4458 /* If this is not an unconstrained array type, set some flags. */
4459 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
4460 {
4461 /* Record the property that objects of tagged types are guaranteed to
4462 be properly aligned. This is necessary because conversions to the
4463 class-wide type are translated into conversions to the root type,
4464 which can be less aligned than some of its derived types. */
4465 if (Is_Tagged_Type (gnat_entity)
4466 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4467 TYPE_ALIGN_OK (gnu_type) = 1;
4468
4469 /* Record whether the type is passed by reference. */
4470 if (Is_By_Reference_Type (gnat_entity) && !VOID_TYPE_P (gnu_type))
4471 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4472
4473 /* Record whether an alignment clause was specified. */
4474 if (Present (Alignment_Clause (gnat_entity)))
4475 TYPE_USER_ALIGN (gnu_type) = 1;
4476
4477 /* Record whether a pragma Universal_Aliasing was specified. */
4478 if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
4479 TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
4480
4481 /* If it is passed by reference, force BLKmode to ensure that
4482 objects of this type will always be put in memory. */
4483 if (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
4484 SET_TYPE_MODE (gnu_type, BLKmode);
4485 }
4486
4487 /* If this is a derived type, relate its alias set to that of its parent
4488 to avoid troubles when a call to an inherited primitive is inlined in
4489 a context where a derived object is accessed. The inlined code works
4490 on the parent view so the resulting code may access the same object
4491 using both the parent and the derived alias sets, which thus have to
4492 conflict. As the same issue arises with component references, the
4493 parent alias set also has to conflict with composite types enclosing
4494 derived components. For instance, if we have:
4495
4496 type D is new T;
4497 type R is record
4498 Component : D;
4499 end record;
4500
4501 we want T to conflict with both D and R, in addition to R being a
4502 superset of D by record/component construction.
4503
4504 One way to achieve this is to perform an alias set copy from the
4505 parent to the derived type. This is not quite appropriate, though,
4506 as we don't want separate derived types to conflict with each other:
4507
4508 type I1 is new Integer;
4509 type I2 is new Integer;
4510
4511 We want I1 and I2 to both conflict with Integer but we do not want
4512 I1 to conflict with I2, and an alias set copy on derivation would
4513 have that effect.
4514
4515 The option chosen is to make the alias set of the derived type a
4516 superset of that of its parent type. It trivially fulfills the
4517 simple requirement for the Integer derivation example above, and
4518 the component case as well by superset transitivity:
4519
4520 superset superset
4521 R ----------> D ----------> T
4522
4523 However, for composite types, conversions between derived types are
4524 translated into VIEW_CONVERT_EXPRs so a sequence like:
4525
4526 type Comp1 is new Comp;
4527 type Comp2 is new Comp;
4528 procedure Proc (C : Comp1);
4529
4530 C : Comp2;
4531 Proc (Comp1 (C));
4532
4533 is translated into:
4534
4535 C : Comp2;
4536 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4537
4538 and gimplified into:
4539
4540 C : Comp2;
4541 Comp1 *C.0;
4542 C.0 = (Comp1 *) &C;
4543 Proc (C.0);
4544
4545 i.e. generates code involving type punning. Therefore, Comp1 needs
4546 to conflict with Comp2 and an alias set copy is required.
4547
4548 The language rules ensure the parent type is already frozen here. */
4549 if (kind != E_Subprogram_Type
4550 && Is_Derived_Type (gnat_entity)
4551 && !type_annotate_only)
4552 {
4553 Entity_Id gnat_parent_type = Underlying_Type (Etype (gnat_entity));
4554 /* For constrained packed array subtypes, the implementation type is
4555 used instead of the nominal type. */
4556 if (kind == E_Array_Subtype
4557 && Is_Constrained (gnat_entity)
4558 && Present (Packed_Array_Impl_Type (gnat_parent_type)))
4559 gnat_parent_type = Packed_Array_Impl_Type (gnat_parent_type);
4560 relate_alias_sets (gnu_type, gnat_to_gnu_type (gnat_parent_type),
4561 Is_Composite_Type (gnat_entity)
4562 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4563 }
4564
4565 /* Finally get to the appropriate variant, except for the implementation
4566 type of a packed array because the GNU type might be further adjusted
4567 when the original array type is itself processed. */
4568 if (Treat_As_Volatile (gnat_entity)
4569 && !Is_Packed_Array_Impl_Type (gnat_entity))
4570 {
4571 const int quals
4572 = TYPE_QUAL_VOLATILE
4573 | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
4574 gnu_type = change_qualified_type (gnu_type, quals);
4575 }
4576
4577 /* If we already made a decl, just set the type, otherwise create it. */
4578 if (gnu_decl)
4579 {
4580 TREE_TYPE (gnu_decl) = gnu_type;
4581 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4582 }
4583 else
4584 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
4585 debug_info_p, gnat_entity);
4586 }
4587
4588 /* If we got a type that is not dummy, back-annotate the alignment of the
4589 type if not already in the tree. Likewise for the size, if any. */
4590 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4591 {
4592 gnu_type = TREE_TYPE (gnu_decl);
4593
4594 if (Unknown_Alignment (gnat_entity))
4595 {
4596 unsigned int double_align, align;
4597 bool is_capped_double, align_clause;
4598
4599 /* If the default alignment of "double" or larger scalar types is
4600 specifically capped and this is not an array with an alignment
4601 clause on the component type, return the cap. */
4602 if ((double_align = double_float_alignment) > 0)
4603 is_capped_double
4604 = is_double_float_or_array (gnat_entity, &align_clause);
4605 else if ((double_align = double_scalar_alignment) > 0)
4606 is_capped_double
4607 = is_double_scalar_or_array (gnat_entity, &align_clause);
4608 else
4609 is_capped_double = align_clause = false;
4610
4611 if (is_capped_double && !align_clause)
4612 align = double_align;
4613 else
4614 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4615
4616 Set_Alignment (gnat_entity, UI_From_Int (align));
4617 }
4618
4619 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4620 {
4621 tree gnu_size = TYPE_SIZE (gnu_type);
4622
4623 /* If the size is self-referential, annotate the maximum value. */
4624 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4625 gnu_size = max_size (gnu_size, true);
4626
4627 /* If we are just annotating types and the type is tagged, the tag
4628 and the parent components are not generated by the front-end so
4629 alignment and sizes must be adjusted if there is no rep clause. */
4630 if (type_annotate_only
4631 && Is_Tagged_Type (gnat_entity)
4632 && Unknown_RM_Size (gnat_entity)
4633 && !VOID_TYPE_P (gnu_type)
4634 && (!TYPE_FIELDS (gnu_type)
4635 || integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
4636 {
4637 tree offset;
4638
4639 if (Is_Derived_Type (gnat_entity))
4640 {
4641 Entity_Id gnat_parent = Etype (Base_Type (gnat_entity));
4642 offset = UI_To_gnu (Esize (gnat_parent), bitsizetype);
4643 Set_Alignment (gnat_entity, Alignment (gnat_parent));
4644 }
4645 else
4646 {
4647 unsigned int align
4648 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
4649 offset = bitsize_int (POINTER_SIZE);
4650 Set_Alignment (gnat_entity, UI_From_Int (align));
4651 }
4652
4653 if (TYPE_FIELDS (gnu_type))
4654 offset
4655 = round_up (offset, DECL_ALIGN (TYPE_FIELDS (gnu_type)));
4656
4657 gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
4658 gnu_size = round_up (gnu_size, POINTER_SIZE);
4659 Uint uint_size = annotate_value (gnu_size);
4660 Set_RM_Size (gnat_entity, uint_size);
4661 Set_Esize (gnat_entity, uint_size);
4662 }
4663
4664 /* If there is a rep clause, only adjust alignment and Esize. */
4665 else if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4666 {
4667 unsigned int align
4668 = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
4669 Set_Alignment (gnat_entity, UI_From_Int (align));
4670 gnu_size = round_up (gnu_size, POINTER_SIZE);
4671 Set_Esize (gnat_entity, annotate_value (gnu_size));
4672 }
4673
4674 /* Otherwise no adjustment is needed. */
4675 else
4676 Set_Esize (gnat_entity, annotate_value (gnu_size));
4677 }
4678
4679 if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
4680 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4681 }
4682
4683 /* If we haven't already, associate the ..._DECL node that we just made with
4684 the input GNAT entity node. */
4685 if (!saved)
4686 save_gnu_tree (gnat_entity, gnu_decl, false);
4687
4688 /* Now we are sure gnat_entity has a corresponding ..._DECL node,
4689 eliminate as many deferred computations as possible. */
4690 process_deferred_decl_context (false);
4691
4692 /* If this is an enumeration or floating-point type, we were not able to set
4693 the bounds since they refer to the type. These are always static. */
4694 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4695 || (kind == E_Floating_Point_Type))
4696 {
4697 tree gnu_scalar_type = gnu_type;
4698 tree gnu_low_bound, gnu_high_bound;
4699
4700 /* If this is a padded type, we need to use the underlying type. */
4701 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4702 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4703
4704 /* If this is a floating point type and we haven't set a floating
4705 point type yet, use this in the evaluation of the bounds. */
4706 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4707 longest_float_type_node = gnu_scalar_type;
4708
4709 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4710 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4711
4712 if (kind == E_Enumeration_Type)
4713 {
4714 /* Enumeration types have specific RM bounds. */
4715 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4716 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4717 }
4718 else
4719 {
4720 /* Floating-point types don't have specific RM bounds. */
4721 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4722 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4723 }
4724 }
4725
4726 /* If we deferred processing of incomplete types, re-enable it. If there
4727 were no other disables and we have deferred types to process, do so. */
4728 if (this_deferred
4729 && --defer_incomplete_level == 0
4730 && defer_incomplete_list)
4731 {
4732 struct incomplete *p, *next;
4733
4734 /* We are back to level 0 for the deferring of incomplete types.
4735 But processing these incomplete types below may itself require
4736 deferring, so preserve what we have and restart from scratch. */
4737 p = defer_incomplete_list;
4738 defer_incomplete_list = NULL;
4739
4740 for (; p; p = next)
4741 {
4742 next = p->next;
4743
4744 if (p->old_type)
4745 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4746 gnat_to_gnu_type (p->full_type));
4747 free (p);
4748 }
4749 }
4750
4751 /* If we are not defining this type, see if it's on one of the lists of
4752 incomplete types. If so, handle the list entry now. */
4753 if (is_type && !definition)
4754 {
4755 struct incomplete *p;
4756
4757 for (p = defer_incomplete_list; p; p = p->next)
4758 if (p->old_type && p->full_type == gnat_entity)
4759 {
4760 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4761 TREE_TYPE (gnu_decl));
4762 p->old_type = NULL_TREE;
4763 }
4764
4765 for (p = defer_limited_with_list; p; p = p->next)
4766 if (p->old_type
4767 && (Non_Limited_View (p->full_type) == gnat_entity
4768 || Full_View (p->full_type) == gnat_entity))
4769 {
4770 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4771 TREE_TYPE (gnu_decl));
4772 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
4773 update_profiles_with (p->old_type);
4774 p->old_type = NULL_TREE;
4775 }
4776 }
4777
4778 if (this_global)
4779 force_global--;
4780
4781 /* If this is a packed array type whose original array type is itself
4782 an Itype without freeze node, make sure the latter is processed. */
4783 if (Is_Packed_Array_Impl_Type (gnat_entity)
4784 && Is_Itype (Original_Array_Type (gnat_entity))
4785 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4786 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4787 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, false);
4788
4789 return gnu_decl;
4790 }
4791
4792 /* Similar, but if the returned value is a COMPONENT_REF, return the
4793 FIELD_DECL. */
4794
4795 tree
gnat_to_gnu_field_decl(Entity_Id gnat_entity)4796 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4797 {
4798 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
4799
4800 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4801 gnu_field = TREE_OPERAND (gnu_field, 1);
4802
4803 return gnu_field;
4804 }
4805
4806 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4807 the GCC type corresponding to that entity. */
4808
4809 tree
gnat_to_gnu_type(Entity_Id gnat_entity)4810 gnat_to_gnu_type (Entity_Id gnat_entity)
4811 {
4812 tree gnu_decl;
4813
4814 /* The back end never attempts to annotate generic types. */
4815 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4816 return void_type_node;
4817
4818 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
4819 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4820
4821 return TREE_TYPE (gnu_decl);
4822 }
4823
4824 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4825 the unpadded version of the GCC type corresponding to that entity. */
4826
4827 tree
get_unpadded_type(Entity_Id gnat_entity)4828 get_unpadded_type (Entity_Id gnat_entity)
4829 {
4830 tree type = gnat_to_gnu_type (gnat_entity);
4831
4832 if (TYPE_IS_PADDING_P (type))
4833 type = TREE_TYPE (TYPE_FIELDS (type));
4834
4835 return type;
4836 }
4837
4838 /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
4839 a C++ imported method or equivalent.
4840
4841 We use the predicate on 32-bit x86/Windows to find out whether we need to
4842 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
4843 used for C++ methods (functions with METHOD_TYPE) by the back-end. */
4844
4845 bool
is_cplusplus_method(Entity_Id gnat_entity)4846 is_cplusplus_method (Entity_Id gnat_entity)
4847 {
4848 /* A constructor is a method on the C++ side. We deal with it now because
4849 it is declared without the 'this' parameter in the sources and, although
4850 the front-end will create a version with the 'this' parameter for code
4851 generation purposes, we want to return true for both versions. */
4852 if (Is_Constructor (gnat_entity))
4853 return true;
4854
4855 /* Check that the subprogram has C++ convention. */
4856 if (Convention (gnat_entity) != Convention_CPP)
4857 return false;
4858
4859 /* And that the type of the first parameter (indirectly) has it too. */
4860 Entity_Id gnat_first = First_Formal (gnat_entity);
4861 if (No (gnat_first))
4862 return false;
4863
4864 Entity_Id gnat_type = Etype (gnat_first);
4865 if (Is_Access_Type (gnat_type))
4866 gnat_type = Directly_Designated_Type (gnat_type);
4867 if (Convention (gnat_type) != Convention_CPP)
4868 return false;
4869
4870 /* This is the main case: a C++ virtual method imported as a primitive
4871 operation of a tagged type. */
4872 if (Is_Dispatching_Operation (gnat_entity))
4873 return true;
4874
4875 /* This is set on the E_Subprogram_Type built for a dispatching call. */
4876 if (Is_Dispatch_Table_Entity (gnat_entity))
4877 return true;
4878
4879 /* A thunk needs to be handled like its associated primitive operation. */
4880 if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
4881 return true;
4882
4883 /* Now on to the annoying case: a C++ non-virtual method, imported either
4884 as a non-primitive operation of a tagged type or as a primitive operation
4885 of an untagged type. We cannot reliably differentiate these cases from
4886 their static member or regular function equivalents in Ada, so we ask
4887 the C++ side through the mangled name of the function, as the implicit
4888 'this' parameter is not encoded in the mangled name of a method. */
4889 if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
4890 {
4891 String_Pointer sp = { NULL, NULL };
4892 Get_External_Name (gnat_entity, false, sp);
4893
4894 void *mem;
4895 struct demangle_component *cmp
4896 = cplus_demangle_v3_components (Name_Buffer,
4897 DMGL_GNU_V3
4898 | DMGL_TYPES
4899 | DMGL_PARAMS
4900 | DMGL_RET_DROP,
4901 &mem);
4902 if (!cmp)
4903 return false;
4904
4905 /* We need to release MEM once we have a successful demangling. */
4906 bool ret = false;
4907
4908 if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
4909 && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
4910 && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
4911 && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
4912 {
4913 /* Make sure there is at least one parameter in C++ too. */
4914 if (cmp->u.s_binary.left)
4915 {
4916 unsigned int n_ada_args = 0;
4917 do {
4918 n_ada_args++;
4919 gnat_first = Next_Formal (gnat_first);
4920 } while (Present (gnat_first));
4921
4922 unsigned int n_cpp_args = 0;
4923 do {
4924 n_cpp_args++;
4925 cmp = cmp->u.s_binary.right;
4926 } while (cmp);
4927
4928 if (n_cpp_args < n_ada_args)
4929 ret = true;
4930 }
4931 else
4932 ret = true;
4933 }
4934
4935 free (mem);
4936
4937 return ret;
4938 }
4939
4940 return false;
4941 }
4942
4943 /* Finalize the processing of From_Limited_With incomplete types. */
4944
4945 void
finalize_from_limited_with(void)4946 finalize_from_limited_with (void)
4947 {
4948 struct incomplete *p, *next;
4949
4950 p = defer_limited_with_list;
4951 defer_limited_with_list = NULL;
4952
4953 for (; p; p = next)
4954 {
4955 next = p->next;
4956
4957 if (p->old_type)
4958 {
4959 update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
4960 gnat_to_gnu_type (p->full_type));
4961 if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
4962 update_profiles_with (p->old_type);
4963 }
4964
4965 free (p);
4966 }
4967 }
4968
4969 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind
4970 of type (such E_Task_Type) that has a different type which Gigi uses
4971 for its representation. If the type does not have a special type for
4972 its representation, return GNAT_ENTITY. */
4973
4974 Entity_Id
Gigi_Equivalent_Type(Entity_Id gnat_entity)4975 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4976 {
4977 Entity_Id gnat_equiv = gnat_entity;
4978
4979 if (No (gnat_entity))
4980 return gnat_entity;
4981
4982 switch (Ekind (gnat_entity))
4983 {
4984 case E_Class_Wide_Subtype:
4985 if (Present (Equivalent_Type (gnat_entity)))
4986 gnat_equiv = Equivalent_Type (gnat_entity);
4987 break;
4988
4989 case E_Access_Protected_Subprogram_Type:
4990 case E_Anonymous_Access_Protected_Subprogram_Type:
4991 if (Present (Equivalent_Type (gnat_entity)))
4992 gnat_equiv = Equivalent_Type (gnat_entity);
4993 break;
4994
4995 case E_Access_Subtype:
4996 gnat_equiv = Etype (gnat_entity);
4997 break;
4998
4999 case E_Class_Wide_Type:
5000 gnat_equiv = Root_Type (gnat_entity);
5001 break;
5002
5003 case E_Protected_Type:
5004 case E_Protected_Subtype:
5005 case E_Task_Type:
5006 case E_Task_Subtype:
5007 if (Present (Corresponding_Record_Type (gnat_entity)))
5008 gnat_equiv = Corresponding_Record_Type (gnat_entity);
5009 break;
5010
5011 default:
5012 break;
5013 }
5014
5015 return gnat_equiv;
5016 }
5017
5018 /* Return a GCC tree for a type corresponding to the component type of the
5019 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
5020 is for an array being defined. DEBUG_INFO_P is true if we need to write
5021 debug information for other types that we may create in the process. */
5022
5023 static tree
gnat_to_gnu_component_type(Entity_Id gnat_array,bool definition,bool debug_info_p)5024 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
5025 bool debug_info_p)
5026 {
5027 const Entity_Id gnat_type = Component_Type (gnat_array);
5028 tree gnu_type = gnat_to_gnu_type (gnat_type);
5029 tree gnu_comp_size;
5030 unsigned int max_align;
5031
5032 /* If an alignment is specified, use it as a cap on the component type
5033 so that it can be honored for the whole type. But ignore it for the
5034 original type of packed array types. */
5035 if (No (Packed_Array_Impl_Type (gnat_array))
5036 && Known_Alignment (gnat_array))
5037 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5038 else
5039 max_align = 0;
5040
5041 /* Try to get a smaller form of the component if needed. */
5042 if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
5043 && !Is_Bit_Packed_Array (gnat_array)
5044 && !Has_Aliased_Components (gnat_array)
5045 && !Strict_Alignment (gnat_type)
5046 && RECORD_OR_UNION_TYPE_P (gnu_type)
5047 && !TYPE_FAT_POINTER_P (gnu_type)
5048 && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
5049 gnu_type = make_packable_type (gnu_type, false, max_align);
5050
5051 /* Get and validate any specified Component_Size. */
5052 gnu_comp_size
5053 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5054 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5055 true, Has_Component_Size_Clause (gnat_array));
5056
5057 /* If the component type is a RECORD_TYPE that has a self-referential size,
5058 then use the maximum size for the component size. */
5059 if (!gnu_comp_size
5060 && TREE_CODE (gnu_type) == RECORD_TYPE
5061 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5062 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5063
5064 /* If the array has aliased components and the component size is zero, force
5065 the unit size to ensure that the components have distinct addresses. */
5066 if (!gnu_comp_size
5067 && Has_Aliased_Components (gnat_array)
5068 && integer_zerop (TYPE_SIZE (gnu_type)))
5069 gnu_comp_size = bitsize_unit_node;
5070
5071 /* Honor the component size. This is not needed for bit-packed arrays. */
5072 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5073 {
5074 tree orig_type = gnu_type;
5075
5076 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5077 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5078 gnu_type = orig_type;
5079 else
5080 orig_type = gnu_type;
5081
5082 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5083 true, false, definition, true);
5084
5085 /* If a padding record was made, declare it now since it will never be
5086 declared otherwise. This is necessary to ensure that its subtrees
5087 are properly marked. */
5088 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5089 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5090 gnat_array);
5091 }
5092
5093 /* This is a very special case where the array has aliased components and the
5094 component size might be zero at run time. As explained above, we force at
5095 least the unit size but we don't want to build a distinct padding type for
5096 each invocation (they are not canonicalized if they have variable size) so
5097 we cache this special padding type as TYPE_PADDING_FOR_COMPONENT. */
5098 else if (Has_Aliased_Components (gnat_array)
5099 && TREE_CODE (gnu_type) == ARRAY_TYPE
5100 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))
5101 {
5102 if (TYPE_PADDING_FOR_COMPONENT (gnu_type))
5103 gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
5104 else
5105 {
5106 gnu_comp_size
5107 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5108 TYPE_PADDING_FOR_COMPONENT (gnu_type)
5109 = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5110 true, false, definition, true);
5111 gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
5112 create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
5113 gnat_array);
5114 }
5115 }
5116
5117 if (Has_Atomic_Components (gnat_array) || Is_Atomic_Or_VFA (gnat_type))
5118 check_ok_for_atomic_type (gnu_type, gnat_array, true);
5119
5120 /* If the component type is a padded type made for a non-bit-packed array
5121 of scalars with reverse storage order, we need to propagate the reverse
5122 storage order to the padding type since it is the innermost enclosing
5123 aggregate type around the scalar. */
5124 if (TYPE_IS_PADDING_P (gnu_type)
5125 && Reverse_Storage_Order (gnat_array)
5126 && !Is_Bit_Packed_Array (gnat_array)
5127 && Is_Scalar_Type (gnat_type))
5128 gnu_type = set_reverse_storage_order_on_pad_type (gnu_type);
5129
5130 if (Has_Volatile_Components (gnat_array))
5131 {
5132 const int quals
5133 = TYPE_QUAL_VOLATILE
5134 | (Has_Atomic_Components (gnat_array) ? TYPE_QUAL_ATOMIC : 0);
5135 gnu_type = change_qualified_type (gnu_type, quals);
5136 }
5137
5138 return gnu_type;
5139 }
5140
5141 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
5142 in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
5143 the type of the parameter. FIRST is true if this is the first parameter in
5144 the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
5145 the copy-in copy-out implementation mechanism.
5146
5147 The returned tree is a PARM_DECL, except for the cases where no parameter
5148 needs to be actually passed to the subprogram; the type of this "shadow"
5149 parameter is then returned instead. */
5150
5151 static tree
gnat_to_gnu_param(Entity_Id gnat_param,tree gnu_param_type,bool first,Entity_Id gnat_subprog,bool * cico)5152 gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
5153 Entity_Id gnat_subprog, bool *cico)
5154 {
5155 Entity_Id gnat_param_type = Etype (gnat_param);
5156 Mechanism_Type mech = Mechanism (gnat_param);
5157 tree gnu_param_name = get_entity_name (gnat_param);
5158 bool foreign = Has_Foreign_Convention (gnat_subprog);
5159 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5160 /* The parameter can be indirectly modified if its address is taken. */
5161 bool ro_param = in_param && !Address_Taken (gnat_param);
5162 bool by_return = false, by_component_ptr = false;
5163 bool by_ref = false;
5164 bool restricted_aliasing_p = false;
5165 location_t saved_location = input_location;
5166 tree gnu_param;
5167
5168 /* Make sure to use the proper SLOC for vector ABI warnings. */
5169 if (VECTOR_TYPE_P (gnu_param_type))
5170 Sloc_to_locus (Sloc (gnat_subprog), &input_location);
5171
5172 /* Builtins are expanded inline and there is no real call sequence involved.
5173 So the type expected by the underlying expander is always the type of the
5174 argument "as is". */
5175 if (Convention (gnat_subprog) == Convention_Intrinsic
5176 && Present (Interface_Name (gnat_subprog)))
5177 mech = By_Copy;
5178
5179 /* Handle the first parameter of a valued procedure specially: it's a copy
5180 mechanism for which the parameter is never allocated. */
5181 else if (first && Is_Valued_Procedure (gnat_subprog))
5182 {
5183 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5184 mech = By_Copy;
5185 by_return = true;
5186 }
5187
5188 /* Or else, see if a Mechanism was supplied that forced this parameter
5189 to be passed one way or another. */
5190 else if (mech == Default || mech == By_Copy || mech == By_Reference)
5191 ;
5192
5193 /* Positive mechanism means by copy for sufficiently small parameters. */
5194 else if (mech > 0)
5195 {
5196 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
5197 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
5198 || compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
5199 mech = By_Reference;
5200 else
5201 mech = By_Copy;
5202 }
5203
5204 /* Otherwise, it's an unsupported mechanism so error out. */
5205 else
5206 {
5207 post_error ("unsupported mechanism for&", gnat_param);
5208 mech = Default;
5209 }
5210
5211 /* If this is either a foreign function or if the underlying type won't
5212 be passed by reference and is as aligned as the original type, strip
5213 off possible padding type. */
5214 if (TYPE_IS_PADDING_P (gnu_param_type))
5215 {
5216 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5217
5218 if (foreign
5219 || (!must_pass_by_ref (unpadded_type)
5220 && mech != By_Reference
5221 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))
5222 && TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
5223 gnu_param_type = unpadded_type;
5224 }
5225
5226 /* If this is a read-only parameter, make a variant of the type that is
5227 read-only. ??? However, if this is a self-referential type, the type
5228 can be very complex, so skip it for now. */
5229 if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5230 gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5231
5232 /* For foreign conventions, pass arrays as pointers to the element type.
5233 First check for unconstrained array and get the underlying array. */
5234 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5235 gnu_param_type
5236 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5237
5238 /* Arrays are passed as pointers to element type for foreign conventions. */
5239 if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5240 {
5241 /* Strip off any multi-dimensional entries, then strip
5242 off the last array to get the component type. */
5243 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5244 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5245 gnu_param_type = TREE_TYPE (gnu_param_type);
5246
5247 by_component_ptr = true;
5248 gnu_param_type = TREE_TYPE (gnu_param_type);
5249
5250 if (ro_param)
5251 gnu_param_type
5252 = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
5253
5254 gnu_param_type = build_pointer_type (gnu_param_type);
5255 }
5256
5257 /* Fat pointers are passed as thin pointers for foreign conventions. */
5258 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5259 gnu_param_type
5260 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5261
5262 /* If we were requested or muss pass by reference, do so.
5263 If we were requested to pass by copy, do so.
5264 Otherwise, for foreign conventions, pass In Out or Out parameters
5265 or aggregates by reference. For COBOL and Fortran, pass all
5266 integer and FP types that way too. For Convention Ada, use
5267 the standard Ada default. */
5268 else if (mech == By_Reference
5269 || must_pass_by_ref (gnu_param_type)
5270 || (mech != By_Copy
5271 && ((foreign
5272 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5273 || (foreign
5274 && (Convention (gnat_subprog) == Convention_Fortran
5275 || Convention (gnat_subprog) == Convention_COBOL)
5276 && (INTEGRAL_TYPE_P (gnu_param_type)
5277 || FLOAT_TYPE_P (gnu_param_type)))
5278 || (!foreign
5279 && default_pass_by_ref (gnu_param_type)))))
5280 {
5281 /* We take advantage of 6.2(12) by considering that references built for
5282 parameters whose type isn't by-ref and for which the mechanism hasn't
5283 been forced to by-ref allow only a restricted form of aliasing. */
5284 restricted_aliasing_p
5285 = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
5286 gnu_param_type = build_reference_type (gnu_param_type);
5287 by_ref = true;
5288 }
5289
5290 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5291 else if (!in_param)
5292 *cico = true;
5293
5294 input_location = saved_location;
5295
5296 if (mech == By_Copy && (by_ref || by_component_ptr))
5297 post_error ("?cannot pass & by copy", gnat_param);
5298
5299 /* If this is an Out parameter that isn't passed by reference and isn't
5300 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5301 it will be a VAR_DECL created when we process the procedure, so just
5302 return its type. For the special parameter of a valued procedure,
5303 never pass it in.
5304
5305 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5306 Out parameters with discriminants or implicit initial values to be
5307 handled like In Out parameters. These type are normally built as
5308 aggregates, hence passed by reference, except for some packed arrays
5309 which end up encoded in special integer types. Note that scalars can
5310 be given implicit initial values using the Default_Value aspect.
5311
5312 The exception we need to make is then for packed arrays of records
5313 with discriminants or implicit initial values. We have no light/easy
5314 way to check for the latter case, so we merely check for packed arrays
5315 of records. This may lead to useless copy-in operations, but in very
5316 rare cases only, as these would be exceptions in a set of already
5317 exceptional situations. */
5318 if (Ekind (gnat_param) == E_Out_Parameter
5319 && !by_ref
5320 && (by_return
5321 || (!POINTER_TYPE_P (gnu_param_type)
5322 && !AGGREGATE_TYPE_P (gnu_param_type)
5323 && !Has_Default_Aspect (gnat_param_type)))
5324 && !(Is_Array_Type (gnat_param_type)
5325 && Is_Packed (gnat_param_type)
5326 && Is_Composite_Type (Component_Type (gnat_param_type))))
5327 return gnu_param_type;
5328
5329 gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
5330 TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
5331 DECL_BY_REF_P (gnu_param) = by_ref;
5332 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5333 DECL_POINTS_TO_READONLY_P (gnu_param)
5334 = (ro_param && (by_ref || by_component_ptr));
5335 DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
5336 DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
5337 Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
5338
5339 /* If no Mechanism was specified, indicate what we're using, then
5340 back-annotate it. */
5341 if (mech == Default)
5342 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5343
5344 Set_Mechanism (gnat_param, mech);
5345 return gnu_param;
5346 }
5347
5348 /* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
5349 GNAT_SUBPROG is updated when GNU_TYPE is completed.
5350
5351 Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
5352 the corresponding profile, which means that, by the time the freeze node
5353 of the subprogram is encountered, types involved in its profile may still
5354 be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
5355 the freeze node of types involved in its profile, either types of formal
5356 parameters or the return type. */
5357
5358 static void
associate_subprog_with_dummy_type(Entity_Id gnat_subprog,tree gnu_type)5359 associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
5360 {
5361 gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
5362
5363 struct tree_entity_vec_map in;
5364 in.base.from = gnu_type;
5365 struct tree_entity_vec_map **slot
5366 = dummy_to_subprog_map->find_slot (&in, INSERT);
5367 if (!*slot)
5368 {
5369 tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
5370 e->base.from = gnu_type;
5371 e->to = NULL;
5372 *slot = e;
5373 }
5374
5375 /* Even if there is already a slot for GNU_TYPE, we need to set the flag
5376 because the vector might have been just emptied by update_profiles_with.
5377 This can happen when there are 2 freeze nodes associated with different
5378 views of the same type; the type will be really complete only after the
5379 second freeze node is encountered. */
5380 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
5381
5382 vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
5383
5384 /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
5385 since this would mean updating twice its profile. */
5386 if (v)
5387 {
5388 const unsigned len = v->length ();
5389 unsigned int l = 0, u = len;
5390
5391 /* Entity_Id is a simple integer so we can implement a stable order on
5392 the vector with an ordered insertion scheme and binary search. */
5393 while (l < u)
5394 {
5395 unsigned int m = (l + u) / 2;
5396 int diff = (int) (*v)[m] - (int) gnat_subprog;
5397 if (diff > 0)
5398 u = m;
5399 else if (diff < 0)
5400 l = m + 1;
5401 else
5402 return;
5403 }
5404
5405 /* l == u and therefore is the insertion point. */
5406 vec_safe_insert (v, l, gnat_subprog);
5407 }
5408 else
5409 vec_safe_push (v, gnat_subprog);
5410
5411 (*slot)->to = v;
5412 }
5413
5414 /* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
5415
5416 static void
update_profile(Entity_Id gnat_subprog)5417 update_profile (Entity_Id gnat_subprog)
5418 {
5419 tree gnu_param_list;
5420 tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
5421 Needs_Debug_Info (gnat_subprog),
5422 &gnu_param_list);
5423 if (DECL_P (gnu_type))
5424 {
5425 /* Builtins cannot have their address taken so we can reset them. */
5426 gcc_assert (DECL_BUILT_IN (gnu_type));
5427 save_gnu_tree (gnat_subprog, NULL_TREE, false);
5428 save_gnu_tree (gnat_subprog, gnu_type, false);
5429 return;
5430 }
5431
5432 tree gnu_subprog = get_gnu_tree (gnat_subprog);
5433
5434 TREE_TYPE (gnu_subprog) = gnu_type;
5435
5436 /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
5437 and needs to be adjusted too. */
5438 if (Ekind (gnat_subprog) != E_Subprogram_Type)
5439 {
5440 tree gnu_entity_name = get_entity_name (gnat_subprog);
5441 tree gnu_ext_name
5442 = gnu_ext_name_for_subprog (gnat_subprog, gnu_entity_name);
5443
5444 DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
5445 finish_subprog_decl (gnu_subprog, gnu_ext_name, gnu_type);
5446 }
5447 }
5448
5449 /* Update the GCC trees previously built for the profiles involving GNU_TYPE,
5450 a dummy type which appears in profiles. */
5451
5452 void
update_profiles_with(tree gnu_type)5453 update_profiles_with (tree gnu_type)
5454 {
5455 struct tree_entity_vec_map in;
5456 in.base.from = gnu_type;
5457 struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
5458 gcc_assert (e);
5459 vec<Entity_Id, va_gc_atomic> *v = e->to;
5460 e->to = NULL;
5461
5462 /* The flag needs to be reset before calling update_profile, in case
5463 associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
5464 TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
5465
5466 unsigned int i;
5467 Entity_Id *iter;
5468 FOR_EACH_VEC_ELT (*v, i, iter)
5469 update_profile (*iter);
5470
5471 vec_free (v);
5472 }
5473
5474 /* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
5475
5476 Ada 2012 (AI05-0151) says that incomplete types coming from a limited
5477 context may now appear as parameter and result types. As a consequence,
5478 we may need to defer their translation until after a freeze node is seen
5479 or to the end of the current unit. We also aim at handling temporarily
5480 incomplete types created by the usual delayed elaboration scheme. */
5481
5482 static tree
gnat_to_gnu_profile_type(Entity_Id gnat_type)5483 gnat_to_gnu_profile_type (Entity_Id gnat_type)
5484 {
5485 /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
5486 so the rationale is exposed in that place. These processings probably
5487 ought to be merged at some point. */
5488 Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
5489 const bool is_from_limited_with
5490 = (Is_Incomplete_Type (gnat_equiv)
5491 && From_Limited_With (gnat_equiv));
5492 Entity_Id gnat_full_direct_first
5493 = (is_from_limited_with
5494 ? Non_Limited_View (gnat_equiv)
5495 : (Is_Incomplete_Or_Private_Type (gnat_equiv)
5496 ? Full_View (gnat_equiv) : Empty));
5497 Entity_Id gnat_full_direct
5498 = ((is_from_limited_with
5499 && Present (gnat_full_direct_first)
5500 && Is_Private_Type (gnat_full_direct_first))
5501 ? Full_View (gnat_full_direct_first)
5502 : gnat_full_direct_first);
5503 Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
5504 Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
5505 const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
5506 tree gnu_type;
5507
5508 if (Present (gnat_full) && present_gnu_tree (gnat_full))
5509 gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
5510
5511 else if (is_from_limited_with
5512 && ((!in_main_unit
5513 && !present_gnu_tree (gnat_equiv)
5514 && Present (gnat_full)
5515 && (Is_Record_Type (gnat_full)
5516 || Is_Array_Type (gnat_full)
5517 || Is_Access_Type (gnat_full)))
5518 || (in_main_unit && Present (Freeze_Node (gnat_rep)))))
5519 {
5520 gnu_type = make_dummy_type (gnat_equiv);
5521
5522 if (!in_main_unit)
5523 {
5524 struct incomplete *p = XNEW (struct incomplete);
5525
5526 p->old_type = gnu_type;
5527 p->full_type = gnat_equiv;
5528 p->next = defer_limited_with_list;
5529 defer_limited_with_list = p;
5530 }
5531 }
5532
5533 else if (type_annotate_only && No (gnat_equiv))
5534 gnu_type = void_type_node;
5535
5536 else
5537 gnu_type = gnat_to_gnu_type (gnat_equiv);
5538
5539 /* Access-to-unconstrained-array types need a special treatment. */
5540 if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
5541 {
5542 if (!TYPE_POINTER_TO (gnu_type))
5543 build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
5544 }
5545
5546 return gnu_type;
5547 }
5548
5549 /* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
5550 DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
5551 is true if we need to write debug information for other types that we may
5552 create in the process. Also set PARAM_LIST to the list of parameters.
5553 If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
5554 directly instead of its type. */
5555
5556 static tree
gnat_to_gnu_subprog_type(Entity_Id gnat_subprog,bool definition,bool debug_info_p,tree * param_list)5557 gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
5558 bool debug_info_p, tree *param_list)
5559 {
5560 const Entity_Kind kind = Ekind (gnat_subprog);
5561 Entity_Id gnat_return_type = Etype (gnat_subprog);
5562 Entity_Id gnat_param;
5563 tree gnu_type = present_gnu_tree (gnat_subprog)
5564 ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
5565 tree gnu_return_type;
5566 tree gnu_param_type_list = NULL_TREE;
5567 tree gnu_param_list = NULL_TREE;
5568 /* Non-null for subprograms containing parameters passed by copy-in copy-out
5569 (In Out or Out parameters not passed by reference), in which case it is
5570 the list of nodes used to specify the values of the In Out/Out parameters
5571 that are returned as a record upon procedure return. The TREE_PURPOSE of
5572 an element of this list is a FIELD_DECL of the record and the TREE_VALUE
5573 is the PARM_DECL corresponding to that field. This list will be saved in
5574 the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
5575 tree gnu_cico_list = NULL_TREE;
5576 tree gnu_cico_return_type = NULL_TREE;
5577 /* Fields in return type of procedure with copy-in copy-out parameters. */
5578 tree gnu_field_list = NULL_TREE;
5579 /* The semantics of "pure" in Ada essentially matches that of "const"
5580 in the back-end. In particular, both properties are orthogonal to
5581 the "nothrow" property if the EH circuitry is explicit in the
5582 internal representation of the back-end. If we are to completely
5583 hide the EH circuitry from it, we need to declare that calls to pure
5584 Ada subprograms that can throw have side effects since they can
5585 trigger an "abnormal" transfer of control flow; thus they can be
5586 neither "const" nor "pure" in the back-end sense. */
5587 bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
5588 bool return_by_direct_ref_p = false;
5589 bool return_by_invisi_ref_p = false;
5590 bool return_unconstrained_p = false;
5591 bool incomplete_profile_p = false;
5592 unsigned int num;
5593
5594 /* Look into the return type and get its associated GCC tree if it is not
5595 void, and then compute various flags for the subprogram type. But make
5596 sure not to do this processing multiple times. */
5597 if (Ekind (gnat_return_type) == E_Void)
5598 gnu_return_type = void_type_node;
5599
5600 else if (gnu_type
5601 && TREE_CODE (gnu_type) == FUNCTION_TYPE
5602 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
5603 {
5604 gnu_return_type = TREE_TYPE (gnu_type);
5605 return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
5606 return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
5607 return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
5608 }
5609
5610 else
5611 {
5612 /* For foreign convention subprograms, return System.Address as void *
5613 or equivalent. Note that this comprises GCC builtins. */
5614 if (Has_Foreign_Convention (gnat_subprog)
5615 && Is_Descendant_Of_Address (Underlying_Type (gnat_return_type)))
5616 gnu_return_type = ptr_type_node;
5617 else
5618 gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
5619
5620 /* If this function returns by reference, make the actual return type
5621 the reference type and make a note of that. */
5622 if (Returns_By_Ref (gnat_subprog))
5623 {
5624 gnu_return_type = build_reference_type (gnu_return_type);
5625 return_by_direct_ref_p = true;
5626 }
5627
5628 /* If the return type is an unconstrained array type, the return value
5629 will be allocated on the secondary stack so the actual return type
5630 is the fat pointer type. */
5631 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
5632 {
5633 gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
5634 return_unconstrained_p = true;
5635 }
5636
5637 /* This is the same unconstrained array case, but for a dummy type. */
5638 else if (TYPE_REFERENCE_TO (gnu_return_type)
5639 && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
5640 {
5641 gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
5642 return_unconstrained_p = true;
5643 }
5644
5645 /* Likewise, if the return type requires a transient scope, the return
5646 value will also be allocated on the secondary stack so the actual
5647 return type is the reference type. */
5648 else if (Requires_Transient_Scope (gnat_return_type))
5649 {
5650 gnu_return_type = build_reference_type (gnu_return_type);
5651 return_unconstrained_p = true;
5652 }
5653
5654 /* If the Mechanism is By_Reference, ensure this function uses the
5655 target's by-invisible-reference mechanism, which may not be the
5656 same as above (e.g. it might be passing an extra parameter). */
5657 else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
5658 return_by_invisi_ref_p = true;
5659
5660 /* Likewise, if the return type is itself By_Reference. */
5661 else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
5662 return_by_invisi_ref_p = true;
5663
5664 /* If the type is a padded type and the underlying type would not be
5665 passed by reference or the function has a foreign convention, return
5666 the underlying type. */
5667 else if (TYPE_IS_PADDING_P (gnu_return_type)
5668 && (!default_pass_by_ref
5669 (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
5670 || Has_Foreign_Convention (gnat_subprog)))
5671 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
5672
5673 /* If the return type is unconstrained, it must have a maximum size.
5674 Use the padded type as the effective return type. And ensure the
5675 function uses the target's by-invisible-reference mechanism to
5676 avoid copying too much data when it returns. */
5677 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
5678 {
5679 tree orig_type = gnu_return_type;
5680 tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
5681
5682 /* If the size overflows to 0, set it to an arbitrary positive
5683 value so that assignments in the type are preserved. Their
5684 actual size is independent of this positive value. */
5685 if (TREE_CODE (max_return_size) == INTEGER_CST
5686 && TREE_OVERFLOW (max_return_size)
5687 && integer_zerop (max_return_size))
5688 {
5689 max_return_size = copy_node (bitsize_unit_node);
5690 TREE_OVERFLOW (max_return_size) = 1;
5691 }
5692
5693 gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
5694 0, gnat_subprog, false, false,
5695 definition, true);
5696
5697 /* Declare it now since it will never be declared otherwise. This
5698 is necessary to ensure that its subtrees are properly marked. */
5699 if (gnu_return_type != orig_type
5700 && !DECL_P (TYPE_NAME (gnu_return_type)))
5701 create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
5702 true, debug_info_p, gnat_subprog);
5703
5704 return_by_invisi_ref_p = true;
5705 }
5706
5707 /* If the return type has a size that overflows, we usually cannot have
5708 a function that returns that type. This usage doesn't really make
5709 sense anyway, so issue an error here. */
5710 if (!return_by_invisi_ref_p
5711 && TYPE_SIZE_UNIT (gnu_return_type)
5712 && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
5713 && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
5714 {
5715 post_error ("cannot return type whose size overflows", gnat_subprog);
5716 gnu_return_type = copy_type (gnu_return_type);
5717 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
5718 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
5719 }
5720
5721 /* If the return type is incomplete, there are 2 cases: if the function
5722 returns by reference, then the return type is only linked indirectly
5723 in the profile, so the profile can be seen as complete since it need
5724 not be further modified, only the reference types need be adjusted;
5725 otherwise the profile is incomplete and need be adjusted too. */
5726 if (TYPE_IS_DUMMY_P (gnu_return_type))
5727 {
5728 associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
5729 incomplete_profile_p = true;
5730 }
5731
5732 if (kind == E_Function)
5733 Set_Mechanism (gnat_subprog, return_unconstrained_p
5734 || return_by_direct_ref_p
5735 || return_by_invisi_ref_p
5736 ? By_Reference : By_Copy);
5737 }
5738
5739 /* A procedure (something that doesn't return anything) shouldn't be
5740 considered const since there would be no reason for calling such a
5741 subprogram. Note that procedures with Out (or In Out) parameters
5742 have already been converted into a function with a return type.
5743 Similarly, if the function returns an unconstrained type, then the
5744 function will allocate the return value on the secondary stack and
5745 thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
5746 if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
5747 const_flag = false;
5748
5749 /* Loop over the parameters and get their associated GCC tree. While doing
5750 this, build a copy-in copy-out structure if we need one. */
5751 for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
5752 Present (gnat_param);
5753 gnat_param = Next_Formal_With_Extras (gnat_param), num++)
5754 {
5755 const bool mech_is_by_ref
5756 = Mechanism (gnat_param) == By_Reference
5757 && !(num == 0 && Is_Valued_Procedure (gnat_subprog));
5758 tree gnu_param_name = get_entity_name (gnat_param);
5759 tree gnu_param, gnu_param_type;
5760 bool cico = false;
5761
5762 /* Fetch an existing parameter with complete type and reuse it. But we
5763 didn't save the CICO property so we can only do it for In parameters
5764 or parameters passed by reference. */
5765 if ((Ekind (gnat_param) == E_In_Parameter || mech_is_by_ref)
5766 && present_gnu_tree (gnat_param)
5767 && (gnu_param = get_gnu_tree (gnat_param))
5768 && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param)))
5769 {
5770 DECL_CHAIN (gnu_param) = NULL_TREE;
5771 gnu_param_type = TREE_TYPE (gnu_param);
5772 }
5773
5774 /* Otherwise translate the parameter type and act accordingly. */
5775 else
5776 {
5777 Entity_Id gnat_param_type = Etype (gnat_param);
5778
5779 /* For foreign convention subprograms, pass System.Address as void *
5780 or equivalent. Note that this comprises GCC builtins. */
5781 if (Has_Foreign_Convention (gnat_subprog)
5782 && Is_Descendant_Of_Address (Underlying_Type (gnat_param_type)))
5783 gnu_param_type = ptr_type_node;
5784 else
5785 gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
5786
5787 /* If the parameter type is incomplete, there are 2 cases: if it is
5788 passed by reference, then the type is only linked indirectly in
5789 the profile, so the profile can be seen as complete since it need
5790 not be further modified, only the reference type need be adjusted;
5791 otherwise the profile is incomplete and need be adjusted too. */
5792 if (TYPE_IS_DUMMY_P (gnu_param_type))
5793 {
5794 Node_Id gnat_decl;
5795
5796 if (mech_is_by_ref
5797 || (TYPE_REFERENCE_TO (gnu_param_type)
5798 && TYPE_IS_FAT_POINTER_P
5799 (TYPE_REFERENCE_TO (gnu_param_type)))
5800 || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
5801 {
5802 gnu_param_type = build_reference_type (gnu_param_type);
5803 gnu_param
5804 = create_param_decl (gnu_param_name, gnu_param_type);
5805 TREE_READONLY (gnu_param) = 1;
5806 DECL_BY_REF_P (gnu_param) = 1;
5807 DECL_POINTS_TO_READONLY_P (gnu_param)
5808 = (Ekind (gnat_param) == E_In_Parameter
5809 && !Address_Taken (gnat_param));
5810 Set_Mechanism (gnat_param, By_Reference);
5811 Sloc_to_locus (Sloc (gnat_param),
5812 &DECL_SOURCE_LOCATION (gnu_param));
5813 }
5814
5815 /* ??? This is a kludge to support null procedures in spec taking
5816 a parameter with an untagged incomplete type coming from a
5817 limited context. The front-end creates a body without knowing
5818 anything about the non-limited view, which is illegal Ada and
5819 cannot be supported. Create a parameter with a fake type. */
5820 else if (kind == E_Procedure
5821 && (gnat_decl = Parent (gnat_subprog))
5822 && Nkind (gnat_decl) == N_Procedure_Specification
5823 && Null_Present (gnat_decl)
5824 && Is_Incomplete_Type (gnat_param_type))
5825 gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
5826
5827 else
5828 {
5829 /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
5830 Call_to_gnu will stop if it encounters the PARM_DECL. */
5831 gnu_param
5832 = build_decl (input_location, PARM_DECL, gnu_param_name,
5833 gnu_param_type);
5834 associate_subprog_with_dummy_type (gnat_subprog,
5835 gnu_param_type);
5836 incomplete_profile_p = true;
5837 }
5838 }
5839
5840 /* Otherwise build the parameter declaration normally. */
5841 else
5842 {
5843 gnu_param
5844 = gnat_to_gnu_param (gnat_param, gnu_param_type, num == 0,
5845 gnat_subprog, &cico);
5846
5847 /* We are returned either a PARM_DECL or a type if no parameter
5848 needs to be passed; in either case, adjust the type. */
5849 if (DECL_P (gnu_param))
5850 gnu_param_type = TREE_TYPE (gnu_param);
5851 else
5852 {
5853 gnu_param_type = gnu_param;
5854 gnu_param = NULL_TREE;
5855 }
5856 }
5857 }
5858
5859 /* If we have a GCC tree for the parameter, register it. */
5860 save_gnu_tree (gnat_param, NULL_TREE, false);
5861 if (gnu_param)
5862 {
5863 gnu_param_type_list
5864 = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
5865 gnu_param_list = chainon (gnu_param, gnu_param_list);
5866 save_gnu_tree (gnat_param, gnu_param, false);
5867
5868 /* If a parameter is a pointer, a function may modify memory through
5869 it and thus shouldn't be considered a const function. Also, the
5870 memory may be modified between two calls, so they can't be CSE'ed.
5871 The latter case also handles by-ref parameters. */
5872 if (POINTER_TYPE_P (gnu_param_type)
5873 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
5874 const_flag = false;
5875 }
5876
5877 /* If the parameter uses the copy-in copy-out mechanism, allocate a field
5878 for it in the return type and register the association. */
5879 if (cico && !incomplete_profile_p)
5880 {
5881 if (!gnu_cico_list)
5882 {
5883 gnu_cico_return_type = make_node (RECORD_TYPE);
5884
5885 /* If this is a function, we also need a field for the
5886 return value to be placed. */
5887 if (!VOID_TYPE_P (gnu_return_type))
5888 {
5889 tree gnu_field
5890 = create_field_decl (get_identifier ("RETVAL"),
5891 gnu_return_type,
5892 gnu_cico_return_type, NULL_TREE,
5893 NULL_TREE, 0, 0);
5894 Sloc_to_locus (Sloc (gnat_subprog),
5895 &DECL_SOURCE_LOCATION (gnu_field));
5896 gnu_field_list = gnu_field;
5897 gnu_cico_list
5898 = tree_cons (gnu_field, void_type_node, NULL_TREE);
5899 }
5900
5901 TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN");
5902 /* Set a default alignment to speed up accesses. But we should
5903 not increase the size of the structure too much, lest it does
5904 not fit in return registers anymore. */
5905 SET_TYPE_ALIGN (gnu_cico_return_type,
5906 get_mode_alignment (ptr_mode));
5907 }
5908
5909 tree gnu_field
5910 = create_field_decl (gnu_param_name, gnu_param_type,
5911 gnu_cico_return_type, NULL_TREE, NULL_TREE,
5912 0, 0);
5913 Sloc_to_locus (Sloc (gnat_param),
5914 &DECL_SOURCE_LOCATION (gnu_field));
5915 DECL_CHAIN (gnu_field) = gnu_field_list;
5916 gnu_field_list = gnu_field;
5917 gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
5918 }
5919 }
5920
5921 /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
5922 and finish up the return type. */
5923 if (gnu_cico_list && !incomplete_profile_p)
5924 {
5925 /* If we have a CICO list but it has only one entry, we convert
5926 this function into a function that returns this object. */
5927 if (list_length (gnu_cico_list) == 1)
5928 gnu_cico_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
5929
5930 /* Do not finalize the return type if the subprogram is stubbed
5931 since structures are incomplete for the back-end. */
5932 else if (Convention (gnat_subprog) != Convention_Stubbed)
5933 {
5934 finish_record_type (gnu_cico_return_type, nreverse (gnu_field_list),
5935 0, false);
5936
5937 /* Try to promote the mode of the return type if it is passed
5938 in registers, again to speed up accesses. */
5939 if (TYPE_MODE (gnu_cico_return_type) == BLKmode
5940 && !targetm.calls.return_in_memory (gnu_cico_return_type,
5941 NULL_TREE))
5942 {
5943 unsigned int size
5944 = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type));
5945 unsigned int i = BITS_PER_UNIT;
5946 scalar_int_mode mode;
5947
5948 while (i < size)
5949 i <<= 1;
5950 if (int_mode_for_size (i, 0).exists (&mode))
5951 {
5952 SET_TYPE_MODE (gnu_cico_return_type, mode);
5953 SET_TYPE_ALIGN (gnu_cico_return_type,
5954 GET_MODE_ALIGNMENT (mode));
5955 TYPE_SIZE (gnu_cico_return_type)
5956 = bitsize_int (GET_MODE_BITSIZE (mode));
5957 TYPE_SIZE_UNIT (gnu_cico_return_type)
5958 = size_int (GET_MODE_SIZE (mode));
5959 }
5960 }
5961
5962 if (debug_info_p)
5963 rest_of_record_type_compilation (gnu_cico_return_type);
5964 }
5965
5966 gnu_return_type = gnu_cico_return_type;
5967 }
5968
5969 /* The lists have been built in reverse. */
5970 gnu_param_type_list = nreverse (gnu_param_type_list);
5971 gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
5972 *param_list = nreverse (gnu_param_list);
5973 gnu_cico_list = nreverse (gnu_cico_list);
5974
5975 /* If the profile is incomplete, we only set the (temporary) return and
5976 parameter types; otherwise, we build the full type. In either case,
5977 we reuse an already existing GCC tree that we built previously here. */
5978 if (incomplete_profile_p)
5979 {
5980 if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
5981 ;
5982 else
5983 gnu_type = make_node (FUNCTION_TYPE);
5984 TREE_TYPE (gnu_type) = gnu_return_type;
5985 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
5986 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
5987 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
5988 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
5989 }
5990 else
5991 {
5992 if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
5993 {
5994 TREE_TYPE (gnu_type) = gnu_return_type;
5995 TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
5996 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
5997 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
5998 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
5999 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6000 TYPE_CANONICAL (gnu_type) = gnu_type;
6001 layout_type (gnu_type);
6002 }
6003 else
6004 {
6005 gnu_type
6006 = build_function_type (gnu_return_type, gnu_param_type_list);
6007
6008 /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
6009 has a different TYPE_CI_CO_LIST or flags. */
6010 if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
6011 return_unconstrained_p,
6012 return_by_direct_ref_p,
6013 return_by_invisi_ref_p))
6014 {
6015 gnu_type = copy_type (gnu_type);
6016 TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
6017 TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
6018 TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
6019 TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
6020 }
6021 }
6022
6023 if (const_flag)
6024 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
6025
6026 if (No_Return (gnat_subprog))
6027 gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
6028
6029 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
6030 corresponding DECL node and check the parameter association. */
6031 if (Convention (gnat_subprog) == Convention_Intrinsic
6032 && Present (Interface_Name (gnat_subprog)))
6033 {
6034 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6035 tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
6036
6037 /* If we have a builtin DECL for that function, use it. Check if
6038 the profiles are compatible and warn if they are not. Note that
6039 the checker is expected to post diagnostics in this case. */
6040 if (gnu_builtin_decl)
6041 {
6042 intrin_binding_t inb
6043 = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) };
6044
6045 if (!intrin_profiles_compatible_p (&inb))
6046 post_error
6047 ("?profile of& doesn''t match the builtin it binds!",
6048 gnat_subprog);
6049
6050 return gnu_builtin_decl;
6051 }
6052
6053 /* Inability to find the builtin DECL most often indicates a genuine
6054 mistake, but imports of unregistered intrinsics are sometimes used
6055 on purpose to allow hooking in alternate bodies; we post a warning
6056 conditioned on Wshadow in this case, to let developers be notified
6057 on demand without risking false positives with common default sets
6058 of options. */
6059 if (warn_shadow)
6060 post_error ("?gcc intrinsic not found for&!", gnat_subprog);
6061 }
6062 }
6063
6064 return gnu_type;
6065 }
6066
6067 /* Return the external name for GNAT_SUBPROG given its entity name. */
6068
6069 static tree
gnu_ext_name_for_subprog(Entity_Id gnat_subprog,tree gnu_entity_name)6070 gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name)
6071 {
6072 tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
6073
6074 /* If there was no specified Interface_Name and the external and
6075 internal names of the subprogram are the same, only use the
6076 internal name to allow disambiguation of nested subprograms. */
6077 if (No (Interface_Name (gnat_subprog)) && gnu_ext_name == gnu_entity_name)
6078 gnu_ext_name = NULL_TREE;
6079
6080 return gnu_ext_name;
6081 }
6082
6083 /* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
6084 build_nonshared_array_type. */
6085
6086 static void
set_nonaliased_component_on_array_type(tree type)6087 set_nonaliased_component_on_array_type (tree type)
6088 {
6089 TYPE_NONALIASED_COMPONENT (type) = 1;
6090 if (TYPE_CANONICAL (type))
6091 TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1;
6092 }
6093
6094 /* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
6095 build_nonshared_array_type. */
6096
6097 static void
set_reverse_storage_order_on_array_type(tree type)6098 set_reverse_storage_order_on_array_type (tree type)
6099 {
6100 TYPE_REVERSE_STORAGE_ORDER (type) = 1;
6101 if (TYPE_CANONICAL (type))
6102 TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
6103 }
6104
6105 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
6106
6107 static bool
same_discriminant_p(Entity_Id discr1,Entity_Id discr2)6108 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
6109 {
6110 while (Present (Corresponding_Discriminant (discr1)))
6111 discr1 = Corresponding_Discriminant (discr1);
6112
6113 while (Present (Corresponding_Discriminant (discr2)))
6114 discr2 = Corresponding_Discriminant (discr2);
6115
6116 return
6117 Original_Record_Component (discr1) == Original_Record_Component (discr2);
6118 }
6119
6120 /* Return true if the array type GNU_TYPE, which represents a dimension of
6121 GNAT_TYPE, has a non-aliased component in the back-end sense. */
6122
6123 static bool
array_type_has_nonaliased_component(tree gnu_type,Entity_Id gnat_type)6124 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
6125 {
6126 /* If the array type has an aliased component in the front-end sense,
6127 then it also has an aliased component in the back-end sense. */
6128 if (Has_Aliased_Components (gnat_type))
6129 return false;
6130
6131 /* If this is a derived type, then it has a non-aliased component if
6132 and only if its parent type also has one. */
6133 if (Is_Derived_Type (gnat_type))
6134 {
6135 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
6136 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
6137 gnu_parent_type
6138 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
6139 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
6140 }
6141
6142 /* For a multi-dimensional array type, find the component type. */
6143 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6144 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
6145 gnu_type = TREE_TYPE (gnu_type);
6146
6147 /* Consider that an array of pointers has an aliased component, which is
6148 sort of logical and helps with Taft Amendment types in LTO mode. */
6149 if (POINTER_TYPE_P (TREE_TYPE (gnu_type)))
6150 return false;
6151
6152 /* Otherwise, rely exclusively on properties of the element type. */
6153 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
6154 }
6155
6156 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
6157
6158 static bool
compile_time_known_address_p(Node_Id gnat_address)6159 compile_time_known_address_p (Node_Id gnat_address)
6160 {
6161 /* Handle reference to a constant. */
6162 if (Is_Entity_Name (gnat_address)
6163 && Ekind (Entity (gnat_address)) == E_Constant)
6164 {
6165 gnat_address = Constant_Value (Entity (gnat_address));
6166 if (No (gnat_address))
6167 return false;
6168 }
6169
6170 /* Catch System'To_Address. */
6171 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
6172 gnat_address = Expression (gnat_address);
6173
6174 return Compile_Time_Known_Value (gnat_address);
6175 }
6176
6177 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the
6178 inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */
6179
6180 static bool
cannot_be_superflat(Node_Id gnat_range)6181 cannot_be_superflat (Node_Id gnat_range)
6182 {
6183 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
6184 Node_Id scalar_range;
6185 tree gnu_lb, gnu_hb, gnu_lb_minus_one;
6186
6187 /* If the low bound is not constant, try to find an upper bound. */
6188 while (Nkind (gnat_lb) != N_Integer_Literal
6189 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
6190 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
6191 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
6192 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6193 || Nkind (scalar_range) == N_Range))
6194 gnat_lb = High_Bound (scalar_range);
6195
6196 /* If the high bound is not constant, try to find a lower bound. */
6197 while (Nkind (gnat_hb) != N_Integer_Literal
6198 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
6199 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
6200 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
6201 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
6202 || Nkind (scalar_range) == N_Range))
6203 gnat_hb = Low_Bound (scalar_range);
6204
6205 /* If we have failed to find constant bounds, punt. */
6206 if (Nkind (gnat_lb) != N_Integer_Literal
6207 || Nkind (gnat_hb) != N_Integer_Literal)
6208 return false;
6209
6210 /* We need at least a signed 64-bit type to catch most cases. */
6211 gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype);
6212 gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype);
6213 if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb))
6214 return false;
6215
6216 /* If the low bound is the smallest integer, nothing can be smaller. */
6217 gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node);
6218 if (TREE_OVERFLOW (gnu_lb_minus_one))
6219 return true;
6220
6221 return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one);
6222 }
6223
6224 /* Return true if GNU_EXPR is (essentially) the address of a CONSTRUCTOR. */
6225
6226 static bool
constructor_address_p(tree gnu_expr)6227 constructor_address_p (tree gnu_expr)
6228 {
6229 while (TREE_CODE (gnu_expr) == NOP_EXPR
6230 || TREE_CODE (gnu_expr) == CONVERT_EXPR
6231 || TREE_CODE (gnu_expr) == NON_LVALUE_EXPR)
6232 gnu_expr = TREE_OPERAND (gnu_expr, 0);
6233
6234 return (TREE_CODE (gnu_expr) == ADDR_EXPR
6235 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR);
6236 }
6237
6238 /* Return true if the size in units represented by GNU_SIZE can be handled by
6239 an allocation. If STATIC_P is true, consider only what can be done with a
6240 static allocation. */
6241
6242 static bool
allocatable_size_p(tree gnu_size,bool static_p)6243 allocatable_size_p (tree gnu_size, bool static_p)
6244 {
6245 /* We can allocate a fixed size if it is a valid for the middle-end. */
6246 if (TREE_CODE (gnu_size) == INTEGER_CST)
6247 return valid_constant_size_p (gnu_size);
6248
6249 /* We can allocate a variable size if this isn't a static allocation. */
6250 else
6251 return !static_p;
6252 }
6253
6254 /* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the
6255 initial value of an object of GNU_TYPE. */
6256
6257 static bool
initial_value_needs_conversion(tree gnu_type,tree gnu_expr)6258 initial_value_needs_conversion (tree gnu_type, tree gnu_expr)
6259 {
6260 /* Do not convert if the object's type is unconstrained because this would
6261 generate useless evaluations of the CONSTRUCTOR to compute the size. */
6262 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
6263 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
6264 return false;
6265
6266 /* Do not convert if the object's type is a padding record whose field is of
6267 self-referential size because we want to copy only the actual data. */
6268 if (type_is_padding_self_referential (gnu_type))
6269 return false;
6270
6271 /* Do not convert a call to a function that returns with variable size since
6272 we want to use the return slot optimization in this case. */
6273 if (TREE_CODE (gnu_expr) == CALL_EXPR
6274 && return_type_with_variable_size_p (TREE_TYPE (gnu_expr)))
6275 return false;
6276
6277 /* Do not convert to a record type with a variant part from a record type
6278 without one, to keep the object simpler. */
6279 if (TREE_CODE (gnu_type) == RECORD_TYPE
6280 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
6281 && get_variant_part (gnu_type)
6282 && !get_variant_part (TREE_TYPE (gnu_expr)))
6283 return false;
6284
6285 /* In all the other cases, convert the expression to the object's type. */
6286 return true;
6287 }
6288
6289 /* Given GNAT_ENTITY, elaborate all expressions that are required to
6290 be elaborated at the point of its definition, but do nothing else. */
6291
6292 void
elaborate_entity(Entity_Id gnat_entity)6293 elaborate_entity (Entity_Id gnat_entity)
6294 {
6295 switch (Ekind (gnat_entity))
6296 {
6297 case E_Signed_Integer_Subtype:
6298 case E_Modular_Integer_Subtype:
6299 case E_Enumeration_Subtype:
6300 case E_Ordinary_Fixed_Point_Subtype:
6301 case E_Decimal_Fixed_Point_Subtype:
6302 case E_Floating_Point_Subtype:
6303 {
6304 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
6305 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
6306
6307 /* ??? Tests to avoid Constraint_Error in static expressions
6308 are needed until after the front stops generating bogus
6309 conversions on bounds of real types. */
6310 if (!Raises_Constraint_Error (gnat_lb))
6311 elaborate_expression (gnat_lb, gnat_entity, "L", true, false,
6312 Needs_Debug_Info (gnat_entity));
6313 if (!Raises_Constraint_Error (gnat_hb))
6314 elaborate_expression (gnat_hb, gnat_entity, "U", true, false,
6315 Needs_Debug_Info (gnat_entity));
6316 break;
6317 }
6318
6319 case E_Record_Subtype:
6320 case E_Private_Subtype:
6321 case E_Limited_Private_Subtype:
6322 case E_Record_Subtype_With_Private:
6323 if (Has_Discriminants (gnat_entity) && Is_Constrained (gnat_entity))
6324 {
6325 Node_Id gnat_discriminant_expr;
6326 Entity_Id gnat_field;
6327
6328 for (gnat_field
6329 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
6330 gnat_discriminant_expr
6331 = First_Elmt (Discriminant_Constraint (gnat_entity));
6332 Present (gnat_field);
6333 gnat_field = Next_Discriminant (gnat_field),
6334 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
6335 /* Ignore access discriminants. */
6336 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
6337 elaborate_expression (Node (gnat_discriminant_expr),
6338 gnat_entity, get_entity_char (gnat_field),
6339 true, false, false);
6340 }
6341 break;
6342
6343 }
6344 }
6345
6346 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
6347 NAME, ARGS and ERROR_POINT. */
6348
6349 static void
prepend_one_attribute(struct attrib ** attr_list,enum attrib_type attrib_type,tree attr_name,tree attr_args,Node_Id attr_error_point)6350 prepend_one_attribute (struct attrib **attr_list,
6351 enum attrib_type attrib_type,
6352 tree attr_name,
6353 tree attr_args,
6354 Node_Id attr_error_point)
6355 {
6356 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
6357
6358 attr->type = attrib_type;
6359 attr->name = attr_name;
6360 attr->args = attr_args;
6361 attr->error_point = attr_error_point;
6362
6363 attr->next = *attr_list;
6364 *attr_list = attr;
6365 }
6366
6367 /* Prepend to ATTR_LIST an entry for an attribute provided by GNAT_PRAGMA. */
6368
6369 static void
prepend_one_attribute_pragma(struct attrib ** attr_list,Node_Id gnat_pragma)6370 prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma)
6371 {
6372 const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma);
6373 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
6374 enum attrib_type etype;
6375
6376 /* Map the pragma at hand. Skip if this isn't one we know how to handle. */
6377 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
6378 {
6379 case Pragma_Machine_Attribute:
6380 etype = ATTR_MACHINE_ATTRIBUTE;
6381 break;
6382
6383 case Pragma_Linker_Alias:
6384 etype = ATTR_LINK_ALIAS;
6385 break;
6386
6387 case Pragma_Linker_Section:
6388 etype = ATTR_LINK_SECTION;
6389 break;
6390
6391 case Pragma_Linker_Constructor:
6392 etype = ATTR_LINK_CONSTRUCTOR;
6393 break;
6394
6395 case Pragma_Linker_Destructor:
6396 etype = ATTR_LINK_DESTRUCTOR;
6397 break;
6398
6399 case Pragma_Weak_External:
6400 etype = ATTR_WEAK_EXTERNAL;
6401 break;
6402
6403 case Pragma_Thread_Local_Storage:
6404 etype = ATTR_THREAD_LOCAL_STORAGE;
6405 break;
6406
6407 default:
6408 return;
6409 }
6410
6411 /* See what arguments we have and turn them into GCC trees for attribute
6412 handlers. These expect identifier for strings. We handle at most two
6413 arguments and static expressions only. */
6414 if (Present (gnat_arg) && Present (First (gnat_arg)))
6415 {
6416 Node_Id gnat_arg0 = Next (First (gnat_arg));
6417 Node_Id gnat_arg1 = Empty;
6418
6419 if (Present (gnat_arg0)
6420 && Is_OK_Static_Expression (Expression (gnat_arg0)))
6421 {
6422 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
6423
6424 if (TREE_CODE (gnu_arg0) == STRING_CST)
6425 {
6426 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
6427 if (IDENTIFIER_LENGTH (gnu_arg0) == 0)
6428 return;
6429 }
6430
6431 gnat_arg1 = Next (gnat_arg0);
6432 }
6433
6434 if (Present (gnat_arg1)
6435 && Is_OK_Static_Expression (Expression (gnat_arg1)))
6436 {
6437 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
6438
6439 if (TREE_CODE (gnu_arg1) == STRING_CST)
6440 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
6441 }
6442 }
6443
6444 /* Prepend to the list. Make a list of the argument we might have, as GCC
6445 expects it. */
6446 prepend_one_attribute (attr_list, etype, gnu_arg0,
6447 gnu_arg1
6448 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
6449 Present (Next (First (gnat_arg)))
6450 ? Expression (Next (First (gnat_arg))) : gnat_pragma);
6451 }
6452
6453 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
6454
6455 static void
prepend_attributes(struct attrib ** attr_list,Entity_Id gnat_entity)6456 prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity)
6457 {
6458 Node_Id gnat_temp;
6459
6460 /* Attributes are stored as Representation Item pragmas. */
6461 for (gnat_temp = First_Rep_Item (gnat_entity);
6462 Present (gnat_temp);
6463 gnat_temp = Next_Rep_Item (gnat_temp))
6464 if (Nkind (gnat_temp) == N_Pragma)
6465 prepend_one_attribute_pragma (attr_list, gnat_temp);
6466 }
6467
6468 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
6469 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
6470 return the GCC tree to use for that expression. S is the suffix to use
6471 if a variable needs to be created and DEFINITION is true if this is done
6472 for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
6473 otherwise, we are just elaborating the expression for side-effects. If
6474 NEED_DEBUG is true, we need a variable for debugging purposes even if it
6475 isn't needed for code generation. */
6476
6477 static tree
elaborate_expression(Node_Id gnat_expr,Entity_Id gnat_entity,const char * s,bool definition,bool need_value,bool need_debug)6478 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s,
6479 bool definition, bool need_value, bool need_debug)
6480 {
6481 tree gnu_expr;
6482
6483 /* If we already elaborated this expression (e.g. it was involved
6484 in the definition of a private type), use the old value. */
6485 if (present_gnu_tree (gnat_expr))
6486 return get_gnu_tree (gnat_expr);
6487
6488 /* If we don't need a value and this is static or a discriminant,
6489 we don't need to do anything. */
6490 if (!need_value
6491 && (Is_OK_Static_Expression (gnat_expr)
6492 || (Nkind (gnat_expr) == N_Identifier
6493 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
6494 return NULL_TREE;
6495
6496 /* If it's a static expression, we don't need a variable for debugging. */
6497 if (need_debug && Is_OK_Static_Expression (gnat_expr))
6498 need_debug = false;
6499
6500 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
6501 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s,
6502 definition, need_debug);
6503
6504 /* Save the expression in case we try to elaborate this entity again. Since
6505 it's not a DECL, don't check it. Don't save if it's a discriminant. */
6506 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
6507 save_gnu_tree (gnat_expr, gnu_expr, true);
6508
6509 return need_value ? gnu_expr : error_mark_node;
6510 }
6511
6512 /* Similar, but take a GNU expression and always return a result. */
6513
6514 static tree
elaborate_expression_1(tree gnu_expr,Entity_Id gnat_entity,const char * s,bool definition,bool need_debug)6515 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6516 bool definition, bool need_debug)
6517 {
6518 const bool expr_public_p = Is_Public (gnat_entity);
6519 const bool expr_global_p = expr_public_p || global_bindings_p ();
6520 bool expr_variable_p, use_variable;
6521
6522 /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
6523 that an expression cannot contain both a discriminant and a variable. */
6524 if (CONTAINS_PLACEHOLDER_P (gnu_expr))
6525 return gnu_expr;
6526
6527 /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
6528 a variable that is initialized to contain the expression when the package
6529 containing the definition is elaborated. If this entity is defined at top
6530 level, replace the expression by the variable; otherwise use a SAVE_EXPR
6531 if this is necessary. */
6532 if (TREE_CONSTANT (gnu_expr))
6533 expr_variable_p = false;
6534 else
6535 {
6536 /* Skip any conversions and simple constant arithmetics to see if the
6537 expression is based on a read-only variable. */
6538 tree inner = remove_conversions (gnu_expr, true);
6539
6540 inner = skip_simple_constant_arithmetic (inner);
6541
6542 if (handled_component_p (inner))
6543 inner = get_inner_constant_reference (inner);
6544
6545 expr_variable_p
6546 = !(inner
6547 && TREE_CODE (inner) == VAR_DECL
6548 && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
6549 }
6550
6551 /* We only need to use the variable if we are in a global context since GCC
6552 can do the right thing in the local case. However, when not optimizing,
6553 use it for bounds of loop iteration scheme to avoid code duplication. */
6554 use_variable = expr_variable_p
6555 && (expr_global_p
6556 || (!optimize
6557 && definition
6558 && Is_Itype (gnat_entity)
6559 && Nkind (Associated_Node_For_Itype (gnat_entity))
6560 == N_Loop_Parameter_Specification));
6561
6562 /* Now create it, possibly only for debugging purposes. */
6563 if (use_variable || need_debug)
6564 {
6565 /* The following variable creation can happen when processing the body
6566 of subprograms that are defined out of the extended main unit and
6567 inlined. In this case, we are not at the global scope, and thus the
6568 new variable must not be tagged "external", as we used to do here as
6569 soon as DEFINITION was false. */
6570 tree gnu_decl
6571 = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE,
6572 TREE_TYPE (gnu_expr), gnu_expr, true,
6573 expr_public_p, !definition && expr_global_p,
6574 expr_global_p, false, true, need_debug,
6575 NULL, gnat_entity);
6576
6577 /* Using this variable at debug time (if need_debug is true) requires a
6578 proper location. The back-end will compute a location for this
6579 variable only if the variable is used by the generated code.
6580 Returning the variable ensures the caller will use it in generated
6581 code. Note that there is no need for a location if the debug info
6582 contains an integer constant.
6583 TODO: when the encoding-based debug scheme is dropped, move this
6584 condition to the top-level IF block: we will not need to create a
6585 variable anymore in such cases, then. */
6586 if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr)))
6587 return gnu_decl;
6588 }
6589
6590 return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
6591 }
6592
6593 /* Similar, but take an alignment factor and make it explicit in the tree. */
6594
6595 static tree
elaborate_expression_2(tree gnu_expr,Entity_Id gnat_entity,const char * s,bool definition,bool need_debug,unsigned int align)6596 elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s,
6597 bool definition, bool need_debug, unsigned int align)
6598 {
6599 tree unit_align = size_int (align / BITS_PER_UNIT);
6600 return
6601 size_binop (MULT_EXPR,
6602 elaborate_expression_1 (size_binop (EXACT_DIV_EXPR,
6603 gnu_expr,
6604 unit_align),
6605 gnat_entity, s, definition,
6606 need_debug),
6607 unit_align);
6608 }
6609
6610 /* Structure to hold internal data for elaborate_reference. */
6611
6612 struct er_data
6613 {
6614 Entity_Id entity;
6615 bool definition;
6616 unsigned int n;
6617 };
6618
6619 /* Wrapper function around elaborate_expression_1 for elaborate_reference. */
6620
6621 static tree
elaborate_reference_1(tree ref,void * data)6622 elaborate_reference_1 (tree ref, void *data)
6623 {
6624 struct er_data *er = (struct er_data *)data;
6625 char suffix[16];
6626
6627 /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */
6628 if (TREE_CONSTANT (ref))
6629 return ref;
6630
6631 /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat
6632 pointer. This may be more efficient, but will also allow us to more
6633 easily find the match for the PLACEHOLDER_EXPR. */
6634 if (TREE_CODE (ref) == COMPONENT_REF
6635 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
6636 return build3 (COMPONENT_REF, TREE_TYPE (ref),
6637 elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
6638 TREE_OPERAND (ref, 1), NULL_TREE);
6639
6640 sprintf (suffix, "EXP%d", ++er->n);
6641 return
6642 elaborate_expression_1 (ref, er->entity, suffix, er->definition, false);
6643 }
6644
6645 /* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY.
6646 DEFINITION is true if this is done for a definition of GNAT_ENTITY and
6647 INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */
6648
6649 static tree
elaborate_reference(tree ref,Entity_Id gnat_entity,bool definition,tree * init)6650 elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
6651 tree *init)
6652 {
6653 struct er_data er = { gnat_entity, definition, 0 };
6654 return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init);
6655 }
6656
6657 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6658 the value passed against the list of choices. */
6659
6660 static tree
choices_to_gnu(tree gnu_operand,Node_Id gnat_choices)6661 choices_to_gnu (tree gnu_operand, Node_Id gnat_choices)
6662 {
6663 tree gnu_result = boolean_false_node, gnu_type;
6664
6665 gnu_operand = maybe_character_value (gnu_operand);
6666 gnu_type = TREE_TYPE (gnu_operand);
6667
6668 for (Node_Id gnat_choice = First (gnat_choices);
6669 Present (gnat_choice);
6670 gnat_choice = Next (gnat_choice))
6671 {
6672 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
6673 tree gnu_test;
6674
6675 switch (Nkind (gnat_choice))
6676 {
6677 case N_Range:
6678 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
6679 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
6680 break;
6681
6682 case N_Subtype_Indication:
6683 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
6684 (Constraint (gnat_choice))));
6685 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
6686 (Constraint (gnat_choice))));
6687 break;
6688
6689 case N_Identifier:
6690 case N_Expanded_Name:
6691 /* This represents either a subtype range or a static value of
6692 some kind; Ekind says which. */
6693 if (Is_Type (Entity (gnat_choice)))
6694 {
6695 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
6696
6697 gnu_low = TYPE_MIN_VALUE (gnu_type);
6698 gnu_high = TYPE_MAX_VALUE (gnu_type);
6699 break;
6700 }
6701
6702 /* ... fall through ... */
6703
6704 case N_Character_Literal:
6705 case N_Integer_Literal:
6706 gnu_low = gnat_to_gnu (gnat_choice);
6707 break;
6708
6709 case N_Others_Choice:
6710 break;
6711
6712 default:
6713 gcc_unreachable ();
6714 }
6715
6716 /* Everything should be folded into constants at this point. */
6717 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
6718 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
6719
6720 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
6721 gnu_low = convert (gnu_type, gnu_low);
6722 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
6723 gnu_high = convert (gnu_type, gnu_high);
6724
6725 if (gnu_low && gnu_high)
6726 gnu_test
6727 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
6728 build_binary_op (GE_EXPR, boolean_type_node,
6729 gnu_operand, gnu_low, true),
6730 build_binary_op (LE_EXPR, boolean_type_node,
6731 gnu_operand, gnu_high, true),
6732 true);
6733 else if (gnu_low)
6734 gnu_test
6735 = build_binary_op (EQ_EXPR, boolean_type_node, gnu_operand, gnu_low,
6736 true);
6737 else
6738 gnu_test = boolean_true_node;
6739
6740 if (gnu_result == boolean_false_node)
6741 gnu_result = gnu_test;
6742 else
6743 gnu_result
6744 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_result,
6745 gnu_test, true);
6746 }
6747
6748 return gnu_result;
6749 }
6750
6751 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6752 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6753
6754 static int
adjust_packed(tree field_type,tree record_type,int packed)6755 adjust_packed (tree field_type, tree record_type, int packed)
6756 {
6757 /* If the field contains an item of variable size, we cannot pack it
6758 because we cannot create temporaries of non-fixed size in case
6759 we need to take the address of the field. See addressable_p and
6760 the notes on the addressability issues for further details. */
6761 if (type_has_variable_size (field_type))
6762 return 0;
6763
6764 /* In the other cases, we can honor the packing. */
6765 if (packed)
6766 return packed;
6767
6768 /* If the alignment of the record is specified and the field type
6769 is over-aligned, request Storage_Unit alignment for the field. */
6770 if (TYPE_ALIGN (record_type)
6771 && TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6772 return -1;
6773
6774 /* Likewise if the maximum alignment of the record is specified. */
6775 if (TYPE_MAX_ALIGN (record_type)
6776 && TYPE_ALIGN (field_type) > TYPE_MAX_ALIGN (record_type))
6777 return -1;
6778
6779 return 0;
6780 }
6781
6782 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6783 placed in GNU_RECORD_TYPE.
6784
6785 PACKED is 1 if the enclosing record is packed or -1 if the enclosing
6786 record has Component_Alignment of Storage_Unit.
6787
6788 DEFINITION is true if this field is for a record being defined.
6789
6790 DEBUG_INFO_P is true if we need to write debug information for types
6791 that we may create in the process. */
6792
6793 static tree
gnat_to_gnu_field(Entity_Id gnat_field,tree gnu_record_type,int packed,bool definition,bool debug_info_p)6794 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6795 bool definition, bool debug_info_p)
6796 {
6797 const Entity_Id gnat_record_type = Underlying_Type (Scope (gnat_field));
6798 const Entity_Id gnat_field_type = Etype (gnat_field);
6799 const bool is_atomic
6800 = (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type));
6801 const bool is_aliased = Is_Aliased (gnat_field);
6802 const bool is_independent
6803 = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
6804 const bool is_volatile
6805 = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
6806 const bool is_strict_alignment = Strict_Alignment (gnat_field_type);
6807 /* We used to consider that volatile fields also require strict alignment,
6808 but that was an interpolation and would cause us to reject a pragma
6809 volatile on a packed record type containing boolean components, while
6810 there is no basis to do so in the RM. In such cases, the writes will
6811 involve load-modify-store sequences, but that's OK for volatile. The
6812 only constraint is the implementation advice whereby only the bits of
6813 the components should be accessed if they both start and end on byte
6814 boundaries, but that should be guaranteed by the GCC memory model. */
6815 const bool needs_strict_alignment
6816 = (is_atomic || is_aliased || is_independent || is_strict_alignment);
6817 tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
6818 tree gnu_field_id = get_entity_name (gnat_field);
6819 tree gnu_field, gnu_size, gnu_pos;
6820
6821 /* If this field requires strict alignment, we cannot pack it because
6822 it would very likely be under-aligned in the record. */
6823 if (needs_strict_alignment)
6824 packed = 0;
6825 else
6826 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6827
6828 /* If a size is specified, use it. Otherwise, if the record type is packed,
6829 use the official RM size. See "Handling of Type'Size Values" in Einfo
6830 for further details. */
6831 if (Known_Esize (gnat_field))
6832 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6833 gnat_field, FIELD_DECL, false, true);
6834 else if (packed == 1)
6835 gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
6836 gnat_field, FIELD_DECL, false, true);
6837 else
6838 gnu_size = NULL_TREE;
6839
6840 /* If we have a specified size that is smaller than that of the field's type,
6841 or a position is specified, and the field's type is a record that doesn't
6842 require strict alignment, see if we can get either an integral mode form
6843 of the type or a smaller form. If we can, show a size was specified for
6844 the field if there wasn't one already, so we know to make this a bitfield
6845 and avoid making things wider.
6846
6847 Changing to an integral mode form is useful when the record is packed as
6848 we can then place the field at a non-byte-aligned position and so achieve
6849 tighter packing. This is in addition required if the field shares a byte
6850 with another field and the front-end lets the back-end handle the access
6851 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6852
6853 Changing to a smaller form is required if the specified size is smaller
6854 than that of the field's type and the type contains sub-fields that are
6855 padded, in order to avoid generating accesses to these sub-fields that
6856 are wider than the field.
6857
6858 We avoid the transformation if it is not required or potentially useful,
6859 as it might entail an increase of the field's alignment and have ripple
6860 effects on the outer record type. A typical case is a field known to be
6861 byte-aligned and not to share a byte with another field. */
6862 if (!needs_strict_alignment
6863 && RECORD_OR_UNION_TYPE_P (gnu_field_type)
6864 && !TYPE_FAT_POINTER_P (gnu_field_type)
6865 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))
6866 && (packed == 1
6867 || (gnu_size
6868 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6869 || (Present (Component_Clause (gnat_field))
6870 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6871 % BITS_PER_UNIT == 0
6872 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6873 {
6874 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6875 if (gnu_packable_type != gnu_field_type)
6876 {
6877 gnu_field_type = gnu_packable_type;
6878 if (!gnu_size)
6879 gnu_size = rm_size (gnu_field_type);
6880 }
6881 }
6882
6883 if (Is_Atomic_Or_VFA (gnat_field))
6884 {
6885 const unsigned int align
6886 = promote_object_alignment (gnu_field_type, gnat_field);
6887 if (align > 0)
6888 gnu_field_type
6889 = maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field,
6890 false, false, definition, true);
6891 check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
6892 }
6893
6894 if (Present (Component_Clause (gnat_field)))
6895 {
6896 Node_Id gnat_clause = Component_Clause (gnat_field);
6897 Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
6898
6899 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6900 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6901 gnat_field, FIELD_DECL, false, true);
6902
6903 /* Ensure the position does not overlap with the parent subtype, if there
6904 is one. This test is omitted if the parent of the tagged type has a
6905 full rep clause since, in this case, component clauses are allowed to
6906 overlay the space allocated for the parent type and the front-end has
6907 checked that there are no overlapping components. */
6908 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6909 {
6910 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6911
6912 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6913 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6914 post_error_ne_tree
6915 ("offset of& must be beyond parent{, minimum allowed is ^}",
6916 Position (gnat_clause), gnat_field, TYPE_SIZE_UNIT (gnu_parent));
6917 }
6918
6919 /* If this field needs strict alignment, make sure that the record is
6920 sufficiently aligned and that the position and size are consistent
6921 with the type. But don't do it if we are just annotating types and
6922 the field's type is tagged, since tagged types aren't fully laid out
6923 in this mode. Also, note that atomic implies volatile so the inner
6924 test sequences ordering is significant here. */
6925 if (needs_strict_alignment
6926 && !(type_annotate_only && Is_Tagged_Type (gnat_field_type)))
6927 {
6928 const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
6929
6930 if (TYPE_ALIGN (gnu_record_type)
6931 && TYPE_ALIGN (gnu_record_type) < type_align)
6932 SET_TYPE_ALIGN (gnu_record_type, type_align);
6933
6934 /* If the position is not a multiple of the alignment of the type,
6935 then error out and reset the position. */
6936 if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
6937 bitsize_int (type_align))))
6938 {
6939 const char *s;
6940
6941 if (is_atomic)
6942 s = "position of atomic field& must be multiple of ^ bits";
6943 else if (is_aliased)
6944 s = "position of aliased field& must be multiple of ^ bits";
6945 else if (is_independent)
6946 s = "position of independent field& must be multiple of ^ bits";
6947 else if (is_strict_alignment)
6948 s = "position of & with aliased or tagged part must be"
6949 " multiple of ^ bits";
6950 else
6951 gcc_unreachable ();
6952
6953 post_error_ne_num (s, First_Bit (gnat_clause), gnat_field,
6954 type_align);
6955 gnu_pos = NULL_TREE;
6956 }
6957
6958 if (gnu_size)
6959 {
6960 tree gnu_type_size = TYPE_SIZE (gnu_field_type);
6961 const int cmp = tree_int_cst_compare (gnu_size, gnu_type_size);
6962
6963 /* If the size is lower than that of the type, or greater for
6964 atomic and aliased, then error out and reset the size. */
6965 if (cmp < 0 || (cmp > 0 && (is_atomic || is_aliased)))
6966 {
6967 const char *s;
6968
6969 if (is_atomic)
6970 s = "size of atomic field& must be ^ bits";
6971 else if (is_aliased)
6972 s = "size of aliased field& must be ^ bits";
6973 else if (is_independent)
6974 s = "size of independent field& must be at least ^ bits";
6975 else if (is_strict_alignment)
6976 s = "size of & with aliased or tagged part must be"
6977 " at least ^ bits";
6978 else
6979 gcc_unreachable ();
6980
6981 post_error_ne_tree (s, Last_Bit (gnat_clause), gnat_field,
6982 gnu_type_size);
6983 gnu_size = NULL_TREE;
6984 }
6985
6986 /* Likewise if the size is not a multiple of a byte, */
6987 else if (!integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
6988 bitsize_unit_node)))
6989 {
6990 const char *s;
6991
6992 if (is_independent)
6993 s = "size of independent field& must be multiple of"
6994 " Storage_Unit";
6995 else if (is_strict_alignment)
6996 s = "size of & with aliased or tagged part must be"
6997 " multiple of Storage_Unit";
6998 else
6999 gcc_unreachable ();
7000
7001 post_error_ne (s, Last_Bit (gnat_clause), gnat_field);
7002 gnu_size = NULL_TREE;
7003 }
7004 }
7005 }
7006 }
7007
7008 /* If the record has rep clauses and this is the tag field, make a rep
7009 clause for it as well. */
7010 else if (Has_Specified_Layout (gnat_record_type)
7011 && Chars (gnat_field) == Name_uTag)
7012 {
7013 gnu_pos = bitsize_zero_node;
7014 gnu_size = TYPE_SIZE (gnu_field_type);
7015 }
7016
7017 else
7018 {
7019 gnu_pos = NULL_TREE;
7020
7021 /* If we are packing the record and the field is BLKmode, round the
7022 size up to a byte boundary. */
7023 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
7024 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
7025 }
7026
7027 /* We need to make the size the maximum for the type if it is
7028 self-referential and an unconstrained type. In that case, we can't
7029 pack the field since we can't make a copy to align it. */
7030 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
7031 && !gnu_size
7032 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
7033 && !Is_Constrained (Underlying_Type (gnat_field_type)))
7034 {
7035 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
7036 packed = 0;
7037 }
7038
7039 /* If a size is specified, adjust the field's type to it. */
7040 if (gnu_size)
7041 {
7042 tree orig_field_type;
7043
7044 /* If the field's type is justified modular, we would need to remove
7045 the wrapper to (better) meet the layout requirements. However we
7046 can do so only if the field is not aliased to preserve the unique
7047 layout, if it has the same storage order as the enclosing record
7048 and if the prescribed size is not greater than that of the packed
7049 array to preserve the justification. */
7050 if (!needs_strict_alignment
7051 && TREE_CODE (gnu_field_type) == RECORD_TYPE
7052 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
7053 && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type)
7054 == Reverse_Storage_Order (gnat_record_type)
7055 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
7056 <= 0)
7057 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7058
7059 /* Similarly if the field's type is a misaligned integral type, but
7060 there is no restriction on the size as there is no justification. */
7061 if (!needs_strict_alignment
7062 && TYPE_IS_PADDING_P (gnu_field_type)
7063 && INTEGRAL_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_field_type))))
7064 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
7065
7066 gnu_field_type
7067 = make_type_from_size (gnu_field_type, gnu_size,
7068 Has_Biased_Representation (gnat_field));
7069
7070 orig_field_type = gnu_field_type;
7071 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
7072 false, false, definition, true);
7073
7074 /* If a padding record was made, declare it now since it will never be
7075 declared otherwise. This is necessary to ensure that its subtrees
7076 are properly marked. */
7077 if (gnu_field_type != orig_field_type
7078 && !DECL_P (TYPE_NAME (gnu_field_type)))
7079 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, true,
7080 debug_info_p, gnat_field);
7081 }
7082
7083 /* Otherwise (or if there was an error), don't specify a position. */
7084 else
7085 gnu_pos = NULL_TREE;
7086
7087 /* If the field's type is a padded type made for a scalar field of a record
7088 type with reverse storage order, we need to propagate the reverse storage
7089 order to the padding type since it is the innermost enclosing aggregate
7090 type around the scalar. */
7091 if (TYPE_IS_PADDING_P (gnu_field_type)
7092 && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type)
7093 && Is_Scalar_Type (gnat_field_type))
7094 gnu_field_type = set_reverse_storage_order_on_pad_type (gnu_field_type);
7095
7096 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
7097 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
7098
7099 /* Now create the decl for the field. */
7100 gnu_field
7101 = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
7102 gnu_size, gnu_pos, packed, is_aliased);
7103 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
7104 DECL_ALIASED_P (gnu_field) = is_aliased;
7105 TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile;
7106
7107 if (Ekind (gnat_field) == E_Discriminant)
7108 {
7109 DECL_INVARIANT_P (gnu_field)
7110 = No (Discriminant_Default_Value (gnat_field));
7111 DECL_DISCRIMINANT_NUMBER (gnu_field)
7112 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
7113 }
7114
7115 return gnu_field;
7116 }
7117
7118 /* Return true if at least one member of COMPONENT_LIST needs strict
7119 alignment. */
7120
7121 static bool
components_need_strict_alignment(Node_Id component_list)7122 components_need_strict_alignment (Node_Id component_list)
7123 {
7124 Node_Id component_decl;
7125
7126 for (component_decl = First_Non_Pragma (Component_Items (component_list));
7127 Present (component_decl);
7128 component_decl = Next_Non_Pragma (component_decl))
7129 {
7130 Entity_Id gnat_field = Defining_Entity (component_decl);
7131
7132 if (Is_Aliased (gnat_field))
7133 return true;
7134
7135 if (Strict_Alignment (Etype (gnat_field)))
7136 return true;
7137 }
7138
7139 return false;
7140 }
7141
7142 /* Return true if TYPE is a type with variable size or a padding type with a
7143 field of variable size or a record that has a field with such a type. */
7144
7145 static bool
type_has_variable_size(tree type)7146 type_has_variable_size (tree type)
7147 {
7148 tree field;
7149
7150 if (!TREE_CONSTANT (TYPE_SIZE (type)))
7151 return true;
7152
7153 if (TYPE_IS_PADDING_P (type)
7154 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
7155 return true;
7156
7157 if (!RECORD_OR_UNION_TYPE_P (type))
7158 return false;
7159
7160 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
7161 if (type_has_variable_size (TREE_TYPE (field)))
7162 return true;
7163
7164 return false;
7165 }
7166
7167 /* Return true if FIELD is an artificial field. */
7168
7169 static bool
field_is_artificial(tree field)7170 field_is_artificial (tree field)
7171 {
7172 /* These fields are generated by the front-end proper. */
7173 if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
7174 return true;
7175
7176 /* These fields are generated by gigi. */
7177 if (DECL_INTERNAL_P (field))
7178 return true;
7179
7180 return false;
7181 }
7182
7183 /* Return true if FIELD is a non-artificial field with self-referential
7184 size. */
7185
7186 static bool
field_has_self_size(tree field)7187 field_has_self_size (tree field)
7188 {
7189 if (field_is_artificial (field))
7190 return false;
7191
7192 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7193 return false;
7194
7195 return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
7196 }
7197
7198 /* Return true if FIELD is a non-artificial field with variable size. */
7199
7200 static bool
field_has_variable_size(tree field)7201 field_has_variable_size (tree field)
7202 {
7203 if (field_is_artificial (field))
7204 return false;
7205
7206 if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
7207 return false;
7208
7209 return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
7210 }
7211
7212 /* qsort comparer for the bit positions of two record components. */
7213
7214 static int
compare_field_bitpos(const PTR rt1,const PTR rt2)7215 compare_field_bitpos (const PTR rt1, const PTR rt2)
7216 {
7217 const_tree const field1 = * (const_tree const *) rt1;
7218 const_tree const field2 = * (const_tree const *) rt2;
7219 const int ret
7220 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
7221
7222 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
7223 }
7224
7225 /* Reverse function from gnat_to_gnu_field: return the GNAT field present in
7226 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and
7227 corresponding to the GNU tree GNU_FIELD. */
7228
7229 static Entity_Id
gnu_field_to_gnat(tree gnu_field,Node_Id gnat_component_list,Entity_Id gnat_record_type)7230 gnu_field_to_gnat (tree gnu_field, Node_Id gnat_component_list,
7231 Entity_Id gnat_record_type)
7232 {
7233 Entity_Id gnat_component_decl, gnat_field;
7234
7235 if (Present (Component_Items (gnat_component_list)))
7236 for (gnat_component_decl
7237 = First_Non_Pragma (Component_Items (gnat_component_list));
7238 Present (gnat_component_decl);
7239 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
7240 {
7241 gnat_field = Defining_Entity (gnat_component_decl);
7242 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
7243 return gnat_field;
7244 }
7245
7246 if (Has_Discriminants (gnat_record_type))
7247 for (gnat_field = First_Stored_Discriminant (gnat_record_type);
7248 Present (gnat_field);
7249 gnat_field = Next_Stored_Discriminant (gnat_field))
7250 if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
7251 return gnat_field;
7252
7253 return Empty;
7254 }
7255
7256 /* Issue a warning for the problematic placement of GNU_FIELD present in
7257 either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE.
7258 IN_VARIANT is true if GNAT_COMPONENT_LIST is the list of a variant.
7259 DO_REORDER is true if fields of GNAT_RECORD_TYPE are being reordered. */
7260
7261 static void
warn_on_field_placement(tree gnu_field,Node_Id gnat_component_list,Entity_Id gnat_record_type,bool in_variant,bool do_reorder)7262 warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list,
7263 Entity_Id gnat_record_type, bool in_variant,
7264 bool do_reorder)
7265 {
7266 if (!Comes_From_Source (gnat_record_type))
7267 return;
7268
7269 Entity_Id gnat_field
7270 = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type);
7271 gcc_assert (Present (gnat_field));
7272
7273 const char *msg1
7274 = in_variant
7275 ? "?variant layout may cause performance issues"
7276 : "?record layout may cause performance issues";
7277 const char *msg2
7278 = Ekind (gnat_field) == E_Discriminant
7279 ? "?discriminant & whose length is not multiple of a byte"
7280 : field_has_self_size (gnu_field)
7281 ? "?component & whose length depends on a discriminant"
7282 : field_has_variable_size (gnu_field)
7283 ? "?component & whose length is not fixed"
7284 : "?component & whose length is not multiple of a byte";
7285 const char *msg3
7286 = do_reorder
7287 ? "?comes too early and was moved down"
7288 : "?comes too early and ought to be moved down";
7289
7290 post_error (msg1, gnat_field);
7291 post_error_ne (msg2, gnat_field, gnat_field);
7292 post_error (msg3, gnat_field);
7293 }
7294
7295 /* Likewise but for every field present on GNU_FIELD_LIST. */
7296
7297 static void
warn_on_list_placement(tree gnu_field_list,Node_Id gnat_component_list,Entity_Id gnat_record_type,bool in_variant,bool do_reorder)7298 warn_on_list_placement (tree gnu_field_list, Node_Id gnat_component_list,
7299 Entity_Id gnat_record_type, bool in_variant,
7300 bool do_reorder)
7301 {
7302 for (tree gnu_tmp = gnu_field_list; gnu_tmp; gnu_tmp = DECL_CHAIN (gnu_tmp))
7303 warn_on_field_placement (gnu_tmp, gnat_component_list, gnat_record_type,
7304 in_variant, do_reorder);
7305 }
7306
7307 /* Structure holding information for a given variant. */
7308 typedef struct vinfo
7309 {
7310 /* The record type of the variant. */
7311 tree type;
7312
7313 /* The name of the variant. */
7314 tree name;
7315
7316 /* The qualifier of the variant. */
7317 tree qual;
7318
7319 /* Whether the variant has a rep clause. */
7320 bool has_rep;
7321
7322 /* Whether the variant is packed. */
7323 bool packed;
7324
7325 } vinfo_t;
7326
7327 /* Translate and chain GNAT_COMPONENT_LIST present in GNAT_RECORD_TYPE to
7328 GNU_FIELD_LIST, set the result as the field list of GNU_RECORD_TYPE and
7329 finish it up. Return true if GNU_RECORD_TYPE has a rep clause that affects
7330 the layout (see below). When called from gnat_to_gnu_entity during the
7331 processing of a record definition, the GCC node for the parent, if any,
7332 will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
7333 discriminants will be on GNU_FIELD_LIST. The other call to this function
7334 is a recursive call for the component list of a variant and, in this case,
7335 GNU_FIELD_LIST is empty.
7336
7337 PACKED is 1 if this is for a packed record or -1 if this is for a record
7338 with Component_Alignment of Storage_Unit.
7339
7340 DEFINITION is true if we are defining this record type.
7341
7342 CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
7343 out the record. This means the alignment only serves to force fields to
7344 be bitfields, but not to require the record to be that aligned. This is
7345 used for variants.
7346
7347 ALL_REP is true if a rep clause is present for all the fields.
7348
7349 UNCHECKED_UNION is true if we are building this type for a record with a
7350 Pragma Unchecked_Union.
7351
7352 ARTIFICIAL is true if this is a type that was generated by the compiler.
7353
7354 DEBUG_INFO is true if we need to write debug information about the type.
7355
7356 MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
7357 mean that its contents may be unused as well, only the container itself.
7358
7359 FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
7360 the outer record type down to this variant level. It is nonzero only if
7361 all the fields down to this level have a rep clause and ALL_REP is false.
7362
7363 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
7364 with a rep clause is to be added; in this case, that is all that should
7365 be done with such fields and the return value will be false. */
7366
7367 static bool
components_to_record(Node_Id gnat_component_list,Entity_Id gnat_record_type,tree gnu_field_list,tree gnu_record_type,int packed,bool definition,bool cancel_alignment,bool all_rep,bool unchecked_union,bool artificial,bool debug_info,bool maybe_unused,tree first_free_pos,tree * p_gnu_rep_list)7368 components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
7369 tree gnu_field_list, tree gnu_record_type, int packed,
7370 bool definition, bool cancel_alignment, bool all_rep,
7371 bool unchecked_union, bool artificial, bool debug_info,
7372 bool maybe_unused, tree first_free_pos,
7373 tree *p_gnu_rep_list)
7374 {
7375 const bool needs_xv_encodings
7376 = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL;
7377 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
7378 bool variants_have_rep = all_rep;
7379 bool layout_with_rep = false;
7380 bool has_self_field = false;
7381 bool has_aliased_after_self_field = false;
7382 Entity_Id gnat_component_decl, gnat_variant_part;
7383 tree gnu_field, gnu_next, gnu_last;
7384 tree gnu_variant_part = NULL_TREE;
7385 tree gnu_rep_list = NULL_TREE;
7386
7387 /* For each component referenced in a component declaration create a GCC
7388 field and add it to the list, skipping pragmas in the GNAT list. */
7389 gnu_last = tree_last (gnu_field_list);
7390 if (Present (Component_Items (gnat_component_list)))
7391 for (gnat_component_decl
7392 = First_Non_Pragma (Component_Items (gnat_component_list));
7393 Present (gnat_component_decl);
7394 gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
7395 {
7396 Entity_Id gnat_field = Defining_Entity (gnat_component_decl);
7397 Name_Id gnat_name = Chars (gnat_field);
7398
7399 /* If present, the _Parent field must have been created as the single
7400 field of the record type. Put it before any other fields. */
7401 if (gnat_name == Name_uParent)
7402 {
7403 gnu_field = TYPE_FIELDS (gnu_record_type);
7404 gnu_field_list = chainon (gnu_field_list, gnu_field);
7405 }
7406 else
7407 {
7408 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
7409 definition, debug_info);
7410
7411 /* If this is the _Tag field, put it before any other fields. */
7412 if (gnat_name == Name_uTag)
7413 gnu_field_list = chainon (gnu_field_list, gnu_field);
7414
7415 /* If this is the _Controller field, put it before the other
7416 fields except for the _Tag or _Parent field. */
7417 else if (gnat_name == Name_uController && gnu_last)
7418 {
7419 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
7420 DECL_CHAIN (gnu_last) = gnu_field;
7421 }
7422
7423 /* If this is a regular field, put it after the other fields. */
7424 else
7425 {
7426 DECL_CHAIN (gnu_field) = gnu_field_list;
7427 gnu_field_list = gnu_field;
7428 if (!gnu_last)
7429 gnu_last = gnu_field;
7430
7431 /* And record information for the final layout. */
7432 if (field_has_self_size (gnu_field))
7433 has_self_field = true;
7434 else if (has_self_field && DECL_ALIASED_P (gnu_field))
7435 has_aliased_after_self_field = true;
7436 }
7437 }
7438
7439 save_gnu_tree (gnat_field, gnu_field, false);
7440 }
7441
7442 /* At the end of the component list there may be a variant part. */
7443 gnat_variant_part = Variant_Part (gnat_component_list);
7444
7445 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
7446 mutually exclusive and should go in the same memory. To do this we need
7447 to treat each variant as a record whose elements are created from the
7448 component list for the variant. So here we create the records from the
7449 lists for the variants and put them all into the QUAL_UNION_TYPE.
7450 If this is an Unchecked_Union, we make a UNION_TYPE instead or
7451 use GNU_RECORD_TYPE if there are no fields so far. */
7452 if (Present (gnat_variant_part))
7453 {
7454 Node_Id gnat_discr = Name (gnat_variant_part), variant;
7455 tree gnu_discr = gnat_to_gnu (gnat_discr);
7456 tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
7457 tree gnu_var_name
7458 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
7459 "XVN");
7460 tree gnu_union_type, gnu_union_name;
7461 tree this_first_free_pos, gnu_variant_list = NULL_TREE;
7462 bool union_field_needs_strict_alignment = false;
7463 auto_vec <vinfo_t, 16> variant_types;
7464 vinfo_t *gnu_variant;
7465 unsigned int variants_align = 0;
7466 unsigned int i;
7467
7468 gnu_union_name
7469 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
7470
7471 /* Reuse the enclosing union if this is an Unchecked_Union whose fields
7472 are all in the variant part, to match the layout of C unions. There
7473 is an associated check below. */
7474 if (TREE_CODE (gnu_record_type) == UNION_TYPE)
7475 gnu_union_type = gnu_record_type;
7476 else
7477 {
7478 gnu_union_type
7479 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
7480
7481 TYPE_NAME (gnu_union_type) = gnu_union_name;
7482 SET_TYPE_ALIGN (gnu_union_type, 0);
7483 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
7484 TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
7485 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7486 }
7487
7488 /* If all the fields down to this level have a rep clause, find out
7489 whether all the fields at this level also have one. If so, then
7490 compute the new first free position to be passed downward. */
7491 this_first_free_pos = first_free_pos;
7492 if (this_first_free_pos)
7493 {
7494 for (gnu_field = gnu_field_list;
7495 gnu_field;
7496 gnu_field = DECL_CHAIN (gnu_field))
7497 if (DECL_FIELD_OFFSET (gnu_field))
7498 {
7499 tree pos = bit_position (gnu_field);
7500 if (!tree_int_cst_lt (pos, this_first_free_pos))
7501 this_first_free_pos
7502 = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
7503 }
7504 else
7505 {
7506 this_first_free_pos = NULL_TREE;
7507 break;
7508 }
7509 }
7510
7511 /* We build the variants in two passes. The bulk of the work is done in
7512 the first pass, that is to say translating the GNAT nodes, building
7513 the container types and computing the associated properties. However
7514 we cannot finish up the container types during this pass because we
7515 don't know where the variant part will be placed until the end. */
7516 for (variant = First_Non_Pragma (Variants (gnat_variant_part));
7517 Present (variant);
7518 variant = Next_Non_Pragma (variant))
7519 {
7520 tree gnu_variant_type = make_node (RECORD_TYPE);
7521 tree gnu_inner_name, gnu_qual;
7522 bool has_rep;
7523 int field_packed;
7524 vinfo_t vinfo;
7525
7526 Get_Variant_Encoding (variant);
7527 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
7528 TYPE_NAME (gnu_variant_type)
7529 = concat_name (gnu_union_name,
7530 IDENTIFIER_POINTER (gnu_inner_name));
7531
7532 /* Set the alignment of the inner type in case we need to make
7533 inner objects into bitfields, but then clear it out so the
7534 record actually gets only the alignment required. */
7535 SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
7536 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
7537 TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
7538 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
7539
7540 /* Similarly, if the outer record has a size specified and all
7541 the fields have a rep clause, we can propagate the size. */
7542 if (all_rep_and_size)
7543 {
7544 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
7545 TYPE_SIZE_UNIT (gnu_variant_type)
7546 = TYPE_SIZE_UNIT (gnu_record_type);
7547 }
7548
7549 /* Add the fields into the record type for the variant. Note that
7550 we aren't sure to really use it at this point, see below. */
7551 has_rep
7552 = components_to_record (Component_List (variant), gnat_record_type,
7553 NULL_TREE, gnu_variant_type, packed,
7554 definition, !all_rep_and_size, all_rep,
7555 unchecked_union, true, needs_xv_encodings,
7556 true, this_first_free_pos,
7557 all_rep || this_first_free_pos
7558 ? NULL : &gnu_rep_list);
7559
7560 /* Translate the qualifier and annotate the GNAT node. */
7561 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
7562 Set_Present_Expr (variant, annotate_value (gnu_qual));
7563
7564 /* Deal with packedness like in gnat_to_gnu_field. */
7565 if (components_need_strict_alignment (Component_List (variant)))
7566 {
7567 field_packed = 0;
7568 union_field_needs_strict_alignment = true;
7569 }
7570 else
7571 field_packed
7572 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
7573
7574 /* Push this variant onto the stack for the second pass. */
7575 vinfo.type = gnu_variant_type;
7576 vinfo.name = gnu_inner_name;
7577 vinfo.qual = gnu_qual;
7578 vinfo.has_rep = has_rep;
7579 vinfo.packed = field_packed;
7580 variant_types.safe_push (vinfo);
7581
7582 /* Compute the global properties that will determine the placement of
7583 the variant part. */
7584 variants_have_rep |= has_rep;
7585 if (!field_packed && TYPE_ALIGN (gnu_variant_type) > variants_align)
7586 variants_align = TYPE_ALIGN (gnu_variant_type);
7587 }
7588
7589 /* Round up the first free position to the alignment of the variant part
7590 for the variants without rep clause. This will guarantee a consistent
7591 layout independently of the placement of the variant part. */
7592 if (variants_have_rep && variants_align > 0 && this_first_free_pos)
7593 this_first_free_pos = round_up (this_first_free_pos, variants_align);
7594
7595 /* In the second pass, the container types are adjusted if necessary and
7596 finished up, then the corresponding fields of the variant part are
7597 built with their qualifier, unless this is an unchecked union. */
7598 FOR_EACH_VEC_ELT (variant_types, i, gnu_variant)
7599 {
7600 tree gnu_variant_type = gnu_variant->type;
7601 tree gnu_field_list = TYPE_FIELDS (gnu_variant_type);
7602
7603 /* If this is an Unchecked_Union whose fields are all in the variant
7604 part and we have a single field with no representation clause or
7605 placed at offset zero, use the field directly to match the layout
7606 of C unions. */
7607 if (TREE_CODE (gnu_record_type) == UNION_TYPE
7608 && gnu_field_list
7609 && !DECL_CHAIN (gnu_field_list)
7610 && (!DECL_FIELD_OFFSET (gnu_field_list)
7611 || integer_zerop (bit_position (gnu_field_list))))
7612 {
7613 gnu_field = gnu_field_list;
7614 DECL_CONTEXT (gnu_field) = gnu_record_type;
7615 }
7616 else
7617 {
7618 /* Finalize the variant type now. We used to throw away empty
7619 record types but we no longer do that because we need them to
7620 generate complete debug info for the variant; otherwise, the
7621 union type definition will be lacking the fields associated
7622 with these empty variants. */
7623 if (gnu_field_list && variants_have_rep && !gnu_variant->has_rep)
7624 {
7625 /* The variant part will be at offset 0 so we need to ensure
7626 that the fields are laid out starting from the first free
7627 position at this level. */
7628 tree gnu_rep_type = make_node (RECORD_TYPE);
7629 tree gnu_rep_part;
7630 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
7631 = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type);
7632 finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
7633 gnu_rep_part
7634 = create_rep_part (gnu_rep_type, gnu_variant_type,
7635 this_first_free_pos);
7636 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
7637 gnu_field_list = gnu_rep_part;
7638 finish_record_type (gnu_variant_type, gnu_field_list, 0,
7639 false);
7640 }
7641
7642 if (debug_info)
7643 rest_of_record_type_compilation (gnu_variant_type);
7644 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
7645 true, needs_xv_encodings, gnat_component_list);
7646
7647 gnu_field
7648 = create_field_decl (gnu_variant->name, gnu_variant_type,
7649 gnu_union_type,
7650 all_rep_and_size
7651 ? TYPE_SIZE (gnu_variant_type) : 0,
7652 variants_have_rep ? bitsize_zero_node : 0,
7653 gnu_variant->packed, 0);
7654
7655 DECL_INTERNAL_P (gnu_field) = 1;
7656
7657 if (!unchecked_union)
7658 DECL_QUALIFIER (gnu_field) = gnu_variant->qual;
7659 }
7660
7661 DECL_CHAIN (gnu_field) = gnu_variant_list;
7662 gnu_variant_list = gnu_field;
7663 }
7664
7665 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
7666 if (gnu_variant_list)
7667 {
7668 int union_field_packed;
7669
7670 if (all_rep_and_size)
7671 {
7672 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
7673 TYPE_SIZE_UNIT (gnu_union_type)
7674 = TYPE_SIZE_UNIT (gnu_record_type);
7675 }
7676
7677 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
7678 all_rep_and_size ? 1 : 0, needs_xv_encodings);
7679
7680 /* If GNU_UNION_TYPE is our record type, it means we must have an
7681 Unchecked_Union with no fields. Verify that and, if so, just
7682 return. */
7683 if (gnu_union_type == gnu_record_type)
7684 {
7685 gcc_assert (unchecked_union
7686 && !gnu_field_list
7687 && !gnu_rep_list);
7688 return variants_have_rep;
7689 }
7690
7691 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true,
7692 needs_xv_encodings, gnat_component_list);
7693
7694 /* Deal with packedness like in gnat_to_gnu_field. */
7695 if (union_field_needs_strict_alignment)
7696 union_field_packed = 0;
7697 else
7698 union_field_packed
7699 = adjust_packed (gnu_union_type, gnu_record_type, packed);
7700
7701 gnu_variant_part
7702 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
7703 all_rep_and_size
7704 ? TYPE_SIZE (gnu_union_type) : 0,
7705 variants_have_rep ? bitsize_zero_node : 0,
7706 union_field_packed, 0);
7707
7708 DECL_INTERNAL_P (gnu_variant_part) = 1;
7709 }
7710 }
7711
7712 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
7713 pull them out and put them onto the appropriate list.
7714
7715 Similarly, pull out the fields with zero size and no rep clause, as they
7716 would otherwise modify the layout and thus very likely run afoul of the
7717 Ada semantics, which are different from those of C here.
7718
7719 Finally, if there is an aliased field placed in the list after fields
7720 with self-referential size, pull out the latter in the same way.
7721
7722 Optionally, if the reordering mechanism is enabled, pull out the fields
7723 with self-referential size, variable size and fixed size not a multiple
7724 of a byte, so that they don't cause the regular fields to be either at
7725 self-referential/variable offset or misaligned. Note, in the latter
7726 case, that this can only happen in packed record types so the alignment
7727 is effectively capped to the byte for the whole record. But we don't
7728 do it for non-packed record types if pragma Optimize_Alignment (Space)
7729 is specified because this can prevent alignment gaps from being filled.
7730
7731 Optionally, if the layout warning is enabled, keep track of the above 4
7732 different kinds of fields and issue a warning if some of them would be
7733 (or are being) reordered by the reordering mechanism.
7734
7735 ??? If we reorder fields, the debugging information will be affected and
7736 the debugger print fields in a different order from the source code. */
7737 const bool do_reorder
7738 = (Convention (gnat_record_type) == Convention_Ada
7739 && !No_Reordering (gnat_record_type)
7740 && (!Optimize_Alignment_Space (gnat_record_type)
7741 || Is_Packed (gnat_record_type))
7742 && !debug__debug_flag_dot_r);
7743 const bool w_reorder
7744 = (Convention (gnat_record_type) == Convention_Ada
7745 && Warn_On_Questionable_Layout
7746 && !(No_Reordering (gnat_record_type) && GNAT_Mode));
7747 const bool in_variant = (p_gnu_rep_list != NULL);
7748 tree gnu_zero_list = NULL_TREE;
7749 tree gnu_self_list = NULL_TREE;
7750 tree gnu_var_list = NULL_TREE;
7751 tree gnu_bitp_list = NULL_TREE;
7752 tree gnu_tmp_bitp_list = NULL_TREE;
7753 unsigned int tmp_bitp_size = 0;
7754 unsigned int last_reorder_field_type = -1;
7755 unsigned int tmp_last_reorder_field_type = -1;
7756
7757 #define MOVE_FROM_FIELD_LIST_TO(LIST) \
7758 do { \
7759 if (gnu_last) \
7760 DECL_CHAIN (gnu_last) = gnu_next; \
7761 else \
7762 gnu_field_list = gnu_next; \
7763 \
7764 DECL_CHAIN (gnu_field) = (LIST); \
7765 (LIST) = gnu_field; \
7766 } while (0)
7767
7768 gnu_last = NULL_TREE;
7769 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
7770 {
7771 gnu_next = DECL_CHAIN (gnu_field);
7772
7773 if (DECL_FIELD_OFFSET (gnu_field))
7774 {
7775 MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
7776 continue;
7777 }
7778
7779 if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
7780 {
7781 DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
7782 SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
7783 DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
7784 if (DECL_ALIASED_P (gnu_field))
7785 SET_TYPE_ALIGN (gnu_record_type,
7786 MAX (TYPE_ALIGN (gnu_record_type),
7787 TYPE_ALIGN (TREE_TYPE (gnu_field))));
7788 MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
7789 continue;
7790 }
7791
7792 if (has_aliased_after_self_field && field_has_self_size (gnu_field))
7793 {
7794 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7795 continue;
7796 }
7797
7798 /* We don't need further processing in default mode. */
7799 if (!w_reorder && !do_reorder)
7800 {
7801 gnu_last = gnu_field;
7802 continue;
7803 }
7804
7805 if (field_has_self_size (gnu_field))
7806 {
7807 if (w_reorder)
7808 {
7809 if (last_reorder_field_type < 4)
7810 warn_on_field_placement (gnu_field, gnat_component_list,
7811 gnat_record_type, in_variant,
7812 do_reorder);
7813 else
7814 last_reorder_field_type = 4;
7815 }
7816
7817 if (do_reorder)
7818 {
7819 MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
7820 continue;
7821 }
7822 }
7823
7824 else if (field_has_variable_size (gnu_field))
7825 {
7826 if (w_reorder)
7827 {
7828 if (last_reorder_field_type < 3)
7829 warn_on_field_placement (gnu_field, gnat_component_list,
7830 gnat_record_type, in_variant,
7831 do_reorder);
7832 else
7833 last_reorder_field_type = 3;
7834 }
7835
7836 if (do_reorder)
7837 {
7838 MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
7839 continue;
7840 }
7841 }
7842
7843 else
7844 {
7845 /* If the field has no size, then it cannot be bit-packed. */
7846 const unsigned int bitp_size
7847 = DECL_SIZE (gnu_field)
7848 ? TREE_INT_CST_LOW (DECL_SIZE (gnu_field)) % BITS_PER_UNIT
7849 : 0;
7850
7851 /* If the field is bit-packed, we move it to a temporary list that
7852 contains the contiguously preceding bit-packed fields, because
7853 we want to be able to put them back if the misalignment happens
7854 to cancel itself after several bit-packed fields. */
7855 if (bitp_size != 0)
7856 {
7857 tmp_bitp_size = (tmp_bitp_size + bitp_size) % BITS_PER_UNIT;
7858
7859 if (last_reorder_field_type != 2)
7860 {
7861 tmp_last_reorder_field_type = last_reorder_field_type;
7862 last_reorder_field_type = 2;
7863 }
7864
7865 if (do_reorder)
7866 {
7867 MOVE_FROM_FIELD_LIST_TO (gnu_tmp_bitp_list);
7868 continue;
7869 }
7870 }
7871
7872 /* No more bit-packed fields, move the existing ones to the end or
7873 put them back at their original location. */
7874 else if (last_reorder_field_type == 2 || gnu_tmp_bitp_list)
7875 {
7876 last_reorder_field_type = 1;
7877
7878 if (tmp_bitp_size != 0)
7879 {
7880 if (w_reorder && tmp_last_reorder_field_type < 2)
7881 {
7882 if (gnu_tmp_bitp_list)
7883 warn_on_list_placement (gnu_tmp_bitp_list,
7884 gnat_component_list,
7885 gnat_record_type, in_variant,
7886 do_reorder);
7887 else
7888 warn_on_field_placement (gnu_last,
7889 gnat_component_list,
7890 gnat_record_type, in_variant,
7891 do_reorder);
7892 }
7893
7894 if (do_reorder)
7895 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
7896
7897 gnu_tmp_bitp_list = NULL_TREE;
7898 tmp_bitp_size = 0;
7899 }
7900 else
7901 {
7902 /* Rechain the temporary list in front of GNU_FIELD. */
7903 tree gnu_bitp_field = gnu_field;
7904 while (gnu_tmp_bitp_list)
7905 {
7906 tree gnu_bitp_next = DECL_CHAIN (gnu_tmp_bitp_list);
7907 DECL_CHAIN (gnu_tmp_bitp_list) = gnu_bitp_field;
7908 if (gnu_last)
7909 DECL_CHAIN (gnu_last) = gnu_tmp_bitp_list;
7910 else
7911 gnu_field_list = gnu_tmp_bitp_list;
7912 gnu_bitp_field = gnu_tmp_bitp_list;
7913 gnu_tmp_bitp_list = gnu_bitp_next;
7914 }
7915 }
7916 }
7917
7918 else
7919 last_reorder_field_type = 1;
7920 }
7921
7922 gnu_last = gnu_field;
7923 }
7924
7925 #undef MOVE_FROM_FIELD_LIST_TO
7926
7927 gnu_field_list = nreverse (gnu_field_list);
7928
7929 /* If permitted, we reorder the fields as follows:
7930
7931 1) all (groups of) fields whose length is fixed and multiple of a byte,
7932 2) the remaining fields whose length is fixed and not multiple of a byte,
7933 3) the remaining fields whose length doesn't depend on discriminants,
7934 4) all fields whose length depends on discriminants,
7935 5) the variant part,
7936
7937 within the record and within each variant recursively. */
7938
7939 if (w_reorder)
7940 {
7941 /* If we have pending bit-packed fields, warn if they would be moved
7942 to after regular fields. */
7943 if (last_reorder_field_type == 2
7944 && tmp_bitp_size != 0
7945 && tmp_last_reorder_field_type < 2)
7946 {
7947 if (gnu_tmp_bitp_list)
7948 warn_on_list_placement (gnu_tmp_bitp_list,
7949 gnat_component_list, gnat_record_type,
7950 in_variant, do_reorder);
7951 else
7952 warn_on_field_placement (gnu_field_list,
7953 gnat_component_list, gnat_record_type,
7954 in_variant, do_reorder);
7955 }
7956 }
7957
7958 if (do_reorder)
7959 {
7960 /* If we have pending bit-packed fields on the temporary list, we put
7961 them either on the bit-packed list or back on the regular list. */
7962 if (gnu_tmp_bitp_list)
7963 {
7964 if (tmp_bitp_size != 0)
7965 gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
7966 else
7967 gnu_field_list = chainon (gnu_tmp_bitp_list, gnu_field_list);
7968 }
7969
7970 gnu_field_list
7971 = chainon (gnu_field_list,
7972 chainon (gnu_bitp_list,
7973 chainon (gnu_var_list, gnu_self_list)));
7974 }
7975
7976 /* Otherwise, if there is an aliased field placed after a field whose length
7977 depends on discriminants, we put all the fields of the latter sort, last.
7978 We need to do this in case an object of this record type is mutable. */
7979 else if (has_aliased_after_self_field)
7980 gnu_field_list = chainon (gnu_field_list, gnu_self_list);
7981
7982 /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
7983 in our REP list to the previous level because this level needs them in
7984 order to do a correct layout, i.e. avoid having overlapping fields. */
7985 if (p_gnu_rep_list && gnu_rep_list)
7986 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
7987
7988 /* Deal with the annoying case of an extension of a record with variable size
7989 and partial rep clause, for which the _Parent field is forced at offset 0
7990 and has variable size, which we do not support below. Note that we cannot
7991 do it if the field has fixed size because we rely on the presence of the
7992 REP part built below to trigger the reordering of the fields in a derived
7993 record type when all the fields have a fixed position. */
7994 else if (gnu_rep_list
7995 && !DECL_CHAIN (gnu_rep_list)
7996 && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
7997 && !variants_have_rep
7998 && first_free_pos
7999 && integer_zerop (first_free_pos)
8000 && integer_zerop (bit_position (gnu_rep_list)))
8001 {
8002 DECL_CHAIN (gnu_rep_list) = gnu_field_list;
8003 gnu_field_list = gnu_rep_list;
8004 gnu_rep_list = NULL_TREE;
8005 }
8006
8007 /* Otherwise, sort the fields by bit position and put them into their own
8008 record, before the others, if we also have fields without rep clause. */
8009 else if (gnu_rep_list)
8010 {
8011 tree gnu_rep_type, gnu_rep_part;
8012 int i, len = list_length (gnu_rep_list);
8013 tree *gnu_arr = XALLOCAVEC (tree, len);
8014
8015 /* If all the fields have a rep clause, we can do a flat layout. */
8016 layout_with_rep = !gnu_field_list
8017 && (!gnu_variant_part || variants_have_rep);
8018 gnu_rep_type
8019 = layout_with_rep ? gnu_record_type : make_node (RECORD_TYPE);
8020
8021 for (gnu_field = gnu_rep_list, i = 0;
8022 gnu_field;
8023 gnu_field = DECL_CHAIN (gnu_field), i++)
8024 gnu_arr[i] = gnu_field;
8025
8026 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
8027
8028 /* Put the fields in the list in order of increasing position, which
8029 means we start from the end. */
8030 gnu_rep_list = NULL_TREE;
8031 for (i = len - 1; i >= 0; i--)
8032 {
8033 DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
8034 gnu_rep_list = gnu_arr[i];
8035 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
8036 }
8037
8038 if (layout_with_rep)
8039 gnu_field_list = gnu_rep_list;
8040 else
8041 {
8042 TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type)
8043 = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
8044 finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
8045
8046 /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
8047 without rep clause are laid out starting from this position.
8048 Therefore, we force it as a minimal size on the REP part. */
8049 gnu_rep_part
8050 = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
8051
8052 /* Chain the REP part at the beginning of the field list. */
8053 DECL_CHAIN (gnu_rep_part) = gnu_field_list;
8054 gnu_field_list = gnu_rep_part;
8055 }
8056 }
8057
8058 /* Chain the variant part at the end of the field list. */
8059 if (gnu_variant_part)
8060 gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
8061
8062 if (cancel_alignment)
8063 SET_TYPE_ALIGN (gnu_record_type, 0);
8064
8065 TYPE_ARTIFICIAL (gnu_record_type) = artificial;
8066
8067 finish_record_type (gnu_record_type, gnu_field_list, layout_with_rep ? 1 : 0,
8068 debug_info && !maybe_unused);
8069
8070 /* Chain the fields with zero size at the beginning of the field list. */
8071 if (gnu_zero_list)
8072 TYPE_FIELDS (gnu_record_type)
8073 = chainon (gnu_zero_list, TYPE_FIELDS (gnu_record_type));
8074
8075 return (gnu_rep_list && !p_gnu_rep_list) || variants_have_rep;
8076 }
8077
8078 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
8079 placed into an Esize, Component_Bit_Offset, or Component_Size value
8080 in the GNAT tree. */
8081
8082 static Uint
annotate_value(tree gnu_size)8083 annotate_value (tree gnu_size)
8084 {
8085 static int var_count = 0;
8086 TCode tcode;
8087 Node_Ref_Or_Val ops[3] = { No_Uint, No_Uint, No_Uint };
8088 struct tree_int_map in;
8089
8090 /* See if we've already saved the value for this node. */
8091 if (EXPR_P (gnu_size) || DECL_P (gnu_size))
8092 {
8093 struct tree_int_map *e;
8094
8095 in.base.from = gnu_size;
8096 e = annotate_value_cache->find (&in);
8097
8098 if (e)
8099 return (Node_Ref_Or_Val) e->to;
8100 }
8101 else
8102 in.base.from = NULL_TREE;
8103
8104 /* If we do not return inside this switch, TCODE will be set to the
8105 code to be used in a call to Create_Node. */
8106 switch (TREE_CODE (gnu_size))
8107 {
8108 case INTEGER_CST:
8109 /* For negative values, build NEGATE_EXPR of the opposite. Such values
8110 can appear for discriminants in expressions for variants. */
8111 if (tree_int_cst_sgn (gnu_size) < 0)
8112 {
8113 tree t = wide_int_to_tree (sizetype, -wi::to_wide (gnu_size));
8114 tcode = Negate_Expr;
8115 ops[0] = UI_From_gnu (t);
8116 }
8117 else
8118 return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
8119 break;
8120
8121 case COMPONENT_REF:
8122 /* The only case we handle here is a simple discriminant reference. */
8123 if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
8124 {
8125 tree ref = gnu_size;
8126 gnu_size = TREE_OPERAND (ref, 1);
8127
8128 /* Climb up the chain of successive extensions, if any. */
8129 while (TREE_CODE (TREE_OPERAND (ref, 0)) == COMPONENT_REF
8130 && DECL_NAME (TREE_OPERAND (TREE_OPERAND (ref, 0), 1))
8131 == parent_name_id)
8132 ref = TREE_OPERAND (ref, 0);
8133
8134 if (TREE_CODE (TREE_OPERAND (ref, 0)) == PLACEHOLDER_EXPR)
8135 {
8136 /* Fall through to common processing as a FIELD_DECL. */
8137 tcode = Discrim_Val;
8138 ops[0] = UI_From_gnu (DECL_DISCRIMINANT_NUMBER (gnu_size));
8139 }
8140 else
8141 return No_Uint;
8142 }
8143 else
8144 return No_Uint;
8145 break;
8146
8147 case VAR_DECL:
8148 tcode = Dynamic_Val;
8149 ops[0] = UI_From_Int (++var_count);
8150 break;
8151
8152 CASE_CONVERT:
8153 case NON_LVALUE_EXPR:
8154 return annotate_value (TREE_OPERAND (gnu_size, 0));
8155
8156 /* Now just list the operations we handle. */
8157 case COND_EXPR: tcode = Cond_Expr; break;
8158 case MINUS_EXPR: tcode = Minus_Expr; break;
8159 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
8160 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
8161 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
8162 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
8163 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
8164 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
8165 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
8166 case NEGATE_EXPR: tcode = Negate_Expr; break;
8167 case MIN_EXPR: tcode = Min_Expr; break;
8168 case MAX_EXPR: tcode = Max_Expr; break;
8169 case ABS_EXPR: tcode = Abs_Expr; break;
8170 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
8171 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
8172 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
8173 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
8174 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
8175 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
8176 case LT_EXPR: tcode = Lt_Expr; break;
8177 case LE_EXPR: tcode = Le_Expr; break;
8178 case GT_EXPR: tcode = Gt_Expr; break;
8179 case GE_EXPR: tcode = Ge_Expr; break;
8180 case EQ_EXPR: tcode = Eq_Expr; break;
8181 case NE_EXPR: tcode = Ne_Expr; break;
8182
8183 case PLUS_EXPR:
8184 /* Turn addition of negative constant into subtraction. */
8185 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST
8186 && tree_int_cst_sign_bit (TREE_OPERAND (gnu_size, 1)))
8187 {
8188 tcode = Minus_Expr;
8189 wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
8190 ops[1] = annotate_value (wide_int_to_tree (sizetype, wop1));
8191 break;
8192 }
8193
8194 /* ... fall through ... */
8195
8196 case MULT_EXPR:
8197 tcode = (TREE_CODE (gnu_size) == MULT_EXPR ? Mult_Expr : Plus_Expr);
8198 /* Fold conversions from bytes to bits into inner operations. */
8199 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST
8200 && CONVERT_EXPR_P (TREE_OPERAND (gnu_size, 0)))
8201 {
8202 tree inner_op = TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 0);
8203 if (TREE_CODE (inner_op) == TREE_CODE (gnu_size)
8204 && TREE_CODE (TREE_OPERAND (inner_op, 1)) == INTEGER_CST)
8205 {
8206 ops[0] = annotate_value (TREE_OPERAND (inner_op, 0));
8207 tree inner_op_op1 = TREE_OPERAND (inner_op, 1);
8208 tree gnu_size_op1 = TREE_OPERAND (gnu_size, 1);
8209 widest_int op1;
8210 if (TREE_CODE (gnu_size) == MULT_EXPR)
8211 op1 = (wi::to_widest (inner_op_op1)
8212 * wi::to_widest (gnu_size_op1));
8213 else
8214 {
8215 op1 = (wi::to_widest (inner_op_op1)
8216 + wi::to_widest (gnu_size_op1));
8217 if (wi::zext (op1, TYPE_PRECISION (sizetype)) == 0)
8218 return ops[0];
8219 }
8220 ops[1] = annotate_value (wide_int_to_tree (sizetype, op1));
8221 }
8222 }
8223 break;
8224
8225 case BIT_AND_EXPR:
8226 tcode = Bit_And_Expr;
8227 /* For negative values in sizetype, build NEGATE_EXPR of the opposite.
8228 Such values can appear in expressions with aligning patterns. */
8229 if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
8230 {
8231 wide_int wop1 = -wi::to_wide (TREE_OPERAND (gnu_size, 1));
8232 tree op1 = wide_int_to_tree (sizetype, wop1);
8233 ops[1] = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
8234 }
8235 break;
8236
8237 case CALL_EXPR:
8238 /* In regular mode, inline back only if symbolic annotation is requested
8239 in order to avoid memory explosion on big discriminated record types.
8240 But not in ASIS mode, as symbolic annotation is required for DDA. */
8241 if (List_Representation_Info == 3 || type_annotate_only)
8242 {
8243 tree t = maybe_inline_call_in_expr (gnu_size);
8244 return t ? annotate_value (t) : No_Uint;
8245 }
8246 else
8247 return Uint_Minus_1;
8248
8249 default:
8250 return No_Uint;
8251 }
8252
8253 /* Now get each of the operands that's relevant for this code. If any
8254 cannot be expressed as a repinfo node, say we can't. */
8255 for (int i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
8256 if (ops[i] == No_Uint)
8257 {
8258 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
8259 if (ops[i] == No_Uint)
8260 return No_Uint;
8261 }
8262
8263 Node_Ref_Or_Val ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
8264
8265 /* Save the result in the cache. */
8266 if (in.base.from)
8267 {
8268 struct tree_int_map **h;
8269 /* We can't assume the hash table data hasn't moved since the initial
8270 look up, so we have to search again. Allocating and inserting an
8271 entry at that point would be an alternative, but then we'd better
8272 discard the entry if we decided not to cache it. */
8273 h = annotate_value_cache->find_slot (&in, INSERT);
8274 gcc_assert (!*h);
8275 *h = ggc_alloc<tree_int_map> ();
8276 (*h)->base.from = in.base.from;
8277 (*h)->to = ret;
8278 }
8279
8280 return ret;
8281 }
8282
8283 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
8284 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
8285 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
8286 BY_REF is true if the object is used by reference. */
8287
8288 void
annotate_object(Entity_Id gnat_entity,tree gnu_type,tree size,bool by_ref)8289 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
8290 {
8291 if (by_ref)
8292 {
8293 if (TYPE_IS_FAT_POINTER_P (gnu_type))
8294 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
8295 else
8296 gnu_type = TREE_TYPE (gnu_type);
8297 }
8298
8299 if (Unknown_Esize (gnat_entity))
8300 {
8301 if (TREE_CODE (gnu_type) == RECORD_TYPE
8302 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8303 size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
8304 else if (!size)
8305 size = TYPE_SIZE (gnu_type);
8306
8307 if (size)
8308 Set_Esize (gnat_entity, annotate_value (size));
8309 }
8310
8311 if (Unknown_Alignment (gnat_entity))
8312 Set_Alignment (gnat_entity,
8313 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
8314 }
8315
8316 /* Return first element of field list whose TREE_PURPOSE is the same as ELEM.
8317 Return NULL_TREE if there is no such element in the list. */
8318
8319 static tree
purpose_member_field(const_tree elem,tree list)8320 purpose_member_field (const_tree elem, tree list)
8321 {
8322 while (list)
8323 {
8324 tree field = TREE_PURPOSE (list);
8325 if (SAME_FIELD_P (field, elem))
8326 return list;
8327 list = TREE_CHAIN (list);
8328 }
8329 return NULL_TREE;
8330 }
8331
8332 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
8333 set Component_Bit_Offset and Esize of the components to the position and
8334 size used by Gigi. */
8335
8336 static void
annotate_rep(Entity_Id gnat_entity,tree gnu_type)8337 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
8338 {
8339 /* For an extension, the inherited components have not been translated because
8340 they are fetched from the _Parent component on the fly. */
8341 const bool is_extension
8342 = Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity);
8343
8344 /* We operate by first making a list of all fields and their position (we
8345 can get the size easily) and then update all the sizes in the tree. */
8346 tree gnu_list
8347 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
8348 BIGGEST_ALIGNMENT, NULL_TREE);
8349
8350 for (Entity_Id gnat_field = First_Entity (gnat_entity);
8351 Present (gnat_field);
8352 gnat_field = Next_Entity (gnat_field))
8353 if ((Ekind (gnat_field) == E_Component
8354 && (is_extension || present_gnu_tree (gnat_field)))
8355 || (Ekind (gnat_field) == E_Discriminant
8356 && !Is_Unchecked_Union (Scope (gnat_field))))
8357 {
8358 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
8359 gnu_list);
8360 if (t)
8361 {
8362 tree parent_offset;
8363
8364 /* If we are just annotating types and the type is tagged, the tag
8365 and the parent components are not generated by the front-end so
8366 we need to add the appropriate offset to each component without
8367 representation clause. */
8368 if (type_annotate_only
8369 && Is_Tagged_Type (gnat_entity)
8370 && No (Component_Clause (gnat_field)))
8371 {
8372 /* For a component appearing in the current extension, the
8373 offset is the size of the parent. */
8374 if (Is_Derived_Type (gnat_entity)
8375 && Original_Record_Component (gnat_field) == gnat_field)
8376 parent_offset
8377 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
8378 bitsizetype);
8379 else
8380 parent_offset = bitsize_int (POINTER_SIZE);
8381
8382 if (TYPE_FIELDS (gnu_type))
8383 parent_offset
8384 = round_up (parent_offset,
8385 DECL_ALIGN (TYPE_FIELDS (gnu_type)));
8386 }
8387 else
8388 parent_offset = bitsize_zero_node;
8389
8390 Set_Component_Bit_Offset
8391 (gnat_field,
8392 annotate_value
8393 (size_binop (PLUS_EXPR,
8394 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
8395 TREE_VEC_ELT (TREE_VALUE (t), 2)),
8396 parent_offset)));
8397
8398 Set_Esize (gnat_field,
8399 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
8400 }
8401 else if (is_extension)
8402 {
8403 /* If there is no entry, this is an inherited component whose
8404 position is the same as in the parent type. */
8405 Entity_Id gnat_orig_field = Original_Record_Component (gnat_field);
8406
8407 /* If we are just annotating types, discriminants renaming those of
8408 the parent have no entry so deal with them specifically. */
8409 if (type_annotate_only
8410 && gnat_orig_field == gnat_field
8411 && Ekind (gnat_field) == E_Discriminant)
8412 gnat_orig_field = Corresponding_Discriminant (gnat_field);
8413
8414 Set_Component_Bit_Offset (gnat_field,
8415 Component_Bit_Offset (gnat_orig_field));
8416
8417 Set_Esize (gnat_field, Esize (gnat_orig_field));
8418 }
8419 }
8420 }
8421
8422 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
8423 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
8424 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
8425 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
8426 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
8427 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
8428 pre-existing list to be chained to the newly created entries. */
8429
8430 static tree
build_position_list(tree gnu_type,bool do_not_flatten_variant,tree gnu_pos,tree gnu_bitpos,unsigned int offset_align,tree gnu_list)8431 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
8432 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
8433 {
8434 tree gnu_field;
8435
8436 for (gnu_field = TYPE_FIELDS (gnu_type);
8437 gnu_field;
8438 gnu_field = DECL_CHAIN (gnu_field))
8439 {
8440 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
8441 DECL_FIELD_BIT_OFFSET (gnu_field));
8442 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
8443 DECL_FIELD_OFFSET (gnu_field));
8444 unsigned int our_offset_align
8445 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
8446 tree v = make_tree_vec (3);
8447
8448 TREE_VEC_ELT (v, 0) = gnu_our_offset;
8449 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
8450 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
8451 gnu_list = tree_cons (gnu_field, v, gnu_list);
8452
8453 /* Recurse on internal fields, flattening the nested fields except for
8454 those in the variant part, if requested. */
8455 if (DECL_INTERNAL_P (gnu_field))
8456 {
8457 tree gnu_field_type = TREE_TYPE (gnu_field);
8458 if (do_not_flatten_variant
8459 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
8460 gnu_list
8461 = build_position_list (gnu_field_type, do_not_flatten_variant,
8462 size_zero_node, bitsize_zero_node,
8463 BIGGEST_ALIGNMENT, gnu_list);
8464 else
8465 gnu_list
8466 = build_position_list (gnu_field_type, do_not_flatten_variant,
8467 gnu_our_offset, gnu_our_bitpos,
8468 our_offset_align, gnu_list);
8469 }
8470 }
8471
8472 return gnu_list;
8473 }
8474
8475 /* Return a list describing the substitutions needed to reflect the
8476 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
8477 be in any order. The values in an element of the list are in the form
8478 of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
8479 a definition of GNAT_SUBTYPE. */
8480
8481 static vec<subst_pair>
build_subst_list(Entity_Id gnat_subtype,Entity_Id gnat_type,bool definition)8482 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
8483 {
8484 vec<subst_pair> gnu_list = vNULL;
8485 Entity_Id gnat_discrim;
8486 Node_Id gnat_constr;
8487
8488 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
8489 gnat_constr = First_Elmt (Stored_Constraint (gnat_subtype));
8490 Present (gnat_discrim);
8491 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
8492 gnat_constr = Next_Elmt (gnat_constr))
8493 /* Ignore access discriminants. */
8494 if (!Is_Access_Type (Etype (Node (gnat_constr))))
8495 {
8496 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
8497 tree replacement = convert (TREE_TYPE (gnu_field),
8498 elaborate_expression
8499 (Node (gnat_constr), gnat_subtype,
8500 get_entity_char (gnat_discrim),
8501 definition, true, false));
8502 subst_pair s = { gnu_field, replacement };
8503 gnu_list.safe_push (s);
8504 }
8505
8506 return gnu_list;
8507 }
8508
8509 /* Scan all fields in QUAL_UNION_TYPE and return a list describing the
8510 variants of QUAL_UNION_TYPE that are still relevant after applying
8511 the substitutions described in SUBST_LIST. GNU_LIST is a pre-existing
8512 list to be prepended to the newly created entries. */
8513
8514 static vec<variant_desc>
build_variant_list(tree qual_union_type,vec<subst_pair> subst_list,vec<variant_desc> gnu_list)8515 build_variant_list (tree qual_union_type, vec<subst_pair> subst_list,
8516 vec<variant_desc> gnu_list)
8517 {
8518 tree gnu_field;
8519
8520 for (gnu_field = TYPE_FIELDS (qual_union_type);
8521 gnu_field;
8522 gnu_field = DECL_CHAIN (gnu_field))
8523 {
8524 tree qual = DECL_QUALIFIER (gnu_field);
8525 unsigned int i;
8526 subst_pair *s;
8527
8528 FOR_EACH_VEC_ELT (subst_list, i, s)
8529 qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
8530
8531 /* If the new qualifier is not unconditionally false, its variant may
8532 still be accessed. */
8533 if (!integer_zerop (qual))
8534 {
8535 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
8536 variant_desc v = { variant_type, gnu_field, qual, NULL_TREE };
8537
8538 gnu_list.safe_push (v);
8539
8540 /* Recurse on the variant subpart of the variant, if any. */
8541 variant_subpart = get_variant_part (variant_type);
8542 if (variant_subpart)
8543 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
8544 subst_list, gnu_list);
8545
8546 /* If the new qualifier is unconditionally true, the subsequent
8547 variants cannot be accessed. */
8548 if (integer_onep (qual))
8549 break;
8550 }
8551 }
8552
8553 return gnu_list;
8554 }
8555
8556 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
8557 corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
8558 corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
8559 VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
8560 size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
8561 true if we are being called to process the Component_Size of GNAT_OBJECT;
8562 this is used only for error messages. ZERO_OK is true if a size of zero
8563 is permitted; if ZERO_OK is false, it means that a size of zero should be
8564 treated as an unspecified size. */
8565
8566 static tree
validate_size(Uint uint_size,tree gnu_type,Entity_Id gnat_object,enum tree_code kind,bool component_p,bool zero_ok)8567 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
8568 enum tree_code kind, bool component_p, bool zero_ok)
8569 {
8570 Node_Id gnat_error_node;
8571 tree type_size, size;
8572
8573 /* Return 0 if no size was specified. */
8574 if (uint_size == No_Uint)
8575 return NULL_TREE;
8576
8577 /* Ignore a negative size since that corresponds to our back-annotation. */
8578 if (UI_Lt (uint_size, Uint_0))
8579 return NULL_TREE;
8580
8581 /* Find the node to use for error messages. */
8582 if ((Ekind (gnat_object) == E_Component
8583 || Ekind (gnat_object) == E_Discriminant)
8584 && Present (Component_Clause (gnat_object)))
8585 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
8586 else if (Present (Size_Clause (gnat_object)))
8587 gnat_error_node = Expression (Size_Clause (gnat_object));
8588 else
8589 gnat_error_node = gnat_object;
8590
8591 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8592 but cannot be represented in bitsizetype. */
8593 size = UI_To_gnu (uint_size, bitsizetype);
8594 if (TREE_OVERFLOW (size))
8595 {
8596 if (component_p)
8597 post_error_ne ("component size for& is too large", gnat_error_node,
8598 gnat_object);
8599 else
8600 post_error_ne ("size for& is too large", gnat_error_node,
8601 gnat_object);
8602 return NULL_TREE;
8603 }
8604
8605 /* Ignore a zero size if it is not permitted. */
8606 if (!zero_ok && integer_zerop (size))
8607 return NULL_TREE;
8608
8609 /* The size of objects is always a multiple of a byte. */
8610 if (kind == VAR_DECL
8611 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
8612 {
8613 if (component_p)
8614 post_error_ne ("component size for& is not a multiple of Storage_Unit",
8615 gnat_error_node, gnat_object);
8616 else
8617 post_error_ne ("size for& is not a multiple of Storage_Unit",
8618 gnat_error_node, gnat_object);
8619 return NULL_TREE;
8620 }
8621
8622 /* If this is an integral type or a packed array type, the front-end has
8623 already verified the size, so we need not do it here (which would mean
8624 checking against the bounds). However, if this is an aliased object,
8625 it may not be smaller than the type of the object. */
8626 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
8627 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
8628 return size;
8629
8630 /* If the object is a record that contains a template, add the size of the
8631 template to the specified size. */
8632 if (TREE_CODE (gnu_type) == RECORD_TYPE
8633 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8634 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
8635
8636 if (kind == VAR_DECL
8637 /* If a type needs strict alignment, a component of this type in
8638 a packed record cannot be packed and thus uses the type size. */
8639 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
8640 type_size = TYPE_SIZE (gnu_type);
8641 else
8642 type_size = rm_size (gnu_type);
8643
8644 /* Modify the size of a discriminated type to be the maximum size. */
8645 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
8646 type_size = max_size (type_size, true);
8647
8648 /* If this is an access type or a fat pointer, the minimum size is that given
8649 by the smallest integral mode that's valid for pointers. */
8650 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
8651 {
8652 scalar_int_mode p_mode = NARROWEST_INT_MODE;
8653 while (!targetm.valid_pointer_mode (p_mode))
8654 p_mode = GET_MODE_WIDER_MODE (p_mode).require ();
8655 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
8656 }
8657
8658 /* Issue an error either if the default size of the object isn't a constant
8659 or if the new size is smaller than it. */
8660 if (TREE_CODE (type_size) != INTEGER_CST
8661 || TREE_OVERFLOW (type_size)
8662 || tree_int_cst_lt (size, type_size))
8663 {
8664 if (component_p)
8665 post_error_ne_tree
8666 ("component size for& too small{, minimum allowed is ^}",
8667 gnat_error_node, gnat_object, type_size);
8668 else
8669 post_error_ne_tree
8670 ("size for& too small{, minimum allowed is ^}",
8671 gnat_error_node, gnat_object, type_size);
8672 return NULL_TREE;
8673 }
8674
8675 return size;
8676 }
8677
8678 /* Similarly, but both validate and process a value of RM size. This routine
8679 is only called for types. */
8680
8681 static void
set_rm_size(Uint uint_size,tree gnu_type,Entity_Id gnat_entity)8682 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
8683 {
8684 Node_Id gnat_attr_node;
8685 tree old_size, size;
8686
8687 /* Do nothing if no size was specified. */
8688 if (uint_size == No_Uint)
8689 return;
8690
8691 /* Ignore a negative size since that corresponds to our back-annotation. */
8692 if (UI_Lt (uint_size, Uint_0))
8693 return;
8694
8695 /* Only issue an error if a Value_Size clause was explicitly given.
8696 Otherwise, we'd be duplicating an error on the Size clause. */
8697 gnat_attr_node
8698 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
8699
8700 /* Get the size as an INTEGER_CST. Issue an error if a size was specified
8701 but cannot be represented in bitsizetype. */
8702 size = UI_To_gnu (uint_size, bitsizetype);
8703 if (TREE_OVERFLOW (size))
8704 {
8705 if (Present (gnat_attr_node))
8706 post_error_ne ("Value_Size for& is too large", gnat_attr_node,
8707 gnat_entity);
8708 return;
8709 }
8710
8711 /* Ignore a zero size unless a Value_Size clause exists, or a size clause
8712 exists, or this is an integer type, in which case the front-end will
8713 have always set it. */
8714 if (No (gnat_attr_node)
8715 && integer_zerop (size)
8716 && !Has_Size_Clause (gnat_entity)
8717 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8718 return;
8719
8720 old_size = rm_size (gnu_type);
8721
8722 /* If the old size is self-referential, get the maximum size. */
8723 if (CONTAINS_PLACEHOLDER_P (old_size))
8724 old_size = max_size (old_size, true);
8725
8726 /* Issue an error either if the old size of the object isn't a constant or
8727 if the new size is smaller than it. The front-end has already verified
8728 this for scalar and packed array types. */
8729 if (TREE_CODE (old_size) != INTEGER_CST
8730 || TREE_OVERFLOW (old_size)
8731 || (AGGREGATE_TYPE_P (gnu_type)
8732 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
8733 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
8734 && !(TYPE_IS_PADDING_P (gnu_type)
8735 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
8736 && TYPE_PACKED_ARRAY_TYPE_P
8737 (TREE_TYPE (TYPE_FIELDS (gnu_type))))
8738 && tree_int_cst_lt (size, old_size)))
8739 {
8740 if (Present (gnat_attr_node))
8741 post_error_ne_tree
8742 ("Value_Size for& too small{, minimum allowed is ^}",
8743 gnat_attr_node, gnat_entity, old_size);
8744 return;
8745 }
8746
8747 /* Otherwise, set the RM size proper for integral types... */
8748 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
8749 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
8750 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
8751 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
8752 SET_TYPE_RM_SIZE (gnu_type, size);
8753
8754 /* ...or the Ada size for record and union types. */
8755 else if (RECORD_OR_UNION_TYPE_P (gnu_type)
8756 && !TYPE_FAT_POINTER_P (gnu_type))
8757 SET_TYPE_ADA_SIZE (gnu_type, size);
8758 }
8759
8760 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
8761 a type or object whose present alignment is ALIGN. If this alignment is
8762 valid, return it. Otherwise, give an error and return ALIGN. */
8763
8764 static unsigned int
validate_alignment(Uint alignment,Entity_Id gnat_entity,unsigned int align)8765 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
8766 {
8767 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
8768 unsigned int new_align;
8769 Node_Id gnat_error_node;
8770
8771 /* Don't worry about checking alignment if alignment was not specified
8772 by the source program and we already posted an error for this entity. */
8773 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
8774 return align;
8775
8776 /* Post the error on the alignment clause if any. Note, for the implicit
8777 base type of an array type, the alignment clause is on the first
8778 subtype. */
8779 if (Present (Alignment_Clause (gnat_entity)))
8780 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
8781
8782 else if (Is_Itype (gnat_entity)
8783 && Is_Array_Type (gnat_entity)
8784 && Etype (gnat_entity) == gnat_entity
8785 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
8786 gnat_error_node =
8787 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
8788
8789 else
8790 gnat_error_node = gnat_entity;
8791
8792 /* Within GCC, an alignment is an integer, so we must make sure a value is
8793 specified that fits in that range. Also, there is an upper bound to
8794 alignments we can support/allow. */
8795 if (!UI_Is_In_Int_Range (alignment)
8796 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
8797 post_error_ne_num ("largest supported alignment for& is ^",
8798 gnat_error_node, gnat_entity, max_allowed_alignment);
8799 else if (!(Present (Alignment_Clause (gnat_entity))
8800 && From_At_Mod (Alignment_Clause (gnat_entity)))
8801 && new_align * BITS_PER_UNIT < align)
8802 {
8803 unsigned int double_align;
8804 bool is_capped_double, align_clause;
8805
8806 /* If the default alignment of "double" or larger scalar types is
8807 specifically capped and the new alignment is above the cap, do
8808 not post an error and change the alignment only if there is an
8809 alignment clause; this makes it possible to have the associated
8810 GCC type overaligned by default for performance reasons. */
8811 if ((double_align = double_float_alignment) > 0)
8812 {
8813 Entity_Id gnat_type
8814 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8815 is_capped_double
8816 = is_double_float_or_array (gnat_type, &align_clause);
8817 }
8818 else if ((double_align = double_scalar_alignment) > 0)
8819 {
8820 Entity_Id gnat_type
8821 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
8822 is_capped_double
8823 = is_double_scalar_or_array (gnat_type, &align_clause);
8824 }
8825 else
8826 is_capped_double = align_clause = false;
8827
8828 if (is_capped_double && new_align >= double_align)
8829 {
8830 if (align_clause)
8831 align = new_align * BITS_PER_UNIT;
8832 }
8833 else
8834 {
8835 if (is_capped_double)
8836 align = double_align * BITS_PER_UNIT;
8837
8838 post_error_ne_num ("alignment for& must be at least ^",
8839 gnat_error_node, gnat_entity,
8840 align / BITS_PER_UNIT);
8841 }
8842 }
8843 else
8844 {
8845 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
8846 if (new_align > align)
8847 align = new_align;
8848 }
8849
8850 return align;
8851 }
8852
8853 /* Promote the alignment of GNU_TYPE corresponding to GNAT_ENTITY. Return
8854 a positive value on success or zero on failure. */
8855
8856 static unsigned int
promote_object_alignment(tree gnu_type,Entity_Id gnat_entity)8857 promote_object_alignment (tree gnu_type, Entity_Id gnat_entity)
8858 {
8859 unsigned int align, size_cap, align_cap;
8860
8861 /* No point in promoting the alignment if this doesn't prevent BLKmode access
8862 to the object, in particular block copy, as this will for example disable
8863 the NRV optimization for it. No point in jumping through all the hoops
8864 needed in order to support BIGGEST_ALIGNMENT if we don't really have to.
8865 So we cap to the smallest alignment that corresponds to a known efficient
8866 memory access pattern, except for Atomic and Volatile_Full_Access. */
8867 if (Is_Atomic_Or_VFA (gnat_entity))
8868 {
8869 size_cap = UINT_MAX;
8870 align_cap = BIGGEST_ALIGNMENT;
8871 }
8872 else
8873 {
8874 size_cap = MAX_FIXED_MODE_SIZE;
8875 align_cap = get_mode_alignment (ptr_mode);
8876 }
8877
8878 /* Do the promotion within the above limits. */
8879 if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
8880 || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
8881 align = 0;
8882 else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
8883 align = align_cap;
8884 else
8885 align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
8886
8887 /* But make sure not to under-align the object. */
8888 if (align <= TYPE_ALIGN (gnu_type))
8889 align = 0;
8890
8891 /* And honor the minimum valid atomic alignment, if any. */
8892 #ifdef MINIMUM_ATOMIC_ALIGNMENT
8893 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
8894 align = MINIMUM_ATOMIC_ALIGNMENT;
8895 #endif
8896
8897 return align;
8898 }
8899
8900 /* Verify that TYPE is something we can implement atomically. If not, issue
8901 an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
8902 process a component type. */
8903
8904 static void
check_ok_for_atomic_type(tree type,Entity_Id gnat_entity,bool component_p)8905 check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p)
8906 {
8907 Node_Id gnat_error_point = gnat_entity;
8908 Node_Id gnat_node;
8909 machine_mode mode;
8910 enum mode_class mclass;
8911 unsigned int align;
8912 tree size;
8913
8914 /* If this is an anonymous base type, nothing to check, the error will be
8915 reported on the source type if need be. */
8916 if (!Comes_From_Source (gnat_entity))
8917 return;
8918
8919 mode = TYPE_MODE (type);
8920 mclass = GET_MODE_CLASS (mode);
8921 align = TYPE_ALIGN (type);
8922 size = TYPE_SIZE (type);
8923
8924 /* Consider all aligned floating-point types atomic and any aligned types
8925 that are represented by integers no wider than a machine word. */
8926 scalar_int_mode int_mode;
8927 if ((mclass == MODE_FLOAT
8928 || (is_a <scalar_int_mode> (mode, &int_mode)
8929 && GET_MODE_BITSIZE (int_mode) <= BITS_PER_WORD))
8930 && align >= GET_MODE_ALIGNMENT (mode))
8931 return;
8932
8933 /* For the moment, also allow anything that has an alignment equal to its
8934 size and which is smaller than a word. */
8935 if (size
8936 && TREE_CODE (size) == INTEGER_CST
8937 && compare_tree_int (size, align) == 0
8938 && align <= BITS_PER_WORD)
8939 return;
8940
8941 for (gnat_node = First_Rep_Item (gnat_entity);
8942 Present (gnat_node);
8943 gnat_node = Next_Rep_Item (gnat_node))
8944 if (Nkind (gnat_node) == N_Pragma)
8945 {
8946 unsigned char pragma_id
8947 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
8948
8949 if ((pragma_id == Pragma_Atomic && !component_p)
8950 || (pragma_id == Pragma_Atomic_Components && component_p))
8951 {
8952 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
8953 break;
8954 }
8955 }
8956
8957 if (component_p)
8958 post_error_ne ("atomic access to component of & cannot be guaranteed",
8959 gnat_error_point, gnat_entity);
8960 else if (Is_Volatile_Full_Access (gnat_entity))
8961 post_error_ne ("volatile full access to & cannot be guaranteed",
8962 gnat_error_point, gnat_entity);
8963 else
8964 post_error_ne ("atomic access to & cannot be guaranteed",
8965 gnat_error_point, gnat_entity);
8966 }
8967
8968
8969 /* Helper for the intrin compatibility checks family. Evaluate whether
8970 two types are definitely incompatible. */
8971
8972 static bool
intrin_types_incompatible_p(tree t1,tree t2)8973 intrin_types_incompatible_p (tree t1, tree t2)
8974 {
8975 enum tree_code code;
8976
8977 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
8978 return false;
8979
8980 if (TYPE_MODE (t1) != TYPE_MODE (t2))
8981 return true;
8982
8983 if (TREE_CODE (t1) != TREE_CODE (t2))
8984 return true;
8985
8986 code = TREE_CODE (t1);
8987
8988 switch (code)
8989 {
8990 case INTEGER_TYPE:
8991 case REAL_TYPE:
8992 return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
8993
8994 case POINTER_TYPE:
8995 case REFERENCE_TYPE:
8996 /* Assume designated types are ok. We'd need to account for char * and
8997 void * variants to do better, which could rapidly get messy and isn't
8998 clearly worth the effort. */
8999 return false;
9000
9001 default:
9002 break;
9003 }
9004
9005 return false;
9006 }
9007
9008 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
9009 on the Ada/builtin argument lists for the INB binding. */
9010
9011 static bool
intrin_arglists_compatible_p(intrin_binding_t * inb)9012 intrin_arglists_compatible_p (intrin_binding_t * inb)
9013 {
9014 function_args_iterator ada_iter, btin_iter;
9015
9016 function_args_iter_init (&ada_iter, inb->ada_fntype);
9017 function_args_iter_init (&btin_iter, inb->btin_fntype);
9018
9019 /* Sequence position of the last argument we checked. */
9020 int argpos = 0;
9021
9022 while (true)
9023 {
9024 tree ada_type = function_args_iter_cond (&ada_iter);
9025 tree btin_type = function_args_iter_cond (&btin_iter);
9026
9027 /* If we've exhausted both lists simultaneously, we're done. */
9028 if (!ada_type && !btin_type)
9029 break;
9030
9031 /* If one list is shorter than the other, they fail to match. */
9032 if (!ada_type || !btin_type)
9033 return false;
9034
9035 /* If we're done with the Ada args and not with the internal builtin
9036 args, or the other way around, complain. */
9037 if (ada_type == void_type_node
9038 && btin_type != void_type_node)
9039 {
9040 post_error ("?Ada arguments list too short!", inb->gnat_entity);
9041 return false;
9042 }
9043
9044 if (btin_type == void_type_node
9045 && ada_type != void_type_node)
9046 {
9047 post_error_ne_num ("?Ada arguments list too long ('> ^)!",
9048 inb->gnat_entity, inb->gnat_entity, argpos);
9049 return false;
9050 }
9051
9052 /* Otherwise, check that types match for the current argument. */
9053 argpos ++;
9054 if (intrin_types_incompatible_p (ada_type, btin_type))
9055 {
9056 post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
9057 inb->gnat_entity, inb->gnat_entity, argpos);
9058 return false;
9059 }
9060
9061
9062 function_args_iter_next (&ada_iter);
9063 function_args_iter_next (&btin_iter);
9064 }
9065
9066 return true;
9067 }
9068
9069 /* Helper for intrin_profiles_compatible_p, to perform compatibility checks
9070 on the Ada/builtin return values for the INB binding. */
9071
9072 static bool
intrin_return_compatible_p(intrin_binding_t * inb)9073 intrin_return_compatible_p (intrin_binding_t * inb)
9074 {
9075 tree ada_return_type = TREE_TYPE (inb->ada_fntype);
9076 tree btin_return_type = TREE_TYPE (inb->btin_fntype);
9077
9078 /* Accept function imported as procedure, common and convenient. */
9079 if (VOID_TYPE_P (ada_return_type)
9080 && !VOID_TYPE_P (btin_return_type))
9081 return true;
9082
9083 /* Check return types compatibility otherwise. Note that this
9084 handles void/void as well. */
9085 if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
9086 {
9087 post_error ("?intrinsic binding type mismatch on return value!",
9088 inb->gnat_entity);
9089 return false;
9090 }
9091
9092 return true;
9093 }
9094
9095 /* Check and return whether the Ada and gcc builtin profiles bound by INB are
9096 compatible. Issue relevant warnings when they are not.
9097
9098 This is intended as a light check to diagnose the most obvious cases, not
9099 as a full fledged type compatibility predicate. It is the programmer's
9100 responsibility to ensure correctness of the Ada declarations in Imports,
9101 especially when binding straight to a compiler internal. */
9102
9103 static bool
intrin_profiles_compatible_p(intrin_binding_t * inb)9104 intrin_profiles_compatible_p (intrin_binding_t * inb)
9105 {
9106 /* Check compatibility on return values and argument lists, each responsible
9107 for posting warnings as appropriate. Ensure use of the proper sloc for
9108 this purpose. */
9109
9110 bool arglists_compatible_p, return_compatible_p;
9111 location_t saved_location = input_location;
9112
9113 Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
9114
9115 return_compatible_p = intrin_return_compatible_p (inb);
9116 arglists_compatible_p = intrin_arglists_compatible_p (inb);
9117
9118 input_location = saved_location;
9119
9120 return return_compatible_p && arglists_compatible_p;
9121 }
9122
9123 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
9124 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
9125 specified size for this field. POS_LIST is a position list describing
9126 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
9127 to this layout. */
9128
9129 static tree
create_field_decl_from(tree old_field,tree field_type,tree record_type,tree size,tree pos_list,vec<subst_pair> subst_list)9130 create_field_decl_from (tree old_field, tree field_type, tree record_type,
9131 tree size, tree pos_list,
9132 vec<subst_pair> subst_list)
9133 {
9134 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
9135 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
9136 unsigned int offset_align = tree_to_uhwi (TREE_VEC_ELT (t, 1));
9137 tree new_pos, new_field;
9138 unsigned int i;
9139 subst_pair *s;
9140
9141 if (CONTAINS_PLACEHOLDER_P (pos))
9142 FOR_EACH_VEC_ELT (subst_list, i, s)
9143 pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
9144
9145 /* If the position is now a constant, we can set it as the position of the
9146 field when we make it. Otherwise, we need to deal with it specially. */
9147 if (TREE_CONSTANT (pos))
9148 new_pos = bit_from_pos (pos, bitpos);
9149 else
9150 new_pos = NULL_TREE;
9151
9152 new_field
9153 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
9154 size, new_pos, DECL_PACKED (old_field),
9155 !DECL_NONADDRESSABLE_P (old_field));
9156
9157 if (!new_pos)
9158 {
9159 normalize_offset (&pos, &bitpos, offset_align);
9160 /* Finalize the position. */
9161 DECL_FIELD_OFFSET (new_field) = variable_size (pos);
9162 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
9163 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
9164 DECL_SIZE (new_field) = size;
9165 DECL_SIZE_UNIT (new_field)
9166 = convert (sizetype,
9167 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
9168 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
9169 }
9170
9171 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
9172 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
9173 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
9174 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
9175
9176 return new_field;
9177 }
9178
9179 /* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
9180 it is the minimal size the REP_PART must have. */
9181
9182 static tree
create_rep_part(tree rep_type,tree record_type,tree min_size)9183 create_rep_part (tree rep_type, tree record_type, tree min_size)
9184 {
9185 tree field;
9186
9187 if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
9188 min_size = NULL_TREE;
9189
9190 field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
9191 min_size, NULL_TREE, 0, 1);
9192 DECL_INTERNAL_P (field) = 1;
9193
9194 return field;
9195 }
9196
9197 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
9198
9199 static tree
get_rep_part(tree record_type)9200 get_rep_part (tree record_type)
9201 {
9202 tree field = TYPE_FIELDS (record_type);
9203
9204 /* The REP part is the first field, internal, another record, and its name
9205 starts with an 'R'. */
9206 if (field
9207 && DECL_INTERNAL_P (field)
9208 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
9209 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
9210 return field;
9211
9212 return NULL_TREE;
9213 }
9214
9215 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
9216
9217 tree
get_variant_part(tree record_type)9218 get_variant_part (tree record_type)
9219 {
9220 tree field;
9221
9222 /* The variant part is the only internal field that is a qualified union. */
9223 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
9224 if (DECL_INTERNAL_P (field)
9225 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
9226 return field;
9227
9228 return NULL_TREE;
9229 }
9230
9231 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
9232 the list of variants to be used and RECORD_TYPE is the type of the parent.
9233 POS_LIST is a position list describing the layout of fields present in
9234 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
9235 layout. DEBUG_INFO_P is true if we need to write debug information. */
9236
9237 static tree
create_variant_part_from(tree old_variant_part,vec<variant_desc> variant_list,tree record_type,tree pos_list,vec<subst_pair> subst_list,bool debug_info_p)9238 create_variant_part_from (tree old_variant_part,
9239 vec<variant_desc> variant_list,
9240 tree record_type, tree pos_list,
9241 vec<subst_pair> subst_list,
9242 bool debug_info_p)
9243 {
9244 tree offset = DECL_FIELD_OFFSET (old_variant_part);
9245 tree old_union_type = TREE_TYPE (old_variant_part);
9246 tree new_union_type, new_variant_part;
9247 tree union_field_list = NULL_TREE;
9248 variant_desc *v;
9249 unsigned int i;
9250
9251 /* First create the type of the variant part from that of the old one. */
9252 new_union_type = make_node (QUAL_UNION_TYPE);
9253 TYPE_NAME (new_union_type)
9254 = concat_name (TYPE_NAME (record_type),
9255 IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
9256
9257 /* If the position of the variant part is constant, subtract it from the
9258 size of the type of the parent to get the new size. This manual CSE
9259 reduces the code size when not optimizing. */
9260 if (TREE_CODE (offset) == INTEGER_CST
9261 && TYPE_SIZE (record_type)
9262 && TYPE_SIZE_UNIT (record_type))
9263 {
9264 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
9265 tree first_bit = bit_from_pos (offset, bitpos);
9266 TYPE_SIZE (new_union_type)
9267 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
9268 TYPE_SIZE_UNIT (new_union_type)
9269 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
9270 byte_from_pos (offset, bitpos));
9271 SET_TYPE_ADA_SIZE (new_union_type,
9272 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
9273 first_bit));
9274 SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
9275 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
9276 }
9277 else
9278 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
9279
9280 /* Now finish up the new variants and populate the union type. */
9281 FOR_EACH_VEC_ELT_REVERSE (variant_list, i, v)
9282 {
9283 tree old_field = v->field, new_field;
9284 tree old_variant, old_variant_subpart, new_variant, field_list;
9285
9286 /* Skip variants that don't belong to this nesting level. */
9287 if (DECL_CONTEXT (old_field) != old_union_type)
9288 continue;
9289
9290 /* Retrieve the list of fields already added to the new variant. */
9291 new_variant = v->new_type;
9292 field_list = TYPE_FIELDS (new_variant);
9293
9294 /* If the old variant had a variant subpart, we need to create a new
9295 variant subpart and add it to the field list. */
9296 old_variant = v->type;
9297 old_variant_subpart = get_variant_part (old_variant);
9298 if (old_variant_subpart)
9299 {
9300 tree new_variant_subpart
9301 = create_variant_part_from (old_variant_subpart, variant_list,
9302 new_variant, pos_list, subst_list,
9303 debug_info_p);
9304 DECL_CHAIN (new_variant_subpart) = field_list;
9305 field_list = new_variant_subpart;
9306 }
9307
9308 /* Finish up the new variant and create the field. */
9309 finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p);
9310 compute_record_mode (new_variant);
9311 create_type_decl (TYPE_NAME (new_variant), new_variant, true,
9312 debug_info_p, Empty);
9313
9314 new_field
9315 = create_field_decl_from (old_field, new_variant, new_union_type,
9316 TYPE_SIZE (new_variant),
9317 pos_list, subst_list);
9318 DECL_QUALIFIER (new_field) = v->qual;
9319 DECL_INTERNAL_P (new_field) = 1;
9320 DECL_CHAIN (new_field) = union_field_list;
9321 union_field_list = new_field;
9322 }
9323
9324 /* Finish up the union type and create the variant part. Note that we don't
9325 reverse the field list because VARIANT_LIST has been traversed in reverse
9326 order. */
9327 finish_record_type (new_union_type, union_field_list, 2, debug_info_p);
9328 compute_record_mode (new_union_type);
9329 create_type_decl (TYPE_NAME (new_union_type), new_union_type, true,
9330 debug_info_p, Empty);
9331
9332 new_variant_part
9333 = create_field_decl_from (old_variant_part, new_union_type, record_type,
9334 TYPE_SIZE (new_union_type),
9335 pos_list, subst_list);
9336 DECL_INTERNAL_P (new_variant_part) = 1;
9337
9338 /* With multiple discriminants it is possible for an inner variant to be
9339 statically selected while outer ones are not; in this case, the list
9340 of fields of the inner variant is not flattened and we end up with a
9341 qualified union with a single member. Drop the useless container. */
9342 if (!DECL_CHAIN (union_field_list))
9343 {
9344 DECL_CONTEXT (union_field_list) = record_type;
9345 DECL_FIELD_OFFSET (union_field_list)
9346 = DECL_FIELD_OFFSET (new_variant_part);
9347 DECL_FIELD_BIT_OFFSET (union_field_list)
9348 = DECL_FIELD_BIT_OFFSET (new_variant_part);
9349 SET_DECL_OFFSET_ALIGN (union_field_list,
9350 DECL_OFFSET_ALIGN (new_variant_part));
9351 new_variant_part = union_field_list;
9352 }
9353
9354 return new_variant_part;
9355 }
9356
9357 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
9358 which are both RECORD_TYPE, after applying the substitutions described
9359 in SUBST_LIST. */
9360
9361 static void
copy_and_substitute_in_size(tree new_type,tree old_type,vec<subst_pair> subst_list)9362 copy_and_substitute_in_size (tree new_type, tree old_type,
9363 vec<subst_pair> subst_list)
9364 {
9365 unsigned int i;
9366 subst_pair *s;
9367
9368 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
9369 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
9370 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
9371 SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
9372 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
9373
9374 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
9375 FOR_EACH_VEC_ELT (subst_list, i, s)
9376 TYPE_SIZE (new_type)
9377 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
9378 s->discriminant, s->replacement);
9379
9380 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
9381 FOR_EACH_VEC_ELT (subst_list, i, s)
9382 TYPE_SIZE_UNIT (new_type)
9383 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
9384 s->discriminant, s->replacement);
9385
9386 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
9387 FOR_EACH_VEC_ELT (subst_list, i, s)
9388 SET_TYPE_ADA_SIZE
9389 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
9390 s->discriminant, s->replacement));
9391
9392 /* Finalize the size. */
9393 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
9394 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
9395 }
9396
9397 /* Return true if DISC is a stored discriminant of RECORD_TYPE. */
9398
9399 static inline bool
is_stored_discriminant(Entity_Id discr,Entity_Id record_type)9400 is_stored_discriminant (Entity_Id discr, Entity_Id record_type)
9401 {
9402 if (Is_Unchecked_Union (record_type))
9403 return false;
9404 else if (Is_Tagged_Type (record_type))
9405 return No (Corresponding_Discriminant (discr));
9406 else if (Ekind (record_type) == E_Record_Type)
9407 return Original_Record_Component (discr) == discr;
9408 else
9409 return true;
9410 }
9411
9412 /* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are
9413 both record types, after applying the substitutions described in SUBST_LIST.
9414 DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */
9415
9416 static void
copy_and_substitute_in_layout(Entity_Id gnat_new_type,Entity_Id gnat_old_type,tree gnu_new_type,tree gnu_old_type,vec<subst_pair> gnu_subst_list,bool debug_info_p)9417 copy_and_substitute_in_layout (Entity_Id gnat_new_type,
9418 Entity_Id gnat_old_type,
9419 tree gnu_new_type,
9420 tree gnu_old_type,
9421 vec<subst_pair> gnu_subst_list,
9422 bool debug_info_p)
9423 {
9424 const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
9425 tree gnu_field_list = NULL_TREE;
9426 bool selected_variant, all_constant_pos = true;
9427 vec<variant_desc> gnu_variant_list;
9428
9429 /* Look for REP and variant parts in the old type. */
9430 tree gnu_rep_part = get_rep_part (gnu_old_type);
9431 tree gnu_variant_part = get_variant_part (gnu_old_type);
9432
9433 /* If there is a variant part, we must compute whether the constraints
9434 statically select a particular variant. If so, we simply drop the
9435 qualified union and flatten the list of fields. Otherwise we will
9436 build a new qualified union for the variants that are still relevant. */
9437 if (gnu_variant_part)
9438 {
9439 variant_desc *v;
9440 unsigned int i;
9441
9442 gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part),
9443 gnu_subst_list, vNULL);
9444
9445 /* If all the qualifiers are unconditionally true, the innermost variant
9446 is statically selected. */
9447 selected_variant = true;
9448 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9449 if (!integer_onep (v->qual))
9450 {
9451 selected_variant = false;
9452 break;
9453 }
9454
9455 /* Otherwise, create the new variants. */
9456 if (!selected_variant)
9457 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9458 {
9459 tree old_variant = v->type;
9460 tree new_variant = make_node (RECORD_TYPE);
9461 tree suffix
9462 = concat_name (DECL_NAME (gnu_variant_part),
9463 IDENTIFIER_POINTER (DECL_NAME (v->field)));
9464 TYPE_NAME (new_variant)
9465 = concat_name (TYPE_NAME (gnu_new_type),
9466 IDENTIFIER_POINTER (suffix));
9467 TYPE_REVERSE_STORAGE_ORDER (new_variant)
9468 = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
9469 copy_and_substitute_in_size (new_variant, old_variant,
9470 gnu_subst_list);
9471 v->new_type = new_variant;
9472 }
9473 }
9474 else
9475 {
9476 gnu_variant_list.create (0);
9477 selected_variant = false;
9478 }
9479
9480 /* Make a list of fields and their position in the old type. */
9481 tree gnu_pos_list
9482 = build_position_list (gnu_old_type,
9483 gnu_variant_list.exists () && !selected_variant,
9484 size_zero_node, bitsize_zero_node,
9485 BIGGEST_ALIGNMENT, NULL_TREE);
9486
9487 /* Now go down every component in the new type and compute its size and
9488 position from those of the component in the old type and the stored
9489 constraints of the new type. */
9490 Entity_Id gnat_field, gnat_old_field;
9491 for (gnat_field = First_Entity (gnat_new_type);
9492 Present (gnat_field);
9493 gnat_field = Next_Entity (gnat_field))
9494 if ((Ekind (gnat_field) == E_Component
9495 || (Ekind (gnat_field) == E_Discriminant
9496 && is_stored_discriminant (gnat_field, gnat_new_type)))
9497 && (gnat_old_field = is_subtype
9498 ? Original_Record_Component (gnat_field)
9499 : Corresponding_Record_Component (gnat_field))
9500 && Underlying_Type (Scope (gnat_old_field)) == gnat_old_type
9501 && present_gnu_tree (gnat_old_field))
9502 {
9503 Name_Id gnat_name = Chars (gnat_field);
9504 tree gnu_old_field = get_gnu_tree (gnat_old_field);
9505 if (TREE_CODE (gnu_old_field) == COMPONENT_REF)
9506 gnu_old_field = TREE_OPERAND (gnu_old_field, 1);
9507 tree gnu_context = DECL_CONTEXT (gnu_old_field);
9508 tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
9509 tree gnu_cont_type, gnu_last = NULL_TREE;
9510
9511 /* If the type is the same, retrieve the GCC type from the
9512 old field to take into account possible adjustments. */
9513 if (Etype (gnat_field) == Etype (gnat_old_field))
9514 gnu_field_type = TREE_TYPE (gnu_old_field);
9515 else
9516 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
9517
9518 /* If there was a component clause, the field types must be the same
9519 for the old and new types, so copy the data from the old field to
9520 avoid recomputation here. Also if the field is justified modular
9521 and the optimization in gnat_to_gnu_field was applied. */
9522 if (Present (Component_Clause (gnat_old_field))
9523 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
9524 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
9525 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
9526 == TREE_TYPE (gnu_old_field)))
9527 {
9528 gnu_size = DECL_SIZE (gnu_old_field);
9529 gnu_field_type = TREE_TYPE (gnu_old_field);
9530 }
9531
9532 /* If the old field was packed and of constant size, we have to get the
9533 old size here as it might differ from what the Etype conveys and the
9534 latter might overlap with the following field. Try to arrange the
9535 type for possible better packing along the way. */
9536 else if (DECL_PACKED (gnu_old_field)
9537 && TREE_CODE (DECL_SIZE (gnu_old_field)) == INTEGER_CST)
9538 {
9539 gnu_size = DECL_SIZE (gnu_old_field);
9540 if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
9541 && !TYPE_FAT_POINTER_P (gnu_field_type)
9542 && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
9543 gnu_field_type = make_packable_type (gnu_field_type, true);
9544 }
9545
9546 else
9547 gnu_size = TYPE_SIZE (gnu_field_type);
9548
9549 /* If the context of the old field is the old type or its REP part,
9550 put the field directly in the new type; otherwise look up the
9551 context in the variant list and put the field either in the new
9552 type if there is a selected variant or in one new variant. */
9553 if (gnu_context == gnu_old_type
9554 || (gnu_rep_part && gnu_context == TREE_TYPE (gnu_rep_part)))
9555 gnu_cont_type = gnu_new_type;
9556 else
9557 {
9558 variant_desc *v;
9559 unsigned int i;
9560 tree rep_part;
9561
9562 FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
9563 if (gnu_context == v->type
9564 || ((rep_part = get_rep_part (v->type))
9565 && gnu_context == TREE_TYPE (rep_part)))
9566 break;
9567
9568 if (v)
9569 gnu_cont_type = selected_variant ? gnu_new_type : v->new_type;
9570 else
9571 /* The front-end may pass us "ghost" components if it fails to
9572 recognize that a constrain statically selects a particular
9573 variant. Discard them. */
9574 continue;
9575 }
9576
9577 /* Now create the new field modeled on the old one. */
9578 gnu_field
9579 = create_field_decl_from (gnu_old_field, gnu_field_type,
9580 gnu_cont_type, gnu_size,
9581 gnu_pos_list, gnu_subst_list);
9582 gnu_pos = DECL_FIELD_OFFSET (gnu_field);
9583
9584 /* If the context is a variant, put it in the new variant directly. */
9585 if (gnu_cont_type != gnu_new_type)
9586 {
9587 DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
9588 TYPE_FIELDS (gnu_cont_type) = gnu_field;
9589 }
9590
9591 /* To match the layout crafted in components_to_record, if this is
9592 the _Tag or _Parent field, put it before any other fields. */
9593 else if (gnat_name == Name_uTag || gnat_name == Name_uParent)
9594 gnu_field_list = chainon (gnu_field_list, gnu_field);
9595
9596 /* Similarly, if this is the _Controller field, put it before the
9597 other fields except for the _Tag or _Parent field. */
9598 else if (gnat_name == Name_uController && gnu_last)
9599 {
9600 DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
9601 DECL_CHAIN (gnu_last) = gnu_field;
9602 }
9603
9604 /* Otherwise, put it after the other fields. */
9605 else
9606 {
9607 DECL_CHAIN (gnu_field) = gnu_field_list;
9608 gnu_field_list = gnu_field;
9609 if (!gnu_last)
9610 gnu_last = gnu_field;
9611 if (TREE_CODE (gnu_pos) != INTEGER_CST)
9612 all_constant_pos = false;
9613 }
9614
9615 /* For a stored discriminant in a derived type, replace the field. */
9616 if (!is_subtype && Ekind (gnat_field) == E_Discriminant)
9617 {
9618 tree gnu_ref = get_gnu_tree (gnat_field);
9619 TREE_OPERAND (gnu_ref, 1) = gnu_field;
9620 }
9621 else
9622 save_gnu_tree (gnat_field, gnu_field, false);
9623 }
9624
9625 /* If there is no variant list or a selected variant and the fields all have
9626 constant position, put them in order of increasing position to match that
9627 of constant CONSTRUCTORs. */
9628 if ((!gnu_variant_list.exists () || selected_variant) && all_constant_pos)
9629 {
9630 const int len = list_length (gnu_field_list);
9631 tree *field_arr = XALLOCAVEC (tree, len), t = gnu_field_list;
9632
9633 for (int i = 0; t; t = DECL_CHAIN (t), i++)
9634 field_arr[i] = t;
9635
9636 qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
9637
9638 gnu_field_list = NULL_TREE;
9639 for (int i = 0; i < len; i++)
9640 {
9641 DECL_CHAIN (field_arr[i]) = gnu_field_list;
9642 gnu_field_list = field_arr[i];
9643 }
9644 }
9645
9646 /* If there is a variant list and no selected variant, we need to create the
9647 nest of variant parts from the old nest. */
9648 else if (gnu_variant_list.exists () && !selected_variant)
9649 {
9650 tree new_variant_part
9651 = create_variant_part_from (gnu_variant_part, gnu_variant_list,
9652 gnu_new_type, gnu_pos_list,
9653 gnu_subst_list, debug_info_p);
9654 DECL_CHAIN (new_variant_part) = gnu_field_list;
9655 gnu_field_list = new_variant_part;
9656 }
9657
9658 gnu_variant_list.release ();
9659 gnu_subst_list.release ();
9660
9661 gnu_field_list = nreverse (gnu_field_list);
9662
9663 /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
9664 Otherwise sizes and alignment must be computed independently. */
9665 if (is_subtype)
9666 {
9667 finish_record_type (gnu_new_type, gnu_field_list, 2, debug_info_p);
9668 compute_record_mode (gnu_new_type);
9669 }
9670 else
9671 finish_record_type (gnu_new_type, gnu_field_list, 1, debug_info_p);
9672
9673 /* Now go through the entities again looking for Itypes that we have not yet
9674 elaborated (e.g. Etypes of fields that have Original_Components). */
9675 for (Entity_Id gnat_field = First_Entity (gnat_new_type);
9676 Present (gnat_field);
9677 gnat_field = Next_Entity (gnat_field))
9678 if ((Ekind (gnat_field) == E_Component
9679 || Ekind (gnat_field) == E_Discriminant)
9680 && Is_Itype (Etype (gnat_field))
9681 && !present_gnu_tree (Etype (gnat_field)))
9682 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
9683 }
9684
9685 /* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
9686 the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
9687 the original array type if it has been translated. This association is a
9688 parallel type for GNAT encodings or a debug type for standard DWARF. Note
9689 that for standard DWARF, we also want to get the original type name. */
9690
9691 static void
associate_original_type_to_packed_array(tree gnu_type,Entity_Id gnat_entity)9692 associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity)
9693 {
9694 Entity_Id gnat_original_array_type
9695 = Underlying_Type (Original_Array_Type (gnat_entity));
9696 tree gnu_original_array_type;
9697
9698 if (!present_gnu_tree (gnat_original_array_type))
9699 return;
9700
9701 gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type);
9702
9703 if (TYPE_IS_DUMMY_P (gnu_original_array_type))
9704 return;
9705
9706 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
9707 {
9708 tree original_name = TYPE_NAME (gnu_original_array_type);
9709
9710 if (TREE_CODE (original_name) == TYPE_DECL)
9711 original_name = DECL_NAME (original_name);
9712
9713 SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type);
9714 TYPE_NAME (gnu_type) = original_name;
9715 }
9716 else
9717 add_parallel_type (gnu_type, gnu_original_array_type);
9718 }
9719
9720 /* Given a type T, a FIELD_DECL F, and a replacement value R, return an
9721 equivalent type with adjusted size expressions where all occurrences
9722 of references to F in a PLACEHOLDER_EXPR have been replaced by R.
9723
9724 The function doesn't update the layout of the type, i.e. it assumes
9725 that the substitution is purely formal. That's why the replacement
9726 value R must itself contain a PLACEHOLDER_EXPR. */
9727
9728 tree
substitute_in_type(tree t,tree f,tree r)9729 substitute_in_type (tree t, tree f, tree r)
9730 {
9731 tree nt;
9732
9733 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
9734
9735 switch (TREE_CODE (t))
9736 {
9737 case INTEGER_TYPE:
9738 case ENUMERAL_TYPE:
9739 case BOOLEAN_TYPE:
9740 case REAL_TYPE:
9741
9742 /* First the domain types of arrays. */
9743 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
9744 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
9745 {
9746 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
9747 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
9748
9749 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
9750 return t;
9751
9752 nt = copy_type (t);
9753 TYPE_GCC_MIN_VALUE (nt) = low;
9754 TYPE_GCC_MAX_VALUE (nt) = high;
9755
9756 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
9757 SET_TYPE_INDEX_TYPE
9758 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
9759
9760 return nt;
9761 }
9762
9763 /* Then the subtypes. */
9764 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
9765 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
9766 {
9767 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
9768 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
9769
9770 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
9771 return t;
9772
9773 nt = copy_type (t);
9774 SET_TYPE_RM_MIN_VALUE (nt, low);
9775 SET_TYPE_RM_MAX_VALUE (nt, high);
9776
9777 return nt;
9778 }
9779
9780 return t;
9781
9782 case COMPLEX_TYPE:
9783 nt = substitute_in_type (TREE_TYPE (t), f, r);
9784 if (nt == TREE_TYPE (t))
9785 return t;
9786
9787 return build_complex_type (nt);
9788
9789 case FUNCTION_TYPE:
9790 /* These should never show up here. */
9791 gcc_unreachable ();
9792
9793 case ARRAY_TYPE:
9794 {
9795 tree component = substitute_in_type (TREE_TYPE (t), f, r);
9796 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
9797
9798 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
9799 return t;
9800
9801 nt = build_nonshared_array_type (component, domain);
9802 SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
9803 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
9804 SET_TYPE_MODE (nt, TYPE_MODE (t));
9805 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9806 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9807 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
9808 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
9809 if (TYPE_REVERSE_STORAGE_ORDER (t))
9810 set_reverse_storage_order_on_array_type (nt);
9811 if (TYPE_NONALIASED_COMPONENT (t))
9812 set_nonaliased_component_on_array_type (nt);
9813 return nt;
9814 }
9815
9816 case RECORD_TYPE:
9817 case UNION_TYPE:
9818 case QUAL_UNION_TYPE:
9819 {
9820 bool changed_field = false;
9821 tree field;
9822
9823 /* Start out with no fields, make new fields, and chain them
9824 in. If we haven't actually changed the type of any field,
9825 discard everything we've done and return the old type. */
9826 nt = copy_type (t);
9827 TYPE_FIELDS (nt) = NULL_TREE;
9828
9829 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
9830 {
9831 tree new_field = copy_node (field), new_n;
9832
9833 new_n = substitute_in_type (TREE_TYPE (field), f, r);
9834 if (new_n != TREE_TYPE (field))
9835 {
9836 TREE_TYPE (new_field) = new_n;
9837 changed_field = true;
9838 }
9839
9840 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
9841 if (new_n != DECL_FIELD_OFFSET (field))
9842 {
9843 DECL_FIELD_OFFSET (new_field) = new_n;
9844 changed_field = true;
9845 }
9846
9847 /* Do the substitution inside the qualifier, if any. */
9848 if (TREE_CODE (t) == QUAL_UNION_TYPE)
9849 {
9850 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
9851 if (new_n != DECL_QUALIFIER (field))
9852 {
9853 DECL_QUALIFIER (new_field) = new_n;
9854 changed_field = true;
9855 }
9856 }
9857
9858 DECL_CONTEXT (new_field) = nt;
9859 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
9860
9861 DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
9862 TYPE_FIELDS (nt) = new_field;
9863 }
9864
9865 if (!changed_field)
9866 return t;
9867
9868 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
9869 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
9870 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
9871 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
9872 return nt;
9873 }
9874
9875 default:
9876 return t;
9877 }
9878 }
9879
9880 /* Return the RM size of GNU_TYPE. This is the actual number of bits
9881 needed to represent the object. */
9882
9883 tree
rm_size(tree gnu_type)9884 rm_size (tree gnu_type)
9885 {
9886 /* For integral types, we store the RM size explicitly. */
9887 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
9888 return TYPE_RM_SIZE (gnu_type);
9889
9890 /* Return the RM size of the actual data plus the size of the template. */
9891 if (TREE_CODE (gnu_type) == RECORD_TYPE
9892 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
9893 return
9894 size_binop (PLUS_EXPR,
9895 rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
9896 DECL_SIZE (TYPE_FIELDS (gnu_type)));
9897
9898 /* For record or union types, we store the size explicitly. */
9899 if (RECORD_OR_UNION_TYPE_P (gnu_type)
9900 && !TYPE_FAT_POINTER_P (gnu_type)
9901 && TYPE_ADA_SIZE (gnu_type))
9902 return TYPE_ADA_SIZE (gnu_type);
9903
9904 /* For other types, this is just the size. */
9905 return TYPE_SIZE (gnu_type);
9906 }
9907
9908 /* Return the name to be used for GNAT_ENTITY. If a type, create a
9909 fully-qualified name, possibly with type information encoding.
9910 Otherwise, return the name. */
9911
9912 static const char *
get_entity_char(Entity_Id gnat_entity)9913 get_entity_char (Entity_Id gnat_entity)
9914 {
9915 Get_Encoded_Name (gnat_entity);
9916 return ggc_strdup (Name_Buffer);
9917 }
9918
9919 tree
get_entity_name(Entity_Id gnat_entity)9920 get_entity_name (Entity_Id gnat_entity)
9921 {
9922 Get_Encoded_Name (gnat_entity);
9923 return get_identifier_with_length (Name_Buffer, Name_Len);
9924 }
9925
9926 /* Return an identifier representing the external name to be used for
9927 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
9928 and the specified suffix. */
9929
9930 tree
create_concat_name(Entity_Id gnat_entity,const char * suffix)9931 create_concat_name (Entity_Id gnat_entity, const char *suffix)
9932 {
9933 const Entity_Kind kind = Ekind (gnat_entity);
9934 const bool has_suffix = (suffix != NULL);
9935 String_Template temp = {1, has_suffix ? strlen (suffix) : 0};
9936 String_Pointer sp = {suffix, &temp};
9937
9938 Get_External_Name (gnat_entity, has_suffix, sp);
9939
9940 /* A variable using the Stdcall convention lives in a DLL. We adjust
9941 its name to use the jump table, the _imp__NAME contains the address
9942 for the NAME variable. */
9943 if ((kind == E_Variable || kind == E_Constant)
9944 && Has_Stdcall_Convention (gnat_entity))
9945 {
9946 const int len = strlen (STDCALL_PREFIX) + Name_Len;
9947 char *new_name = (char *) alloca (len + 1);
9948 strcpy (new_name, STDCALL_PREFIX);
9949 strcat (new_name, Name_Buffer);
9950 return get_identifier_with_length (new_name, len);
9951 }
9952
9953 return get_identifier_with_length (Name_Buffer, Name_Len);
9954 }
9955
9956 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
9957 string, return a new IDENTIFIER_NODE that is the concatenation of
9958 the name followed by "___" and the specified suffix. */
9959
9960 tree
concat_name(tree gnu_name,const char * suffix)9961 concat_name (tree gnu_name, const char *suffix)
9962 {
9963 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
9964 char *new_name = (char *) alloca (len + 1);
9965 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
9966 strcat (new_name, "___");
9967 strcat (new_name, suffix);
9968 return get_identifier_with_length (new_name, len);
9969 }
9970
9971 /* Initialize data structures of the decl.c module. */
9972
9973 void
init_gnat_decl(void)9974 init_gnat_decl (void)
9975 {
9976 /* Initialize the cache of annotated values. */
9977 annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
9978
9979 /* Initialize the association of dummy types with subprograms. */
9980 dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
9981 }
9982
9983 /* Destroy data structures of the decl.c module. */
9984
9985 void
destroy_gnat_decl(void)9986 destroy_gnat_decl (void)
9987 {
9988 /* Destroy the cache of annotated values. */
9989 annotate_value_cache->empty ();
9990 annotate_value_cache = NULL;
9991
9992 /* Destroy the association of dummy types with subprograms. */
9993 dummy_to_subprog_map->empty ();
9994 dummy_to_subprog_map = NULL;
9995 }
9996
9997 #include "gt-ada-decl.h"
9998