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