gnat_rm.texi: Document new mechanism Short_Descriptor.
[official-gcc.git] / gcc / ada / gcc-interface / decl.c
blobf7f4a0d1b61b58b9893cb6634abe1100c0908afa
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
20 * *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
23 * *
24 ****************************************************************************/
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "tm.h"
30 #include "tree.h"
31 #include "flags.h"
32 #include "toplev.h"
33 #include "convert.h"
34 #include "ggc.h"
35 #include "obstack.h"
36 #include "target.h"
37 #include "expr.h"
39 #include "ada.h"
40 #include "types.h"
41 #include "atree.h"
42 #include "elists.h"
43 #include "namet.h"
44 #include "nlists.h"
45 #include "repinfo.h"
46 #include "snames.h"
47 #include "stringt.h"
48 #include "uintp.h"
49 #include "fe.h"
50 #include "sinfo.h"
51 #include "einfo.h"
52 #include "hashtab.h"
53 #include "ada-tree.h"
54 #include "gigi.h"
56 #ifndef MAX_FIXED_MODE_SIZE
57 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
58 #endif
60 /* Convention_Stdcall should be processed in a specific way on Windows targets
61 only. The macro below is a helper to avoid having to check for a Windows
62 specific attribute throughout this unit. */
64 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
65 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
66 #else
67 #define Has_Stdcall_Convention(E) (0)
68 #endif
70 /* Stack realignment for functions with foreign conventions is provided on a
71 per back-end basis now, as it is handled by the prologue expanders and not
72 as part of the function's body any more. It might be requested by way of a
73 dedicated function type attribute on the targets that support it.
75 We need a way to avoid setting the attribute on the targets that don't
76 support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
78 It is defined on targets where the circuitry is available, and indicates
79 whether the realignment is needed for 'main'. We use this to decide for
80 foreign subprograms as well.
82 It is not defined on targets where the circuitry is not implemented, and
83 we just never set the attribute in these cases.
85 Whether it is defined on all targets that would need it in theory is
86 not entirely clear. We currently trust the base GCC settings for this
87 purpose. */
89 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
90 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
91 #endif
93 struct incomplete
95 struct incomplete *next;
96 tree old_type;
97 Entity_Id full_type;
100 /* These variables are used to defer recursively expanding incomplete types
101 while we are processing an array, a record or a subprogram type. */
102 static int defer_incomplete_level = 0;
103 static struct incomplete *defer_incomplete_list;
105 /* This variable is used to delay expanding From_With_Type types until the
106 end of the spec. */
107 static struct incomplete *defer_limited_with;
109 /* These variables are used to defer finalizing types. The element of the
110 list is the TYPE_DECL associated with the type. */
111 static int defer_finalize_level = 0;
112 static VEC (tree,heap) *defer_finalize_list;
114 /* A hash table used to cache the result of annotate_value. */
115 static GTY ((if_marked ("tree_int_map_marked_p"),
116 param_is (struct tree_int_map))) htab_t annotate_value_cache;
118 static void copy_alias_set (tree, tree);
119 static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
120 static bool allocatable_size_p (tree, bool);
121 static void prepend_one_attribute_to (struct attrib **,
122 enum attr_type, tree, tree, Node_Id);
123 static void prepend_attributes (Entity_Id, struct attrib **);
124 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
125 static bool is_variable_size (tree);
126 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
127 bool, bool);
128 static tree make_packable_type (tree, bool);
129 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
130 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
131 bool *);
132 static bool same_discriminant_p (Entity_Id, Entity_Id);
133 static bool array_type_has_nonaliased_component (Entity_Id, tree);
134 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
135 bool, bool, bool, bool);
136 static Uint annotate_value (tree);
137 static void annotate_rep (Entity_Id, tree);
138 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
139 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
140 static void set_rm_size (Uint, tree, Entity_Id);
141 static tree make_type_from_size (tree, tree, bool);
142 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
143 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
144 static void check_ok_for_atomic (tree, Entity_Id, bool);
145 static int compatible_signatures_p (tree ftype1, tree ftype2);
146 static void rest_of_type_decl_compilation_no_defer (tree);
148 /* Return true if GNAT_ADDRESS is a compile time known value.
149 In particular catch System'To_Address. */
151 static bool
152 compile_time_known_address_p (Node_Id gnat_address)
154 return ((Nkind (gnat_address) == N_Unchecked_Type_Conversion
155 && Compile_Time_Known_Value (Expression (gnat_address)))
156 || Compile_Time_Known_Value (gnat_address));
159 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
160 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
161 refer to an Ada type. */
163 tree
164 gnat_to_gnu_type (Entity_Id gnat_entity)
166 tree gnu_decl;
168 /* The back end never attempts to annotate generic types */
169 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
170 return void_type_node;
172 /* Convert the ada entity type into a GCC TYPE_DECL node. */
173 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
174 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
175 return TREE_TYPE (gnu_decl);
178 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
179 entity, this routine returns the equivalent GCC tree for that entity
180 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
181 defining identifier.
183 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
184 initial value (in GCC tree form). This is optional for variables.
185 For renamed entities, GNU_EXPR gives the object being renamed.
187 DEFINITION is nonzero if this call is intended for a definition. This is
188 used for separate compilation where it necessary to know whether an
189 external declaration or a definition should be created if the GCC equivalent
190 was not created previously. The value of 1 is normally used for a nonzero
191 DEFINITION, but a value of 2 is used in special circumstances, defined in
192 the code. */
194 tree
195 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
197 Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
198 tree gnu_entity_id;
199 tree gnu_type = NULL_TREE;
200 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
201 GNAT tree. This node will be associated with the GNAT node by calling
202 the save_gnu_tree routine at the end of the `switch' statement. */
203 tree gnu_decl = NULL_TREE;
204 /* true if we have already saved gnu_decl as a gnat association. */
205 bool saved = false;
206 /* Nonzero if we incremented defer_incomplete_level. */
207 bool this_deferred = false;
208 /* Nonzero if we incremented force_global. */
209 bool this_global = false;
210 /* Nonzero if we should check to see if elaborated during processing. */
211 bool maybe_present = false;
212 /* Nonzero if we made GNU_DECL and its type here. */
213 bool this_made_decl = false;
214 struct attrib *attr_list = NULL;
215 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
216 || debug_info_level == DINFO_LEVEL_VERBOSE);
217 Entity_Kind kind = Ekind (gnat_entity);
218 Entity_Id gnat_temp;
219 unsigned int esize
220 = ((Known_Esize (gnat_entity)
221 && UI_Is_In_Int_Range (Esize (gnat_entity)))
222 ? MIN (UI_To_Int (Esize (gnat_entity)),
223 IN (kind, Float_Kind)
224 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
225 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
226 : LONG_LONG_TYPE_SIZE)
227 : LONG_LONG_TYPE_SIZE);
228 tree gnu_size = 0;
229 bool imported_p
230 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
231 unsigned int align = 0;
233 /* Since a use of an Itype is a definition, process it as such if it
234 is not in a with'ed unit. */
236 if (!definition && Is_Itype (gnat_entity)
237 && !present_gnu_tree (gnat_entity)
238 && In_Extended_Main_Code_Unit (gnat_entity))
240 /* Ensure that we are in a subprogram mentioned in the Scope
241 chain of this entity, our current scope is global,
242 or that we encountered a task or entry (where we can't currently
243 accurately check scoping). */
244 if (!current_function_decl
245 || DECL_ELABORATION_PROC_P (current_function_decl))
247 process_type (gnat_entity);
248 return get_gnu_tree (gnat_entity);
251 for (gnat_temp = Scope (gnat_entity);
252 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
254 if (Is_Type (gnat_temp))
255 gnat_temp = Underlying_Type (gnat_temp);
257 if (Ekind (gnat_temp) == E_Subprogram_Body)
258 gnat_temp
259 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
261 if (IN (Ekind (gnat_temp), Subprogram_Kind)
262 && Present (Protected_Body_Subprogram (gnat_temp)))
263 gnat_temp = Protected_Body_Subprogram (gnat_temp);
265 if (Ekind (gnat_temp) == E_Entry
266 || Ekind (gnat_temp) == E_Entry_Family
267 || Ekind (gnat_temp) == E_Task_Type
268 || (IN (Ekind (gnat_temp), Subprogram_Kind)
269 && present_gnu_tree (gnat_temp)
270 && (current_function_decl
271 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
273 process_type (gnat_entity);
274 return get_gnu_tree (gnat_entity);
278 /* This abort means the entity "gnat_entity" has an incorrect scope,
279 i.e. that its scope does not correspond to the subprogram in which
280 it is declared */
281 gcc_unreachable ();
284 /* If this is entity 0, something went badly wrong. */
285 gcc_assert (Present (gnat_entity));
287 /* If we've already processed this entity, return what we got last time.
288 If we are defining the node, we should not have already processed it.
289 In that case, we will abort below when we try to save a new GCC tree for
290 this object. We also need to handle the case of getting a dummy type
291 when a Full_View exists. */
293 if (present_gnu_tree (gnat_entity)
294 && (!definition || (Is_Type (gnat_entity) && imported_p)))
296 gnu_decl = get_gnu_tree (gnat_entity);
298 if (TREE_CODE (gnu_decl) == TYPE_DECL
299 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
300 && IN (kind, Incomplete_Or_Private_Kind)
301 && Present (Full_View (gnat_entity)))
303 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
304 NULL_TREE, 0);
306 save_gnu_tree (gnat_entity, NULL_TREE, false);
307 save_gnu_tree (gnat_entity, gnu_decl, false);
310 return gnu_decl;
313 /* If this is a numeric or enumeral type, or an access type, a nonzero
314 Esize must be specified unless it was specified by the programmer. */
315 gcc_assert (!Unknown_Esize (gnat_entity)
316 || Has_Size_Clause (gnat_entity)
317 || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
318 && (!IN (kind, Access_Kind)
319 || kind == E_Access_Protected_Subprogram_Type
320 || kind == E_Anonymous_Access_Protected_Subprogram_Type
321 || kind == E_Access_Subtype)));
323 /* Likewise, RM_Size must be specified for all discrete and fixed-point
324 types. */
325 gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
326 || !Unknown_RM_Size (gnat_entity));
328 /* Get the name of the entity and set up the line number and filename of
329 the original definition for use in any decl we make. */
330 gnu_entity_id = get_entity_name (gnat_entity);
331 Sloc_to_locus (Sloc (gnat_entity), &input_location);
333 /* If we get here, it means we have not yet done anything with this
334 entity. If we are not defining it here, it must be external,
335 otherwise we should have defined it already. */
336 gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
337 || kind == E_Discriminant || kind == E_Component
338 || kind == E_Label
339 || (kind == E_Constant && Present (Full_View (gnat_entity)))
340 || IN (kind, Type_Kind));
342 /* For cases when we are not defining (i.e., we are referencing from
343 another compilation unit) Public entities, show we are at global level
344 for the purpose of computing scopes. Don't do this for components or
345 discriminants since the relevant test is whether or not the record is
346 being defined. But do this for Imported functions or procedures in
347 all cases. */
348 if ((!definition && Is_Public (gnat_entity)
349 && !Is_Statically_Allocated (gnat_entity)
350 && kind != E_Discriminant && kind != E_Component)
351 || (Is_Imported (gnat_entity)
352 && (kind == E_Function || kind == E_Procedure)))
353 force_global++, this_global = true;
355 /* Handle any attributes directly attached to the entity. */
356 if (Has_Gigi_Rep_Item (gnat_entity))
357 prepend_attributes (gnat_entity, &attr_list);
359 /* Machine_Attributes on types are expected to be propagated to subtypes.
360 The corresponding Gigi_Rep_Items are only attached to the first subtype
361 though, so we handle the propagation here. */
362 if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
363 && !Is_First_Subtype (gnat_entity)
364 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
365 prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
367 switch (kind)
369 case E_Constant:
370 /* If this is a use of a deferred constant, get its full
371 declaration. */
372 if (!definition && Present (Full_View (gnat_entity)))
374 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
375 gnu_expr, 0);
376 saved = true;
377 break;
380 /* If we have an external constant that we are not defining, get the
381 expression that is was defined to represent. We may throw that
382 expression away later if it is not a constant. Do not retrieve the
383 expression if it is an aggregate or allocator, because in complex
384 instantiation contexts it may not be expanded */
385 if (!definition
386 && Present (Expression (Declaration_Node (gnat_entity)))
387 && !No_Initialization (Declaration_Node (gnat_entity))
388 && (Nkind (Expression (Declaration_Node (gnat_entity)))
389 != N_Aggregate)
390 && (Nkind (Expression (Declaration_Node (gnat_entity)))
391 != N_Allocator))
392 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
394 /* Ignore deferred constant definitions; they are processed fully in the
395 front-end. For deferred constant references get the full definition.
396 On the other hand, constants that are renamings are handled like
397 variable renamings. If No_Initialization is set, this is not a
398 deferred constant but a constant whose value is built manually. */
399 if (definition && !gnu_expr
400 && !No_Initialization (Declaration_Node (gnat_entity))
401 && No (Renamed_Object (gnat_entity)))
403 gnu_decl = error_mark_node;
404 saved = true;
405 break;
407 else if (!definition && IN (kind, Incomplete_Or_Private_Kind)
408 && Present (Full_View (gnat_entity)))
410 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
411 NULL_TREE, 0);
412 saved = true;
413 break;
416 goto object;
418 case E_Exception:
419 /* We used to special case VMS exceptions here to directly map them to
420 their associated condition code. Since this code had to be masked
421 dynamically to strip off the severity bits, this caused trouble in
422 the GCC/ZCX case because the "type" pointers we store in the tables
423 have to be static. We now don't special case here anymore, and let
424 the regular processing take place, which leaves us with a regular
425 exception data object for VMS exceptions too. The condition code
426 mapping is taken care of by the front end and the bitmasking by the
427 runtime library. */
428 goto object;
430 case E_Discriminant:
431 case E_Component:
433 /* The GNAT record where the component was defined. */
434 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
436 /* If the variable is an inherited record component (in the case of
437 extended record types), just return the inherited entity, which
438 must be a FIELD_DECL. Likewise for discriminants.
439 For discriminants of untagged records which have explicit
440 stored discriminants, return the entity for the corresponding
441 stored discriminant. Also use Original_Record_Component
442 if the record has a private extension. */
444 if (Present (Original_Record_Component (gnat_entity))
445 && Original_Record_Component (gnat_entity) != gnat_entity)
447 gnu_decl
448 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
449 gnu_expr, definition);
450 saved = true;
451 break;
454 /* If the enclosing record has explicit stored discriminants,
455 then it is an untagged record. If the Corresponding_Discriminant
456 is not empty then this must be a renamed discriminant and its
457 Original_Record_Component must point to the corresponding explicit
458 stored discriminant (i.e., we should have taken the previous
459 branch). */
461 else if (Present (Corresponding_Discriminant (gnat_entity))
462 && Is_Tagged_Type (gnat_record))
464 /* A tagged record has no explicit stored discriminants. */
466 gcc_assert (First_Discriminant (gnat_record)
467 == First_Stored_Discriminant (gnat_record));
468 gnu_decl
469 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
470 gnu_expr, definition);
471 saved = true;
472 break;
475 else if (Present (CR_Discriminant (gnat_entity))
476 && type_annotate_only)
478 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
479 gnu_expr, definition);
480 saved = true;
481 break;
484 /* If the enclosing record has explicit stored discriminants,
485 then it is an untagged record. If the Corresponding_Discriminant
486 is not empty then this must be a renamed discriminant and its
487 Original_Record_Component must point to the corresponding explicit
488 stored discriminant (i.e., we should have taken the first
489 branch). */
491 else if (Present (Corresponding_Discriminant (gnat_entity))
492 && (First_Discriminant (gnat_record)
493 != First_Stored_Discriminant (gnat_record)))
494 gcc_unreachable ();
496 /* Otherwise, if we are not defining this and we have no GCC type
497 for the containing record, make one for it. Then we should
498 have made our own equivalent. */
499 else if (!definition && !present_gnu_tree (gnat_record))
501 /* ??? If this is in a record whose scope is a protected
502 type and we have an Original_Record_Component, use it.
503 This is a workaround for major problems in protected type
504 handling. */
505 Entity_Id Scop = Scope (Scope (gnat_entity));
506 if ((Is_Protected_Type (Scop)
507 || (Is_Private_Type (Scop)
508 && Present (Full_View (Scop))
509 && Is_Protected_Type (Full_View (Scop))))
510 && Present (Original_Record_Component (gnat_entity)))
512 gnu_decl
513 = gnat_to_gnu_entity (Original_Record_Component
514 (gnat_entity),
515 gnu_expr, 0);
516 saved = true;
517 break;
520 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
521 gnu_decl = get_gnu_tree (gnat_entity);
522 saved = true;
523 break;
526 else
527 /* Here we have no GCC type and this is a reference rather than a
528 definition. This should never happen. Most likely the cause is a
529 reference before declaration in the gnat tree for gnat_entity. */
530 gcc_unreachable ();
533 case E_Loop_Parameter:
534 case E_Out_Parameter:
535 case E_Variable:
537 /* Simple variables, loop variables, Out parameters, and exceptions. */
538 object:
540 bool used_by_ref = false;
541 bool const_flag
542 = ((kind == E_Constant || kind == E_Variable)
543 && Is_True_Constant (gnat_entity)
544 && (((Nkind (Declaration_Node (gnat_entity))
545 == N_Object_Declaration)
546 && Present (Expression (Declaration_Node (gnat_entity))))
547 || Present (Renamed_Object (gnat_entity))));
548 bool inner_const_flag = const_flag;
549 bool static_p = Is_Statically_Allocated (gnat_entity);
550 bool mutable_p = false;
551 tree gnu_ext_name = NULL_TREE;
552 tree renamed_obj = NULL_TREE;
553 tree gnu_object_size;
555 if (Present (Renamed_Object (gnat_entity)) && !definition)
557 if (kind == E_Exception)
558 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
559 NULL_TREE, 0);
560 else
561 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
564 /* Get the type after elaborating the renamed object. */
565 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
567 /* For a debug renaming declaration, build a pure debug entity. */
568 if (Present (Debug_Renaming_Link (gnat_entity)))
570 rtx addr;
571 gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type);
572 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
573 if (global_bindings_p ())
574 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
575 else
576 addr = stack_pointer_rtx;
577 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
578 gnat_pushdecl (gnu_decl, gnat_entity);
579 break;
582 /* If this is a loop variable, its type should be the base type.
583 This is because the code for processing a loop determines whether
584 a normal loop end test can be done by comparing the bounds of the
585 loop against those of the base type, which is presumed to be the
586 size used for computation. But this is not correct when the size
587 of the subtype is smaller than the type. */
588 if (kind == E_Loop_Parameter)
589 gnu_type = get_base_type (gnu_type);
591 /* Reject non-renamed objects whose types are unconstrained arrays or
592 any object whose type is a dummy type or VOID_TYPE. */
594 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
595 && No (Renamed_Object (gnat_entity)))
596 || TYPE_IS_DUMMY_P (gnu_type)
597 || TREE_CODE (gnu_type) == VOID_TYPE)
599 gcc_assert (type_annotate_only);
600 if (this_global)
601 force_global--;
602 return error_mark_node;
605 /* If an alignment is specified, use it if valid. Note that
606 exceptions are objects but don't have alignments. We must do this
607 before we validate the size, since the alignment can affect the
608 size. */
609 if (kind != E_Exception && Known_Alignment (gnat_entity))
611 gcc_assert (Present (Alignment (gnat_entity)));
612 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
613 TYPE_ALIGN (gnu_type));
614 gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
615 "PAD", false, definition, true);
618 /* If we are defining the object, see if it has a Size value and
619 validate it if so. If we are not defining the object and a Size
620 clause applies, simply retrieve the value. We don't want to ignore
621 the clause and it is expected to have been validated already. Then
622 get the new type, if any. */
623 if (definition)
624 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
625 gnat_entity, VAR_DECL, false,
626 Has_Size_Clause (gnat_entity));
627 else if (Has_Size_Clause (gnat_entity))
628 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
630 if (gnu_size)
632 gnu_type
633 = make_type_from_size (gnu_type, gnu_size,
634 Has_Biased_Representation (gnat_entity));
636 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
637 gnu_size = NULL_TREE;
640 /* If this object has self-referential size, it must be a record with
641 a default value. We are supposed to allocate an object of the
642 maximum size in this case unless it is a constant with an
643 initializing expression, in which case we can get the size from
644 that. Note that the resulting size may still be a variable, so
645 this may end up with an indirect allocation. */
646 if (No (Renamed_Object (gnat_entity))
647 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
649 if (gnu_expr && kind == E_Constant)
651 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
652 if (CONTAINS_PLACEHOLDER_P (size))
654 /* If the initializing expression is itself a constant,
655 despite having a nominal type with self-referential
656 size, we can get the size directly from it. */
657 if (TREE_CODE (gnu_expr) == COMPONENT_REF
658 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
659 == RECORD_TYPE
660 && TYPE_IS_PADDING_P
661 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
662 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
663 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
664 || DECL_READONLY_ONCE_ELAB
665 (TREE_OPERAND (gnu_expr, 0))))
666 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
667 else
668 gnu_size
669 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
671 else
672 gnu_size = size;
674 /* We may have no GNU_EXPR because No_Initialization is
675 set even though there's an Expression. */
676 else if (kind == E_Constant
677 && (Nkind (Declaration_Node (gnat_entity))
678 == N_Object_Declaration)
679 && Present (Expression (Declaration_Node (gnat_entity))))
680 gnu_size
681 = TYPE_SIZE (gnat_to_gnu_type
682 (Etype
683 (Expression (Declaration_Node (gnat_entity)))));
684 else
686 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
687 mutable_p = true;
691 /* If the size is zero bytes, make it one byte since some linkers have
692 trouble with zero-sized objects. If the object will have a
693 template, that will make it nonzero so don't bother. Also avoid
694 doing that for an object renaming or an object with an address
695 clause, as we would lose useful information on the view size
696 (e.g. for null array slices) and we are not allocating the object
697 here anyway. */
698 if (((gnu_size
699 && integer_zerop (gnu_size)
700 && !TREE_OVERFLOW (gnu_size))
701 || (TYPE_SIZE (gnu_type)
702 && integer_zerop (TYPE_SIZE (gnu_type))
703 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
704 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
705 || !Is_Array_Type (Etype (gnat_entity)))
706 && !Present (Renamed_Object (gnat_entity))
707 && !Present (Address_Clause (gnat_entity)))
708 gnu_size = bitsize_unit_node;
710 /* If this is an object with no specified size and alignment, and
711 if either it is atomic or we are not optimizing alignment for
712 space and it is composite and not an exception, an Out parameter
713 or a reference to another object, and the size of its type is a
714 constant, set the alignment to the smallest one which is not
715 smaller than the size, with an appropriate cap. */
716 if (!gnu_size && align == 0
717 && (Is_Atomic (gnat_entity)
718 || (!Optimize_Alignment_Space (gnat_entity)
719 && kind != E_Exception
720 && kind != E_Out_Parameter
721 && Is_Composite_Type (Etype (gnat_entity))
722 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
723 && !imported_p
724 && No (Renamed_Object (gnat_entity))
725 && No (Address_Clause (gnat_entity))))
726 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
728 /* No point in jumping through all the hoops needed in order
729 to support BIGGEST_ALIGNMENT if we don't really have to. */
730 unsigned int align_cap = Is_Atomic (gnat_entity)
731 ? BIGGEST_ALIGNMENT
732 : get_mode_alignment (word_mode);
734 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
735 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
736 align = align_cap;
737 else
738 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
740 /* But make sure not to under-align the object. */
741 if (align <= TYPE_ALIGN (gnu_type))
742 align = 0;
744 /* And honor the minimum valid atomic alignment, if any. */
745 #ifdef MINIMUM_ATOMIC_ALIGNMENT
746 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
747 align = MINIMUM_ATOMIC_ALIGNMENT;
748 #endif
751 /* If the object is set to have atomic components, find the component
752 type and validate it.
754 ??? Note that we ignore Has_Volatile_Components on objects; it's
755 not at all clear what to do in that case. */
757 if (Has_Atomic_Components (gnat_entity))
759 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
760 ? TREE_TYPE (gnu_type) : gnu_type);
762 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
763 && TYPE_MULTI_ARRAY_P (gnu_inner))
764 gnu_inner = TREE_TYPE (gnu_inner);
766 check_ok_for_atomic (gnu_inner, gnat_entity, true);
769 /* Now check if the type of the object allows atomic access. Note
770 that we must test the type, even if this object has size and
771 alignment to allow such access, because we will be going
772 inside the padded record to assign to the object. We could fix
773 this by always copying via an intermediate value, but it's not
774 clear it's worth the effort. */
775 if (Is_Atomic (gnat_entity))
776 check_ok_for_atomic (gnu_type, gnat_entity, false);
778 /* If this is an aliased object with an unconstrained nominal subtype,
779 make a type that includes the template. */
780 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
781 && Is_Array_Type (Etype (gnat_entity))
782 && !type_annotate_only)
784 tree gnu_fat
785 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
787 gnu_type
788 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
789 concat_id_with_name (gnu_entity_id,
790 "UNC"));
793 #ifdef MINIMUM_ATOMIC_ALIGNMENT
794 /* If the size is a constant and no alignment is specified, force
795 the alignment to be the minimum valid atomic alignment. The
796 restriction on constant size avoids problems with variable-size
797 temporaries; if the size is variable, there's no issue with
798 atomic access. Also don't do this for a constant, since it isn't
799 necessary and can interfere with constant replacement. Finally,
800 do not do it for Out parameters since that creates an
801 size inconsistency with In parameters. */
802 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
803 && !FLOAT_TYPE_P (gnu_type)
804 && !const_flag && No (Renamed_Object (gnat_entity))
805 && !imported_p && No (Address_Clause (gnat_entity))
806 && kind != E_Out_Parameter
807 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
808 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
809 align = MINIMUM_ATOMIC_ALIGNMENT;
810 #endif
812 /* Make a new type with the desired size and alignment, if needed.
813 But do not take into account alignment promotions to compute the
814 size of the object. */
815 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
816 if (gnu_size || align > 0)
817 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
818 "PAD", false, definition,
819 gnu_size ? true : false);
821 /* Make a volatile version of this object's type if we are to make
822 the object volatile. We also interpret 13.3(19) conservatively
823 and disallow any optimizations for an object covered by it. */
824 if ((Treat_As_Volatile (gnat_entity)
825 || (Is_Exported (gnat_entity)
826 /* Exclude exported constants created by the compiler,
827 which should boil down to static dispatch tables and
828 make it possible to put them in read-only memory. */
829 && (Comes_From_Source (gnat_entity) || !const_flag))
830 || Is_Imported (gnat_entity)
831 || Present (Address_Clause (gnat_entity)))
832 && !TYPE_VOLATILE (gnu_type))
833 gnu_type = build_qualified_type (gnu_type,
834 (TYPE_QUALS (gnu_type)
835 | TYPE_QUAL_VOLATILE));
837 /* If this is a renaming, avoid as much as possible to create a new
838 object. However, in several cases, creating it is required.
839 This processing needs to be applied to the raw expression so
840 as to make it more likely to rename the underlying object. */
841 if (Present (Renamed_Object (gnat_entity)))
843 bool create_normal_object = false;
845 /* If the renamed object had padding, strip off the reference
846 to the inner object and reset our type. */
847 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
848 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
849 == RECORD_TYPE
850 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
851 /* Strip useless conversions around the object. */
852 || TREE_CODE (gnu_expr) == NOP_EXPR)
854 gnu_expr = TREE_OPERAND (gnu_expr, 0);
855 gnu_type = TREE_TYPE (gnu_expr);
858 /* Case 1: If this is a constant renaming stemming from a function
859 call, treat it as a normal object whose initial value is what
860 is being renamed. RM 3.3 says that the result of evaluating a
861 function call is a constant object. As a consequence, it can
862 be the inner object of a constant renaming. In this case, the
863 renaming must be fully instantiated, i.e. it cannot be a mere
864 reference to (part of) an existing object. */
865 if (const_flag)
867 tree inner_object = gnu_expr;
868 while (handled_component_p (inner_object))
869 inner_object = TREE_OPERAND (inner_object, 0);
870 if (TREE_CODE (inner_object) == CALL_EXPR)
871 create_normal_object = true;
874 /* Otherwise, see if we can proceed with a stabilized version of
875 the renamed entity or if we need to make a new object. */
876 if (!create_normal_object)
878 tree maybe_stable_expr = NULL_TREE;
879 bool stable = false;
881 /* Case 2: If the renaming entity need not be materialized and
882 the renamed expression is something we can stabilize, use
883 that for the renaming. At the global level, we can only do
884 this if we know no SAVE_EXPRs need be made, because the
885 expression we return might be used in arbitrary conditional
886 branches so we must force the SAVE_EXPRs evaluation
887 immediately and this requires a function context. */
888 if (!Materialize_Entity (gnat_entity)
889 && (!global_bindings_p ()
890 || (staticp (gnu_expr)
891 && !TREE_SIDE_EFFECTS (gnu_expr))))
893 maybe_stable_expr
894 = maybe_stabilize_reference (gnu_expr, true, &stable);
896 if (stable)
898 gnu_decl = maybe_stable_expr;
899 /* ??? No DECL_EXPR is created so we need to mark
900 the expression manually lest it is shared. */
901 if (global_bindings_p ())
902 mark_visited (&gnu_decl);
903 save_gnu_tree (gnat_entity, gnu_decl, true);
904 saved = true;
905 break;
908 /* The stabilization failed. Keep maybe_stable_expr
909 untouched here to let the pointer case below know
910 about that failure. */
913 /* Case 3: If this is a constant renaming and creating a
914 new object is allowed and cheap, treat it as a normal
915 object whose initial value is what is being renamed. */
916 if (const_flag && Is_Elementary_Type (Etype (gnat_entity)))
919 /* Case 4: Make this into a constant pointer to the object we
920 are to rename and attach the object to the pointer if it is
921 something we can stabilize.
923 From the proper scope, attached objects will be referenced
924 directly instead of indirectly via the pointer to avoid
925 subtle aliasing problems with non-addressable entities.
926 They have to be stable because we must not evaluate the
927 variables in the expression every time the renaming is used.
928 The pointer is called a "renaming" pointer in this case.
930 In the rare cases where we cannot stabilize the renamed
931 object, we just make a "bare" pointer, and the renamed
932 entity is always accessed indirectly through it. */
933 else
935 gnu_type = build_reference_type (gnu_type);
936 inner_const_flag = TREE_READONLY (gnu_expr);
937 const_flag = true;
939 /* If the previous attempt at stabilizing failed, there
940 is no point in trying again and we reuse the result
941 without attaching it to the pointer. In this case it
942 will only be used as the initializing expression of
943 the pointer and thus needs no special treatment with
944 regard to multiple evaluations. */
945 if (maybe_stable_expr)
948 /* Otherwise, try to stabilize and attach the expression
949 to the pointer if the stabilization succeeds.
951 Note that this might introduce SAVE_EXPRs and we don't
952 check whether we're at the global level or not. This
953 is fine since we are building a pointer initializer and
954 neither the pointer nor the initializing expression can
955 be accessed before the pointer elaboration has taken
956 place in a correct program.
958 These SAVE_EXPRs will be evaluated at the right place
959 by either the evaluation of the initializer for the
960 non-global case or the elaboration code for the global
961 case, and will be attached to the elaboration procedure
962 in the latter case. */
963 else
965 maybe_stable_expr
966 = maybe_stabilize_reference (gnu_expr, true, &stable);
968 if (stable)
969 renamed_obj = maybe_stable_expr;
971 /* Attaching is actually performed downstream, as soon
972 as we have a VAR_DECL for the pointer we make. */
975 gnu_expr
976 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
978 gnu_size = NULL_TREE;
979 used_by_ref = true;
984 /* If this is an aliased object whose nominal subtype is unconstrained,
985 the object is a record that contains both the template and
986 the object. If there is an initializer, it will have already
987 been converted to the right type, but we need to create the
988 template if there is no initializer. */
989 else if (definition
990 && TREE_CODE (gnu_type) == RECORD_TYPE
991 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
992 /* Beware that padding might have been introduced
993 via maybe_pad_type above. */
994 || (TYPE_IS_PADDING_P (gnu_type)
995 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
996 == RECORD_TYPE
997 && TYPE_CONTAINS_TEMPLATE_P
998 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
999 && !gnu_expr)
1001 tree template_field
1002 = TYPE_IS_PADDING_P (gnu_type)
1003 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1004 : TYPE_FIELDS (gnu_type);
1006 gnu_expr
1007 = gnat_build_constructor
1008 (gnu_type,
1009 tree_cons
1010 (template_field,
1011 build_template (TREE_TYPE (template_field),
1012 TREE_TYPE (TREE_CHAIN (template_field)),
1013 NULL_TREE),
1014 NULL_TREE));
1017 /* Convert the expression to the type of the object except in the
1018 case where the object's type is unconstrained or the object's type
1019 is a padded record whose field is of self-referential size. In
1020 the former case, converting will generate unnecessary evaluations
1021 of the CONSTRUCTOR to compute the size and in the latter case, we
1022 want to only copy the actual data. */
1023 if (gnu_expr
1024 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1025 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1026 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1027 && TYPE_IS_PADDING_P (gnu_type)
1028 && (CONTAINS_PLACEHOLDER_P
1029 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1030 gnu_expr = convert (gnu_type, gnu_expr);
1032 /* If this is a pointer and it does not have an initializing
1033 expression, initialize it to NULL, unless the object is
1034 imported. */
1035 if (definition
1036 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
1037 && !Is_Imported (gnat_entity) && !gnu_expr)
1038 gnu_expr = integer_zero_node;
1040 /* If we are defining the object and it has an Address clause we must
1041 get the address expression from the saved GCC tree for the
1042 object if the object has a Freeze_Node. Otherwise, we elaborate
1043 the address expression here since the front-end has guaranteed
1044 in that case that the elaboration has no effects. Note that
1045 only the latter mechanism is currently in use. */
1046 if (definition && Present (Address_Clause (gnat_entity)))
1048 tree gnu_address
1049 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
1050 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
1052 save_gnu_tree (gnat_entity, NULL_TREE, false);
1054 /* Ignore the size. It's either meaningless or was handled
1055 above. */
1056 gnu_size = NULL_TREE;
1057 /* Convert the type of the object to a reference type that can
1058 alias everything as per 13.3(19). */
1059 gnu_type
1060 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1061 gnu_address = convert (gnu_type, gnu_address);
1062 used_by_ref = true;
1063 const_flag = !Is_Public (gnat_entity)
1064 || compile_time_known_address_p (Expression (Address_Clause
1065 (gnat_entity)));
1067 /* If we don't have an initializing expression for the underlying
1068 variable, the initializing expression for the pointer is the
1069 specified address. Otherwise, we have to make a COMPOUND_EXPR
1070 to assign both the address and the initial value. */
1071 if (!gnu_expr)
1072 gnu_expr = gnu_address;
1073 else
1074 gnu_expr
1075 = build2 (COMPOUND_EXPR, gnu_type,
1076 build_binary_op
1077 (MODIFY_EXPR, NULL_TREE,
1078 build_unary_op (INDIRECT_REF, NULL_TREE,
1079 gnu_address),
1080 gnu_expr),
1081 gnu_address);
1084 /* If it has an address clause and we are not defining it, mark it
1085 as an indirect object. Likewise for Stdcall objects that are
1086 imported. */
1087 if ((!definition && Present (Address_Clause (gnat_entity)))
1088 || (Is_Imported (gnat_entity)
1089 && Has_Stdcall_Convention (gnat_entity)))
1091 /* Convert the type of the object to a reference type that can
1092 alias everything as per 13.3(19). */
1093 gnu_type
1094 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1095 gnu_size = NULL_TREE;
1097 /* No point in taking the address of an initializing expression
1098 that isn't going to be used. */
1099 gnu_expr = NULL_TREE;
1101 /* If it has an address clause whose value is known at compile
1102 time, make the object a CONST_DECL. This will avoid a
1103 useless dereference. */
1104 if (Present (Address_Clause (gnat_entity)))
1106 Node_Id gnat_address
1107 = Expression (Address_Clause (gnat_entity));
1109 if (compile_time_known_address_p (gnat_address))
1111 gnu_expr = gnat_to_gnu (gnat_address);
1112 const_flag = true;
1116 used_by_ref = true;
1119 /* If we are at top level and this object is of variable size,
1120 make the actual type a hidden pointer to the real type and
1121 make the initializer be a memory allocation and initialization.
1122 Likewise for objects we aren't defining (presumed to be
1123 external references from other packages), but there we do
1124 not set up an initialization.
1126 If the object's size overflows, make an allocator too, so that
1127 Storage_Error gets raised. Note that we will never free
1128 such memory, so we presume it never will get allocated. */
1130 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1131 global_bindings_p () || !definition
1132 || static_p)
1133 || (gnu_size
1134 && ! allocatable_size_p (gnu_size,
1135 global_bindings_p () || !definition
1136 || static_p)))
1138 gnu_type = build_reference_type (gnu_type);
1139 gnu_size = NULL_TREE;
1140 used_by_ref = true;
1141 const_flag = true;
1143 /* In case this was a aliased object whose nominal subtype is
1144 unconstrained, the pointer above will be a thin pointer and
1145 build_allocator will automatically make the template.
1147 If we have a template initializer only (that we made above),
1148 pretend there is none and rely on what build_allocator creates
1149 again anyway. Otherwise (if we have a full initializer), get
1150 the data part and feed that to build_allocator.
1152 If we are elaborating a mutable object, tell build_allocator to
1153 ignore a possibly simpler size from the initializer, if any, as
1154 we must allocate the maximum possible size in this case. */
1156 if (definition)
1158 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1160 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1161 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1163 gnu_alloc_type
1164 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1166 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1167 && 1 == VEC_length (constructor_elt,
1168 CONSTRUCTOR_ELTS (gnu_expr)))
1169 gnu_expr = 0;
1170 else
1171 gnu_expr
1172 = build_component_ref
1173 (gnu_expr, NULL_TREE,
1174 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1175 false);
1178 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1179 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1180 && !Is_Imported (gnat_entity))
1181 post_error ("?Storage_Error will be raised at run-time!",
1182 gnat_entity);
1184 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1185 0, 0, gnat_entity, mutable_p);
1187 else
1189 gnu_expr = NULL_TREE;
1190 const_flag = false;
1194 /* If this object would go into the stack and has an alignment larger
1195 than the largest stack alignment the back-end can honor, resort to
1196 a variable of "aligning type". */
1197 if (!global_bindings_p () && !static_p && definition
1198 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1200 /* Create the new variable. No need for extra room before the
1201 aligned field as this is in automatic storage. */
1202 tree gnu_new_type
1203 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1204 TYPE_SIZE_UNIT (gnu_type),
1205 BIGGEST_ALIGNMENT, 0);
1206 tree gnu_new_var
1207 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1208 NULL_TREE, gnu_new_type, NULL_TREE, false,
1209 false, false, false, NULL, gnat_entity);
1211 /* Initialize the aligned field if we have an initializer. */
1212 if (gnu_expr)
1213 add_stmt_with_node
1214 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1215 build_component_ref
1216 (gnu_new_var, NULL_TREE,
1217 TYPE_FIELDS (gnu_new_type), false),
1218 gnu_expr),
1219 gnat_entity);
1221 /* And setup this entity as a reference to the aligned field. */
1222 gnu_type = build_reference_type (gnu_type);
1223 gnu_expr
1224 = build_unary_op
1225 (ADDR_EXPR, gnu_type,
1226 build_component_ref (gnu_new_var, NULL_TREE,
1227 TYPE_FIELDS (gnu_new_type), false));
1229 gnu_size = NULL_TREE;
1230 used_by_ref = true;
1231 const_flag = true;
1234 if (const_flag)
1235 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1236 | TYPE_QUAL_CONST));
1238 /* Convert the expression to the type of the object except in the
1239 case where the object's type is unconstrained or the object's type
1240 is a padded record whose field is of self-referential size. In
1241 the former case, converting will generate unnecessary evaluations
1242 of the CONSTRUCTOR to compute the size and in the latter case, we
1243 want to only copy the actual data. */
1244 if (gnu_expr
1245 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1246 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1247 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1248 && TYPE_IS_PADDING_P (gnu_type)
1249 && (CONTAINS_PLACEHOLDER_P
1250 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1251 gnu_expr = convert (gnu_type, gnu_expr);
1253 /* If this name is external or there was a name specified, use it,
1254 unless this is a VMS exception object since this would conflict
1255 with the symbol we need to export in addition. Don't use the
1256 Interface_Name if there is an address clause (see CD30005). */
1257 if (!Is_VMS_Exception (gnat_entity)
1258 && ((Present (Interface_Name (gnat_entity))
1259 && No (Address_Clause (gnat_entity)))
1260 || (Is_Public (gnat_entity)
1261 && (!Is_Imported (gnat_entity)
1262 || Is_Exported (gnat_entity)))))
1263 gnu_ext_name = create_concat_name (gnat_entity, 0);
1265 /* If this is constant initialized to a static constant and the
1266 object has an aggregate type, force it to be statically
1267 allocated. */
1268 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1269 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1270 && (AGGREGATE_TYPE_P (gnu_type)
1271 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1272 && TYPE_IS_PADDING_P (gnu_type))))
1273 static_p = true;
1275 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1276 gnu_expr, const_flag,
1277 Is_Public (gnat_entity),
1278 imported_p || !definition,
1279 static_p, attr_list, gnat_entity);
1280 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1281 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1282 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1284 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1285 if (global_bindings_p ())
1287 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1288 record_global_renaming_pointer (gnu_decl);
1292 if (definition && DECL_SIZE (gnu_decl)
1293 && get_block_jmpbuf_decl ()
1294 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1295 || (flag_stack_check && !STACK_CHECK_BUILTIN
1296 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1297 STACK_CHECK_MAX_VAR_SIZE))))
1298 add_stmt_with_node (build_call_1_expr
1299 (update_setjmp_buf_decl,
1300 build_unary_op (ADDR_EXPR, NULL_TREE,
1301 get_block_jmpbuf_decl ())),
1302 gnat_entity);
1304 /* If this is a public constant or we're not optimizing and we're not
1305 making a VAR_DECL for it, make one just for export or debugger use.
1306 Likewise if the address is taken or if either the object or type is
1307 aliased. Make an external declaration for a reference, unless this
1308 is a Standard entity since there no real symbol at the object level
1309 for these. */
1310 if (TREE_CODE (gnu_decl) == CONST_DECL
1311 && (definition || Sloc (gnat_entity) > Standard_Location)
1312 && ((Is_Public (gnat_entity)
1313 && !Present (Address_Clause (gnat_entity)))
1314 || optimize == 0
1315 || Address_Taken (gnat_entity)
1316 || Is_Aliased (gnat_entity)
1317 || Is_Aliased (Etype (gnat_entity))))
1319 tree gnu_corr_var
1320 = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1321 gnu_expr, true, Is_Public (gnat_entity),
1322 !definition, static_p, NULL,
1323 gnat_entity);
1325 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1327 /* As debugging information will be generated for the variable,
1328 do not generate information for the constant. */
1329 DECL_IGNORED_P (gnu_decl) = true;
1332 /* If this is declared in a block that contains a block with an
1333 exception handler, we must force this variable in memory to
1334 suppress an invalid optimization. */
1335 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1336 && Exception_Mechanism != Back_End_Exceptions)
1337 TREE_ADDRESSABLE (gnu_decl) = 1;
1339 gnu_type = TREE_TYPE (gnu_decl);
1341 /* Back-annotate Alignment and Esize of the object if not already
1342 known, except for when the object is actually a pointer to the
1343 real object, since alignment and size of a pointer don't have
1344 anything to do with those of the designated object. Note that
1345 we pick the values of the type, not those of the object, to
1346 shield ourselves from low-level platform-dependent adjustments
1347 like alignment promotion. This is both consistent with all the
1348 treatment above, where alignment and size are set on the type of
1349 the object and not on the object directly, and makes it possible
1350 to support confirming representation clauses in all cases. */
1352 if (!used_by_ref && Unknown_Alignment (gnat_entity))
1353 Set_Alignment (gnat_entity,
1354 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
1356 if (!used_by_ref && Unknown_Esize (gnat_entity))
1358 if (TREE_CODE (gnu_type) == RECORD_TYPE
1359 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1360 gnu_object_size
1361 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
1363 Set_Esize (gnat_entity, annotate_value (gnu_object_size));
1366 break;
1368 case E_Void:
1369 /* Return a TYPE_DECL for "void" that we previously made. */
1370 gnu_decl = void_type_decl_node;
1371 break;
1373 case E_Enumeration_Type:
1374 /* A special case, for the types Character and Wide_Character in
1375 Standard, we do not list all the literals. So if the literals
1376 are not specified, make this an unsigned type. */
1377 if (No (First_Literal (gnat_entity)))
1379 gnu_type = make_unsigned_type (esize);
1380 TYPE_NAME (gnu_type) = gnu_entity_id;
1382 /* Set the TYPE_STRING_FLAG for Ada Character and
1383 Wide_Character types. This is needed by the dwarf-2 debug writer to
1384 distinguish between unsigned integer types and character types. */
1385 TYPE_STRING_FLAG (gnu_type) = 1;
1386 break;
1389 /* Normal case of non-character type, or non-Standard character type */
1391 /* Here we have a list of enumeral constants in First_Literal.
1392 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1393 the list to be places into TYPE_FIELDS. Each node in the list
1394 is a TREE_LIST node whose TREE_VALUE is the literal name
1395 and whose TREE_PURPOSE is the value of the literal.
1397 Esize contains the number of bits needed to represent the enumeral
1398 type, Type_Low_Bound also points to the first literal and
1399 Type_High_Bound points to the last literal. */
1401 Entity_Id gnat_literal;
1402 tree gnu_literal_list = NULL_TREE;
1404 if (Is_Unsigned_Type (gnat_entity))
1405 gnu_type = make_unsigned_type (esize);
1406 else
1407 gnu_type = make_signed_type (esize);
1409 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1411 for (gnat_literal = First_Literal (gnat_entity);
1412 Present (gnat_literal);
1413 gnat_literal = Next_Literal (gnat_literal))
1415 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1416 gnu_type);
1417 tree gnu_literal
1418 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1419 gnu_type, gnu_value, true, false, false,
1420 false, NULL, gnat_literal);
1422 save_gnu_tree (gnat_literal, gnu_literal, false);
1423 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1424 gnu_value, gnu_literal_list);
1427 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1429 /* Note that the bounds are updated at the end of this function
1430 because to avoid an infinite recursion when we get the bounds of
1431 this type, since those bounds are objects of this type. */
1433 break;
1435 case E_Signed_Integer_Type:
1436 case E_Ordinary_Fixed_Point_Type:
1437 case E_Decimal_Fixed_Point_Type:
1438 /* For integer types, just make a signed type the appropriate number
1439 of bits. */
1440 gnu_type = make_signed_type (esize);
1441 break;
1443 case E_Modular_Integer_Type:
1444 /* For modular types, make the unsigned type of the proper number of
1445 bits and then set up the modulus, if required. */
1447 enum machine_mode mode;
1448 tree gnu_modulus;
1449 tree gnu_high = 0;
1451 if (Is_Packed_Array_Type (gnat_entity))
1452 esize = UI_To_Int (RM_Size (gnat_entity));
1454 /* Find the smallest mode at least ESIZE bits wide and make a class
1455 using that mode. */
1457 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1458 GET_MODE_BITSIZE (mode) < esize;
1459 mode = GET_MODE_WIDER_MODE (mode))
1462 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1463 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1464 = (Is_Packed_Array_Type (gnat_entity)
1465 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
1467 /* Get the modulus in this type. If it overflows, assume it is because
1468 it is equal to 2**Esize. Note that there is no overflow checking
1469 done on unsigned type, so we detect the overflow by looking for
1470 a modulus of zero, which is otherwise invalid. */
1471 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1473 if (!integer_zerop (gnu_modulus))
1475 TYPE_MODULAR_P (gnu_type) = 1;
1476 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1477 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1478 convert (gnu_type, integer_one_node));
1481 /* If we have to set TYPE_PRECISION different from its natural value,
1482 make a subtype to do do. Likewise if there is a modulus and
1483 it is not one greater than TYPE_MAX_VALUE. */
1484 if (TYPE_PRECISION (gnu_type) != esize
1485 || (TYPE_MODULAR_P (gnu_type)
1486 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1488 tree gnu_subtype = make_node (INTEGER_TYPE);
1490 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1491 TREE_TYPE (gnu_subtype) = gnu_type;
1492 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1493 TYPE_MAX_VALUE (gnu_subtype)
1494 = TYPE_MODULAR_P (gnu_type)
1495 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1496 TYPE_PRECISION (gnu_subtype) = esize;
1497 TYPE_UNSIGNED (gnu_subtype) = 1;
1498 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1499 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1500 = (Is_Packed_Array_Type (gnat_entity)
1501 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
1502 layout_type (gnu_subtype);
1504 gnu_type = gnu_subtype;
1507 break;
1509 case E_Signed_Integer_Subtype:
1510 case E_Enumeration_Subtype:
1511 case E_Modular_Integer_Subtype:
1512 case E_Ordinary_Fixed_Point_Subtype:
1513 case E_Decimal_Fixed_Point_Subtype:
1515 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1516 that we do not want to call build_range_type since we would
1517 like each subtype node to be distinct. This will be important
1518 when memory aliasing is implemented.
1520 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1521 parent type; this fact is used by the arithmetic conversion
1522 functions.
1524 We elaborate the Ancestor_Subtype if it is not in the current
1525 unit and one of our bounds is non-static. We do this to ensure
1526 consistent naming in the case where several subtypes share the same
1527 bounds by always elaborating the first such subtype first, thus
1528 using its name. */
1530 if (!definition
1531 && Present (Ancestor_Subtype (gnat_entity))
1532 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1533 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1534 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1535 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1536 gnu_expr, 0);
1538 gnu_type = make_node (INTEGER_TYPE);
1539 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1541 /* Set the precision to the Esize except for bit-packed arrays and
1542 subtypes of Standard.Boolean. */
1543 if (Is_Packed_Array_Type (gnat_entity)
1544 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1546 esize = UI_To_Int (RM_Size (gnat_entity));
1547 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1549 else if (TREE_CODE (TREE_TYPE (gnu_type)) == BOOLEAN_TYPE)
1550 esize = 1;
1552 TYPE_PRECISION (gnu_type) = esize;
1554 TYPE_MIN_VALUE (gnu_type)
1555 = convert (TREE_TYPE (gnu_type),
1556 elaborate_expression (Type_Low_Bound (gnat_entity),
1557 gnat_entity,
1558 get_identifier ("L"), definition, 1,
1559 Needs_Debug_Info (gnat_entity)));
1561 TYPE_MAX_VALUE (gnu_type)
1562 = convert (TREE_TYPE (gnu_type),
1563 elaborate_expression (Type_High_Bound (gnat_entity),
1564 gnat_entity,
1565 get_identifier ("U"), definition, 1,
1566 Needs_Debug_Info (gnat_entity)));
1568 /* One of the above calls might have caused us to be elaborated,
1569 so don't blow up if so. */
1570 if (present_gnu_tree (gnat_entity))
1572 maybe_present = true;
1573 break;
1576 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1577 = Has_Biased_Representation (gnat_entity);
1579 /* This should be an unsigned type if the lower bound is constant
1580 and non-negative or if the base type is unsigned; a signed type
1581 otherwise. */
1582 TYPE_UNSIGNED (gnu_type)
1583 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1584 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1585 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1586 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1587 || Is_Unsigned_Type (gnat_entity));
1589 layout_type (gnu_type);
1591 /* Inherit our alias set from what we're a subtype of. Subtypes
1592 are not different types and a pointer can designate any instance
1593 within a subtype hierarchy. */
1594 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1596 /* If the type we are dealing with is to represent a packed array,
1597 we need to have the bits left justified on big-endian targets
1598 and right justified on little-endian targets. We also need to
1599 ensure that when the value is read (e.g. for comparison of two
1600 such values), we only get the good bits, since the unused bits
1601 are uninitialized. Both goals are accomplished by wrapping the
1602 modular value in an enclosing struct. */
1603 if (Is_Packed_Array_Type (gnat_entity)
1604 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1606 tree gnu_field_type = gnu_type;
1607 tree gnu_field;
1609 TYPE_RM_SIZE_NUM (gnu_field_type)
1610 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1611 gnu_type = make_node (RECORD_TYPE);
1612 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1614 /* Propagate the alignment of the modular type to the record.
1615 This means that bitpacked arrays have "ceil" alignment for
1616 their size, which may seem counter-intuitive but makes it
1617 possible to easily overlay them on modular types. */
1618 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1619 TYPE_PACKED (gnu_type) = 1;
1621 /* Create a stripped-down declaration of the original type, mainly
1622 for debugging. */
1623 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1624 NULL, true, debug_info_p, gnat_entity);
1626 /* Don't notify the field as "addressable", since we won't be taking
1627 it's address and it would prevent create_field_decl from making a
1628 bitfield. */
1629 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1630 gnu_field_type, gnu_type, 1, 0, 0, 0);
1632 finish_record_type (gnu_type, gnu_field, 0, false);
1633 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1634 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1636 copy_alias_set (gnu_type, gnu_field_type);
1639 /* If the type we are dealing with has got a smaller alignment than the
1640 natural one, we need to wrap it up in a record type and under-align
1641 the latter. We reuse the padding machinery for this purpose. */
1642 else if (Known_Alignment (gnat_entity)
1643 && UI_Is_In_Int_Range (Alignment (gnat_entity))
1644 && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
1645 && align < TYPE_ALIGN (gnu_type))
1647 tree gnu_field_type = gnu_type;
1648 tree gnu_field;
1650 gnu_type = make_node (RECORD_TYPE);
1651 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1653 TYPE_ALIGN (gnu_type) = align;
1654 TYPE_PACKED (gnu_type) = 1;
1656 /* Create a stripped-down declaration of the original type, mainly
1657 for debugging. */
1658 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1659 NULL, true, debug_info_p, gnat_entity);
1661 /* Don't notify the field as "addressable", since we won't be taking
1662 it's address and it would prevent create_field_decl from making a
1663 bitfield. */
1664 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1665 gnu_field_type, gnu_type, 1, 0, 0, 0);
1667 finish_record_type (gnu_type, gnu_field, 0, false);
1668 TYPE_IS_PADDING_P (gnu_type) = 1;
1669 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1671 copy_alias_set (gnu_type, gnu_field_type);
1674 /* Otherwise reset the alignment lest we computed it above. */
1675 else
1676 align = 0;
1678 break;
1680 case E_Floating_Point_Type:
1681 /* If this is a VAX floating-point type, use an integer of the proper
1682 size. All the operations will be handled with ASM statements. */
1683 if (Vax_Float (gnat_entity))
1685 gnu_type = make_signed_type (esize);
1686 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1687 SET_TYPE_DIGITS_VALUE (gnu_type,
1688 UI_To_gnu (Digits_Value (gnat_entity),
1689 sizetype));
1690 break;
1693 /* The type of the Low and High bounds can be our type if this is
1694 a type from Standard, so set them at the end of the function. */
1695 gnu_type = make_node (REAL_TYPE);
1696 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1697 layout_type (gnu_type);
1698 break;
1700 case E_Floating_Point_Subtype:
1701 if (Vax_Float (gnat_entity))
1703 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1704 break;
1708 if (!definition
1709 && Present (Ancestor_Subtype (gnat_entity))
1710 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1711 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1712 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1713 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1714 gnu_expr, 0);
1716 gnu_type = make_node (REAL_TYPE);
1717 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1718 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1720 TYPE_MIN_VALUE (gnu_type)
1721 = convert (TREE_TYPE (gnu_type),
1722 elaborate_expression (Type_Low_Bound (gnat_entity),
1723 gnat_entity, get_identifier ("L"),
1724 definition, 1,
1725 Needs_Debug_Info (gnat_entity)));
1727 TYPE_MAX_VALUE (gnu_type)
1728 = convert (TREE_TYPE (gnu_type),
1729 elaborate_expression (Type_High_Bound (gnat_entity),
1730 gnat_entity, get_identifier ("U"),
1731 definition, 1,
1732 Needs_Debug_Info (gnat_entity)));
1734 /* One of the above calls might have caused us to be elaborated,
1735 so don't blow up if so. */
1736 if (present_gnu_tree (gnat_entity))
1738 maybe_present = true;
1739 break;
1742 layout_type (gnu_type);
1744 /* Inherit our alias set from what we're a subtype of, as for
1745 integer subtypes. */
1746 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1748 break;
1750 /* Array and String Types and Subtypes
1752 Unconstrained array types are represented by E_Array_Type and
1753 constrained array types are represented by E_Array_Subtype. There
1754 are no actual objects of an unconstrained array type; all we have
1755 are pointers to that type.
1757 The following fields are defined on array types and subtypes:
1759 Component_Type Component type of the array.
1760 Number_Dimensions Number of dimensions (an int).
1761 First_Index Type of first index. */
1763 case E_String_Type:
1764 case E_Array_Type:
1766 tree gnu_template_fields = NULL_TREE;
1767 tree gnu_template_type = make_node (RECORD_TYPE);
1768 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1769 tree gnu_fat_type = make_node (RECORD_TYPE);
1770 int ndim = Number_Dimensions (gnat_entity);
1771 int firstdim
1772 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1773 int nextdim
1774 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1775 int index;
1776 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1777 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1778 tree gnu_comp_size = 0;
1779 tree gnu_max_size = size_one_node;
1780 tree gnu_max_size_unit;
1781 Entity_Id gnat_ind_subtype;
1782 Entity_Id gnat_ind_base_subtype;
1783 tree gnu_template_reference;
1784 tree tem;
1786 TYPE_NAME (gnu_template_type)
1787 = create_concat_name (gnat_entity, "XUB");
1789 /* Make a node for the array. If we are not defining the array
1790 suppress expanding incomplete types. */
1791 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1793 if (!definition)
1794 defer_incomplete_level++, this_deferred = true;
1796 /* Build the fat pointer type. Use a "void *" object instead of
1797 a pointer to the array type since we don't have the array type
1798 yet (it will reference the fat pointer via the bounds). */
1799 tem = chainon (chainon (NULL_TREE,
1800 create_field_decl (get_identifier ("P_ARRAY"),
1801 ptr_void_type_node,
1802 gnu_fat_type, 0, 0, 0, 0)),
1803 create_field_decl (get_identifier ("P_BOUNDS"),
1804 gnu_ptr_template,
1805 gnu_fat_type, 0, 0, 0, 0));
1807 /* Make sure we can put this into a register. */
1808 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1810 /* Do not finalize this record type since the types of its fields
1811 are still incomplete at this point. */
1812 finish_record_type (gnu_fat_type, tem, 0, true);
1813 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1815 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1816 is the fat pointer. This will be used to access the individual
1817 fields once we build them. */
1818 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1819 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1820 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1821 gnu_template_reference
1822 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1823 TREE_READONLY (gnu_template_reference) = 1;
1825 /* Now create the GCC type for each index and add the fields for
1826 that index to the template. */
1827 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1828 gnat_ind_base_subtype
1829 = First_Index (Implementation_Base_Type (gnat_entity));
1830 index < ndim && index >= 0;
1831 index += nextdim,
1832 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1833 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1835 char field_name[10];
1836 tree gnu_ind_subtype
1837 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1838 tree gnu_base_subtype
1839 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1840 tree gnu_base_min
1841 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1842 tree gnu_base_max
1843 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1844 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1846 /* Make the FIELD_DECLs for the minimum and maximum of this
1847 type and then make extractions of that field from the
1848 template. */
1849 sprintf (field_name, "LB%d", index);
1850 gnu_min_field = create_field_decl (get_identifier (field_name),
1851 gnu_ind_subtype,
1852 gnu_template_type, 0, 0, 0, 0);
1853 field_name[0] = 'U';
1854 gnu_max_field = create_field_decl (get_identifier (field_name),
1855 gnu_ind_subtype,
1856 gnu_template_type, 0, 0, 0, 0);
1858 Sloc_to_locus (Sloc (gnat_entity),
1859 &DECL_SOURCE_LOCATION (gnu_min_field));
1860 Sloc_to_locus (Sloc (gnat_entity),
1861 &DECL_SOURCE_LOCATION (gnu_max_field));
1862 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1864 /* We can't use build_component_ref here since the template
1865 type isn't complete yet. */
1866 gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
1867 gnu_template_reference, gnu_min_field,
1868 NULL_TREE);
1869 gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
1870 gnu_template_reference, gnu_max_field,
1871 NULL_TREE);
1872 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1874 /* Make a range type with the new ranges, but using
1875 the Ada subtype. Then we convert to sizetype. */
1876 gnu_index_types[index]
1877 = create_index_type (convert (sizetype, gnu_min),
1878 convert (sizetype, gnu_max),
1879 build_range_type (gnu_ind_subtype,
1880 gnu_min, gnu_max),
1881 gnat_entity);
1882 /* Update the maximum size of the array, in elements. */
1883 gnu_max_size
1884 = size_binop (MULT_EXPR, gnu_max_size,
1885 size_binop (PLUS_EXPR, size_one_node,
1886 size_binop (MINUS_EXPR, gnu_base_max,
1887 gnu_base_min)));
1889 TYPE_NAME (gnu_index_types[index])
1890 = create_concat_name (gnat_entity, field_name);
1893 for (index = 0; index < ndim; index++)
1894 gnu_template_fields
1895 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1897 /* Install all the fields into the template. */
1898 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1899 TYPE_READONLY (gnu_template_type) = 1;
1901 /* Now make the array of arrays and update the pointer to the array
1902 in the fat pointer. Note that it is the first field. */
1903 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1905 /* Try to get a smaller form of the component if needed. */
1906 if ((Is_Packed (gnat_entity)
1907 || Has_Component_Size_Clause (gnat_entity))
1908 && !Is_Bit_Packed_Array (gnat_entity)
1909 && !Has_Aliased_Components (gnat_entity)
1910 && !Strict_Alignment (Component_Type (gnat_entity))
1911 && TREE_CODE (tem) == RECORD_TYPE
1912 && host_integerp (TYPE_SIZE (tem), 1))
1913 tem = make_packable_type (tem, false);
1915 if (Has_Atomic_Components (gnat_entity))
1916 check_ok_for_atomic (tem, gnat_entity, true);
1918 /* Get and validate any specified Component_Size, but if Packed,
1919 ignore it since the front end will have taken care of it. */
1920 gnu_comp_size
1921 = validate_size (Component_Size (gnat_entity), tem,
1922 gnat_entity,
1923 (Is_Bit_Packed_Array (gnat_entity)
1924 ? TYPE_DECL : VAR_DECL),
1925 true, Has_Component_Size_Clause (gnat_entity));
1927 /* If the component type is a RECORD_TYPE that has a self-referential
1928 size, use the maxium size. */
1929 if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
1930 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1931 gnu_comp_size = max_size (TYPE_SIZE (tem), true);
1933 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
1935 tree orig_tem;
1936 tem = make_type_from_size (tem, gnu_comp_size, false);
1937 orig_tem = tem;
1938 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1939 "C_PAD", false, definition, true);
1940 /* If a padding record was made, declare it now since it will
1941 never be declared otherwise. This is necessary to ensure
1942 that its subtrees are properly marked. */
1943 if (tem != orig_tem)
1944 create_type_decl (TYPE_NAME (tem), tem, NULL, true, false,
1945 gnat_entity);
1948 if (Has_Volatile_Components (gnat_entity))
1949 tem = build_qualified_type (tem,
1950 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1952 /* If Component_Size is not already specified, annotate it with the
1953 size of the component. */
1954 if (Unknown_Component_Size (gnat_entity))
1955 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1957 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1958 size_binop (MULT_EXPR, gnu_max_size,
1959 TYPE_SIZE_UNIT (tem)));
1960 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1961 size_binop (MULT_EXPR,
1962 convert (bitsizetype,
1963 gnu_max_size),
1964 TYPE_SIZE (tem)));
1966 for (index = ndim - 1; index >= 0; index--)
1968 tem = build_array_type (tem, gnu_index_types[index]);
1969 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1970 if (array_type_has_nonaliased_component (gnat_entity, tem))
1971 TYPE_NONALIASED_COMPONENT (tem) = 1;
1974 /* If an alignment is specified, use it if valid. But ignore it for
1975 types that represent the unpacked base type for packed arrays. If
1976 the alignment was requested with an explicit user alignment clause,
1977 state so. */
1978 if (No (Packed_Array_Type (gnat_entity))
1979 && Known_Alignment (gnat_entity))
1981 gcc_assert (Present (Alignment (gnat_entity)));
1982 TYPE_ALIGN (tem)
1983 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1984 TYPE_ALIGN (tem));
1985 if (Present (Alignment_Clause (gnat_entity)))
1986 TYPE_USER_ALIGN (tem) = 1;
1989 TYPE_CONVENTION_FORTRAN_P (tem)
1990 = (Convention (gnat_entity) == Convention_Fortran);
1991 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1993 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1994 corresponding fat pointer. */
1995 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1996 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1997 TYPE_MODE (gnu_type) = BLKmode;
1998 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1999 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2001 /* If the maximum size doesn't overflow, use it. */
2002 if (TREE_CODE (gnu_max_size) == INTEGER_CST
2003 && !TREE_OVERFLOW (gnu_max_size))
2004 TYPE_SIZE (tem)
2005 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
2006 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2007 && !TREE_OVERFLOW (gnu_max_size_unit))
2008 TYPE_SIZE_UNIT (tem)
2009 = size_binop (MIN_EXPR, gnu_max_size_unit,
2010 TYPE_SIZE_UNIT (tem));
2012 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2013 tem, NULL, !Comes_From_Source (gnat_entity),
2014 debug_info_p, gnat_entity);
2016 /* Give the fat pointer type a name. */
2017 create_type_decl (create_concat_name (gnat_entity, "XUP"),
2018 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2019 debug_info_p, gnat_entity);
2021 /* Create the type to be used as what a thin pointer designates: an
2022 record type for the object and its template with the field offsets
2023 shifted to have the template at a negative offset. */
2024 tem = build_unc_object_type (gnu_template_type, tem,
2025 create_concat_name (gnat_entity, "XUT"));
2026 shift_unc_components_for_thin_pointers (tem);
2028 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2029 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2031 /* Give the thin pointer type a name. */
2032 create_type_decl (create_concat_name (gnat_entity, "XUX"),
2033 build_pointer_type (tem), NULL,
2034 !Comes_From_Source (gnat_entity), debug_info_p,
2035 gnat_entity);
2037 break;
2039 case E_String_Subtype:
2040 case E_Array_Subtype:
2042 /* This is the actual data type for array variables. Multidimensional
2043 arrays are implemented in the gnu tree as arrays of arrays. Note
2044 that for the moment arrays which have sparse enumeration subtypes as
2045 index components create sparse arrays, which is obviously space
2046 inefficient but so much easier to code for now.
2048 Also note that the subtype never refers to the unconstrained
2049 array type, which is somewhat at variance with Ada semantics.
2051 First check to see if this is simply a renaming of the array
2052 type. If so, the result is the array type. */
2054 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2055 if (!Is_Constrained (gnat_entity))
2056 break;
2057 else
2059 int index;
2060 int array_dim = Number_Dimensions (gnat_entity);
2061 int first_dim
2062 = ((Convention (gnat_entity) == Convention_Fortran)
2063 ? array_dim - 1 : 0);
2064 int next_dim
2065 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
2066 Entity_Id gnat_ind_subtype;
2067 Entity_Id gnat_ind_base_subtype;
2068 tree gnu_base_type = gnu_type;
2069 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
2070 tree gnu_comp_size = NULL_TREE;
2071 tree gnu_max_size = size_one_node;
2072 tree gnu_max_size_unit;
2073 bool need_index_type_struct = false;
2074 bool max_overflow = false;
2076 /* First create the gnu types for each index. Create types for
2077 debugging information to point to the index types if the
2078 are not integer types, have variable bounds, or are
2079 wider than sizetype. */
2081 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
2082 gnat_ind_base_subtype
2083 = First_Index (Implementation_Base_Type (gnat_entity));
2084 index < array_dim && index >= 0;
2085 index += next_dim,
2086 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
2087 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
2089 tree gnu_index_subtype
2090 = get_unpadded_type (Etype (gnat_ind_subtype));
2091 tree gnu_min
2092 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
2093 tree gnu_max
2094 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
2095 tree gnu_base_subtype
2096 = get_unpadded_type (Etype (gnat_ind_base_subtype));
2097 tree gnu_base_min
2098 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
2099 tree gnu_base_max
2100 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
2101 tree gnu_base_type = get_base_type (gnu_base_subtype);
2102 tree gnu_base_base_min
2103 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
2104 tree gnu_base_base_max
2105 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
2106 tree gnu_high;
2107 tree gnu_this_max;
2109 /* If the minimum and maximum values both overflow in
2110 SIZETYPE, but the difference in the original type
2111 does not overflow in SIZETYPE, ignore the overflow
2112 indications. */
2113 if ((TYPE_PRECISION (gnu_index_subtype)
2114 > TYPE_PRECISION (sizetype)
2115 || TYPE_UNSIGNED (gnu_index_subtype)
2116 != TYPE_UNSIGNED (sizetype))
2117 && TREE_CODE (gnu_min) == INTEGER_CST
2118 && TREE_CODE (gnu_max) == INTEGER_CST
2119 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2120 && (!TREE_OVERFLOW
2121 (fold_build2 (MINUS_EXPR, gnu_index_subtype,
2122 TYPE_MAX_VALUE (gnu_index_subtype),
2123 TYPE_MIN_VALUE (gnu_index_subtype)))))
2125 TREE_OVERFLOW (gnu_min) = 0;
2126 TREE_OVERFLOW (gnu_max) = 0;
2129 /* Similarly, if the range is null, use bounds of 1..0 for
2130 the sizetype bounds. */
2131 else if ((TYPE_PRECISION (gnu_index_subtype)
2132 > TYPE_PRECISION (sizetype)
2133 || TYPE_UNSIGNED (gnu_index_subtype)
2134 != TYPE_UNSIGNED (sizetype))
2135 && TREE_CODE (gnu_min) == INTEGER_CST
2136 && TREE_CODE (gnu_max) == INTEGER_CST
2137 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2138 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
2139 TYPE_MIN_VALUE (gnu_index_subtype)))
2140 gnu_min = size_one_node, gnu_max = size_zero_node;
2142 /* Now compute the size of this bound. We need to provide
2143 GCC with an upper bound to use but have to deal with the
2144 "superflat" case. There are three ways to do this. If we
2145 can prove that the array can never be superflat, we can
2146 just use the high bound of the index subtype. If we can
2147 prove that the low bound minus one can't overflow, we
2148 can do this as MAX (hb, lb - 1). Otherwise, we have to use
2149 the expression hb >= lb ? hb : lb - 1. */
2150 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2152 /* See if the base array type is already flat. If it is, we
2153 are probably compiling an ACVC test, but it will cause the
2154 code below to malfunction if we don't handle it specially. */
2155 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2156 && TREE_CODE (gnu_base_max) == INTEGER_CST
2157 && !TREE_OVERFLOW (gnu_base_min)
2158 && !TREE_OVERFLOW (gnu_base_max)
2159 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
2160 gnu_high = size_zero_node, gnu_min = size_one_node;
2162 /* If gnu_high is now an integer which overflowed, the array
2163 cannot be superflat. */
2164 else if (TREE_CODE (gnu_high) == INTEGER_CST
2165 && TREE_OVERFLOW (gnu_high))
2166 gnu_high = gnu_max;
2167 else if (TYPE_UNSIGNED (gnu_base_subtype)
2168 || TREE_CODE (gnu_high) == INTEGER_CST)
2169 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2170 else
2171 gnu_high
2172 = build_cond_expr
2173 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
2174 gnu_max, gnu_min),
2175 gnu_max, gnu_high);
2177 gnu_index_type[index]
2178 = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
2179 gnat_entity);
2181 /* Also compute the maximum size of the array. Here we
2182 see if any constraint on the index type of the base type
2183 can be used in the case of self-referential bound on
2184 the index type of the subtype. We look for a non-"infinite"
2185 and non-self-referential bound from any type involved and
2186 handle each bound separately. */
2188 if ((TREE_CODE (gnu_min) == INTEGER_CST
2189 && !TREE_OVERFLOW (gnu_min)
2190 && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
2191 || !CONTAINS_PLACEHOLDER_P (gnu_min)
2192 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2193 && !TREE_OVERFLOW (gnu_base_min)))
2194 gnu_base_min = gnu_min;
2196 if ((TREE_CODE (gnu_max) == INTEGER_CST
2197 && !TREE_OVERFLOW (gnu_max)
2198 && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
2199 || !CONTAINS_PLACEHOLDER_P (gnu_max)
2200 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2201 && !TREE_OVERFLOW (gnu_base_max)))
2202 gnu_base_max = gnu_max;
2204 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2205 && TREE_OVERFLOW (gnu_base_min))
2206 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2207 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2208 && TREE_OVERFLOW (gnu_base_max))
2209 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2210 max_overflow = true;
2212 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
2213 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
2215 gnu_this_max
2216 = size_binop (MAX_EXPR,
2217 size_binop (PLUS_EXPR, size_one_node,
2218 size_binop (MINUS_EXPR, gnu_base_max,
2219 gnu_base_min)),
2220 size_zero_node);
2222 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2223 && TREE_OVERFLOW (gnu_this_max))
2224 max_overflow = true;
2226 gnu_max_size
2227 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2229 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
2230 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
2231 != INTEGER_CST)
2232 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
2233 || (TREE_TYPE (gnu_index_subtype)
2234 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
2235 != INTEGER_TYPE))
2236 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
2237 || (TYPE_PRECISION (gnu_index_subtype)
2238 > TYPE_PRECISION (sizetype)))
2239 need_index_type_struct = true;
2242 /* Then flatten: create the array of arrays. For an array type
2243 used to implement a packed array, get the component type from
2244 the original array type since the representation clauses that
2245 can affect it are on the latter. */
2246 if (Is_Packed_Array_Type (gnat_entity)
2247 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2249 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2250 for (index = array_dim - 1; index >= 0; index--)
2251 gnu_type = TREE_TYPE (gnu_type);
2253 /* One of the above calls might have caused us to be elaborated,
2254 so don't blow up if so. */
2255 if (present_gnu_tree (gnat_entity))
2257 maybe_present = true;
2258 break;
2261 else
2263 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
2265 /* One of the above calls might have caused us to be elaborated,
2266 so don't blow up if so. */
2267 if (present_gnu_tree (gnat_entity))
2269 maybe_present = true;
2270 break;
2273 /* Try to get a smaller form of the component if needed. */
2274 if ((Is_Packed (gnat_entity)
2275 || Has_Component_Size_Clause (gnat_entity))
2276 && !Is_Bit_Packed_Array (gnat_entity)
2277 && !Has_Aliased_Components (gnat_entity)
2278 && !Strict_Alignment (Component_Type (gnat_entity))
2279 && TREE_CODE (gnu_type) == RECORD_TYPE
2280 && host_integerp (TYPE_SIZE (gnu_type), 1))
2281 gnu_type = make_packable_type (gnu_type, false);
2283 /* Get and validate any specified Component_Size, but if Packed,
2284 ignore it since the front end will have taken care of it. */
2285 gnu_comp_size
2286 = validate_size (Component_Size (gnat_entity), gnu_type,
2287 gnat_entity,
2288 (Is_Bit_Packed_Array (gnat_entity)
2289 ? TYPE_DECL : VAR_DECL), true,
2290 Has_Component_Size_Clause (gnat_entity));
2292 /* If the component type is a RECORD_TYPE that has a
2293 self-referential size, use the maxium size. */
2294 if (!gnu_comp_size
2295 && TREE_CODE (gnu_type) == RECORD_TYPE
2296 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2297 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
2299 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
2301 tree orig_gnu_type;
2302 gnu_type
2303 = make_type_from_size (gnu_type, gnu_comp_size, false);
2304 orig_gnu_type = gnu_type;
2305 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
2306 gnat_entity, "C_PAD", false,
2307 definition, true);
2308 /* If a padding record was made, declare it now since it
2309 will never be declared otherwise. This is necessary
2310 to ensure that its subtrees are properly marked. */
2311 if (gnu_type != orig_gnu_type)
2312 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL,
2313 true, false, gnat_entity);
2316 if (Has_Volatile_Components (Base_Type (gnat_entity)))
2317 gnu_type = build_qualified_type (gnu_type,
2318 (TYPE_QUALS (gnu_type)
2319 | TYPE_QUAL_VOLATILE));
2322 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2323 TYPE_SIZE_UNIT (gnu_type));
2324 gnu_max_size = size_binop (MULT_EXPR,
2325 convert (bitsizetype, gnu_max_size),
2326 TYPE_SIZE (gnu_type));
2328 for (index = array_dim - 1; index >= 0; index --)
2330 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
2331 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2332 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2333 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2336 /* If we are at file level and this is a multi-dimensional array, we
2337 need to make a variable corresponding to the stride of the
2338 inner dimensions. */
2339 if (global_bindings_p () && array_dim > 1)
2341 tree gnu_str_name = get_identifier ("ST");
2342 tree gnu_arr_type;
2344 for (gnu_arr_type = TREE_TYPE (gnu_type);
2345 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2346 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2347 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
2349 tree eltype = TREE_TYPE (gnu_arr_type);
2351 TYPE_SIZE (gnu_arr_type)
2352 = elaborate_expression_1 (gnat_entity, gnat_entity,
2353 TYPE_SIZE (gnu_arr_type),
2354 gnu_str_name, definition, 0);
2356 /* ??? For now, store the size as a multiple of the
2357 alignment of the element type in bytes so that we
2358 can see the alignment from the tree. */
2359 TYPE_SIZE_UNIT (gnu_arr_type)
2360 = build_binary_op
2361 (MULT_EXPR, sizetype,
2362 elaborate_expression_1
2363 (gnat_entity, gnat_entity,
2364 build_binary_op (EXACT_DIV_EXPR, sizetype,
2365 TYPE_SIZE_UNIT (gnu_arr_type),
2366 size_int (TYPE_ALIGN (eltype)
2367 / BITS_PER_UNIT)),
2368 concat_id_with_name (gnu_str_name, "A_U"),
2369 definition, 0),
2370 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2372 /* ??? create_type_decl is not invoked on the inner types so
2373 the MULT_EXPR node built above will never be marked. */
2374 mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type));
2378 /* If we need to write out a record type giving the names of
2379 the bounds, do it now. */
2380 if (need_index_type_struct && debug_info_p)
2382 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
2383 tree gnu_field_list = NULL_TREE;
2384 tree gnu_field;
2386 TYPE_NAME (gnu_bound_rec_type)
2387 = create_concat_name (gnat_entity, "XA");
2389 for (index = array_dim - 1; index >= 0; index--)
2391 tree gnu_type_name
2392 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2394 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2395 gnu_type_name = DECL_NAME (gnu_type_name);
2397 gnu_field = create_field_decl (gnu_type_name,
2398 integer_type_node,
2399 gnu_bound_rec_type,
2400 0, NULL_TREE, NULL_TREE, 0);
2401 TREE_CHAIN (gnu_field) = gnu_field_list;
2402 gnu_field_list = gnu_field;
2405 finish_record_type (gnu_bound_rec_type, gnu_field_list,
2406 0, false);
2408 TYPE_STUB_DECL (gnu_type)
2409 = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
2411 add_parallel_type
2412 (TYPE_STUB_DECL (gnu_type), gnu_bound_rec_type);
2415 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2416 = (Convention (gnat_entity) == Convention_Fortran);
2417 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2418 = (Is_Packed_Array_Type (gnat_entity)
2419 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2421 /* If our size depends on a placeholder and the maximum size doesn't
2422 overflow, use it. */
2423 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2424 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2425 && TREE_OVERFLOW (gnu_max_size))
2426 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2427 && TREE_OVERFLOW (gnu_max_size_unit))
2428 && !max_overflow)
2430 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2431 TYPE_SIZE (gnu_type));
2432 TYPE_SIZE_UNIT (gnu_type)
2433 = size_binop (MIN_EXPR, gnu_max_size_unit,
2434 TYPE_SIZE_UNIT (gnu_type));
2437 /* Set our alias set to that of our base type. This gives all
2438 array subtypes the same alias set. */
2439 copy_alias_set (gnu_type, gnu_base_type);
2442 /* If this is a packed type, make this type the same as the packed
2443 array type, but do some adjusting in the type first. */
2445 if (Present (Packed_Array_Type (gnat_entity)))
2447 Entity_Id gnat_index;
2448 tree gnu_inner_type;
2450 /* First finish the type we had been making so that we output
2451 debugging information for it */
2452 gnu_type
2453 = build_qualified_type (gnu_type,
2454 (TYPE_QUALS (gnu_type)
2455 | (TYPE_QUAL_VOLATILE
2456 * Treat_As_Volatile (gnat_entity))));
2457 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2458 !Comes_From_Source (gnat_entity),
2459 debug_info_p, gnat_entity);
2460 if (!Comes_From_Source (gnat_entity))
2461 DECL_ARTIFICIAL (gnu_decl) = 1;
2463 /* Save it as our equivalent in case the call below elaborates
2464 this type again. */
2465 save_gnu_tree (gnat_entity, gnu_decl, false);
2467 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2468 NULL_TREE, 0);
2469 this_made_decl = true;
2470 gnu_type = TREE_TYPE (gnu_decl);
2471 save_gnu_tree (gnat_entity, NULL_TREE, false);
2473 gnu_inner_type = gnu_type;
2474 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2475 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
2476 || TYPE_IS_PADDING_P (gnu_inner_type)))
2477 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2479 /* We need to point the type we just made to our index type so
2480 the actual bounds can be put into a template. */
2482 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2483 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
2484 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2485 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2487 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2489 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2490 If it is, we need to make another type. */
2491 if (TYPE_MODULAR_P (gnu_inner_type))
2493 tree gnu_subtype;
2495 gnu_subtype = make_node (INTEGER_TYPE);
2497 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2498 TYPE_MIN_VALUE (gnu_subtype)
2499 = TYPE_MIN_VALUE (gnu_inner_type);
2500 TYPE_MAX_VALUE (gnu_subtype)
2501 = TYPE_MAX_VALUE (gnu_inner_type);
2502 TYPE_PRECISION (gnu_subtype)
2503 = TYPE_PRECISION (gnu_inner_type);
2504 TYPE_UNSIGNED (gnu_subtype)
2505 = TYPE_UNSIGNED (gnu_inner_type);
2506 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2507 layout_type (gnu_subtype);
2509 gnu_inner_type = gnu_subtype;
2512 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2515 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2517 for (gnat_index = First_Index (gnat_entity);
2518 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2519 SET_TYPE_ACTUAL_BOUNDS
2520 (gnu_inner_type,
2521 tree_cons (NULL_TREE,
2522 get_unpadded_type (Etype (gnat_index)),
2523 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2525 if (Convention (gnat_entity) != Convention_Fortran)
2526 SET_TYPE_ACTUAL_BOUNDS
2527 (gnu_inner_type,
2528 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2530 if (TREE_CODE (gnu_type) == RECORD_TYPE
2531 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2532 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2536 /* Abort if packed array with no packed array type field set. */
2537 else
2538 gcc_assert (!Is_Packed (gnat_entity));
2540 break;
2542 case E_String_Literal_Subtype:
2543 /* Create the type for a string literal. */
2545 Entity_Id gnat_full_type
2546 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2547 && Present (Full_View (Etype (gnat_entity)))
2548 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2549 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2550 tree gnu_string_array_type
2551 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2552 tree gnu_string_index_type
2553 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2554 (TYPE_DOMAIN (gnu_string_array_type))));
2555 tree gnu_lower_bound
2556 = convert (gnu_string_index_type,
2557 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2558 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2559 tree gnu_length = ssize_int (length - 1);
2560 tree gnu_upper_bound
2561 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2562 gnu_lower_bound,
2563 convert (gnu_string_index_type, gnu_length));
2564 tree gnu_range_type
2565 = build_range_type (gnu_string_index_type,
2566 gnu_lower_bound, gnu_upper_bound);
2567 tree gnu_index_type
2568 = create_index_type (convert (sizetype,
2569 TYPE_MIN_VALUE (gnu_range_type)),
2570 convert (sizetype,
2571 TYPE_MAX_VALUE (gnu_range_type)),
2572 gnu_range_type, gnat_entity);
2574 gnu_type
2575 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2576 gnu_index_type);
2577 copy_alias_set (gnu_type, gnu_string_type);
2579 break;
2581 /* Record Types and Subtypes
2583 The following fields are defined on record types:
2585 Has_Discriminants True if the record has discriminants
2586 First_Discriminant Points to head of list of discriminants
2587 First_Entity Points to head of list of fields
2588 Is_Tagged_Type True if the record is tagged
2590 Implementation of Ada records and discriminated records:
2592 A record type definition is transformed into the equivalent of a C
2593 struct definition. The fields that are the discriminants which are
2594 found in the Full_Type_Declaration node and the elements of the
2595 Component_List found in the Record_Type_Definition node. The
2596 Component_List can be a recursive structure since each Variant of
2597 the Variant_Part of the Component_List has a Component_List.
2599 Processing of a record type definition comprises starting the list of
2600 field declarations here from the discriminants and the calling the
2601 function components_to_record to add the rest of the fields from the
2602 component list and return the gnu type node. The function
2603 components_to_record will call itself recursively as it traverses
2604 the tree. */
2606 case E_Record_Type:
2607 if (Has_Complex_Representation (gnat_entity))
2609 gnu_type
2610 = build_complex_type
2611 (get_unpadded_type
2612 (Etype (Defining_Entity
2613 (First (Component_Items
2614 (Component_List
2615 (Type_Definition
2616 (Declaration_Node (gnat_entity)))))))));
2618 break;
2622 Node_Id full_definition = Declaration_Node (gnat_entity);
2623 Node_Id record_definition = Type_Definition (full_definition);
2624 Entity_Id gnat_field;
2625 tree gnu_field;
2626 tree gnu_field_list = NULL_TREE;
2627 tree gnu_get_parent;
2628 /* Set PACKED in keeping with gnat_to_gnu_field. */
2629 int packed
2630 = Is_Packed (gnat_entity)
2632 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2633 ? -1
2634 : (Known_Alignment (gnat_entity)
2635 || (Strict_Alignment (gnat_entity)
2636 && Known_Static_Esize (gnat_entity)))
2637 ? -2
2638 : 0;
2639 bool has_rep = Has_Specified_Layout (gnat_entity);
2640 bool all_rep = has_rep;
2641 bool is_extension
2642 = (Is_Tagged_Type (gnat_entity)
2643 && Nkind (record_definition) == N_Derived_Type_Definition);
2645 /* See if all fields have a rep clause. Stop when we find one
2646 that doesn't. */
2647 for (gnat_field = First_Entity (gnat_entity);
2648 Present (gnat_field) && all_rep;
2649 gnat_field = Next_Entity (gnat_field))
2650 if ((Ekind (gnat_field) == E_Component
2651 || Ekind (gnat_field) == E_Discriminant)
2652 && No (Component_Clause (gnat_field)))
2653 all_rep = false;
2655 /* If this is a record extension, go a level further to find the
2656 record definition. Also, verify we have a Parent_Subtype. */
2657 if (is_extension)
2659 if (!type_annotate_only
2660 || Present (Record_Extension_Part (record_definition)))
2661 record_definition = Record_Extension_Part (record_definition);
2663 gcc_assert (type_annotate_only
2664 || Present (Parent_Subtype (gnat_entity)));
2667 /* Make a node for the record. If we are not defining the record,
2668 suppress expanding incomplete types. */
2669 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2670 TYPE_NAME (gnu_type) = gnu_entity_id;
2671 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2673 if (!definition)
2674 defer_incomplete_level++, this_deferred = true;
2676 /* If both a size and rep clause was specified, put the size in
2677 the record type now so that it can get the proper mode. */
2678 if (has_rep && Known_Esize (gnat_entity))
2679 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2681 /* Always set the alignment here so that it can be used to
2682 set the mode, if it is making the alignment stricter. If
2683 it is invalid, it will be checked again below. If this is to
2684 be Atomic, choose a default alignment of a word unless we know
2685 the size and it's smaller. */
2686 if (Known_Alignment (gnat_entity))
2687 TYPE_ALIGN (gnu_type)
2688 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2689 else if (Is_Atomic (gnat_entity))
2690 TYPE_ALIGN (gnu_type)
2691 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2692 /* If a type needs strict alignment, the minimum size will be the
2693 type size instead of the RM size (see validate_size). Cap the
2694 alignment, lest it causes this type size to become too large. */
2695 else if (Strict_Alignment (gnat_entity)
2696 && Known_Static_Esize (gnat_entity))
2698 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2699 unsigned int raw_align = raw_size & -raw_size;
2700 if (raw_align < BIGGEST_ALIGNMENT)
2701 TYPE_ALIGN (gnu_type) = raw_align;
2703 else
2704 TYPE_ALIGN (gnu_type) = 0;
2706 /* If we have a Parent_Subtype, make a field for the parent. If
2707 this record has rep clauses, force the position to zero. */
2708 if (Present (Parent_Subtype (gnat_entity)))
2710 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2711 tree gnu_parent;
2713 /* A major complexity here is that the parent subtype will
2714 reference our discriminants in its Discriminant_Constraint
2715 list. But those must reference the parent component of this
2716 record which is of the parent subtype we have not built yet!
2717 To break the circle we first build a dummy COMPONENT_REF which
2718 represents the "get to the parent" operation and initialize
2719 each of those discriminants to a COMPONENT_REF of the above
2720 dummy parent referencing the corresponding discriminant of the
2721 base type of the parent subtype. */
2722 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2723 build0 (PLACEHOLDER_EXPR, gnu_type),
2724 build_decl (FIELD_DECL, NULL_TREE,
2725 void_type_node),
2726 NULL_TREE);
2728 if (Has_Discriminants (gnat_entity))
2729 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2730 Present (gnat_field);
2731 gnat_field = Next_Stored_Discriminant (gnat_field))
2732 if (Present (Corresponding_Discriminant (gnat_field)))
2733 save_gnu_tree
2734 (gnat_field,
2735 build3 (COMPONENT_REF,
2736 get_unpadded_type (Etype (gnat_field)),
2737 gnu_get_parent,
2738 gnat_to_gnu_field_decl (Corresponding_Discriminant
2739 (gnat_field)),
2740 NULL_TREE),
2741 true);
2743 /* Then we build the parent subtype. */
2744 gnu_parent = gnat_to_gnu_type (gnat_parent);
2746 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2747 initially built. The discriminants must reference the fields
2748 of the parent subtype and not those of its base type for the
2749 placeholder machinery to properly work. */
2750 if (Has_Discriminants (gnat_entity))
2751 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2752 Present (gnat_field);
2753 gnat_field = Next_Stored_Discriminant (gnat_field))
2754 if (Present (Corresponding_Discriminant (gnat_field)))
2756 Entity_Id field = Empty;
2757 for (field = First_Stored_Discriminant (gnat_parent);
2758 Present (field);
2759 field = Next_Stored_Discriminant (field))
2760 if (same_discriminant_p (gnat_field, field))
2761 break;
2762 gcc_assert (Present (field));
2763 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2764 = gnat_to_gnu_field_decl (field);
2767 /* The "get to the parent" COMPONENT_REF must be given its
2768 proper type... */
2769 TREE_TYPE (gnu_get_parent) = gnu_parent;
2771 /* ...and reference the _parent field of this record. */
2772 gnu_field_list
2773 = create_field_decl (get_identifier
2774 (Get_Name_String (Name_uParent)),
2775 gnu_parent, gnu_type, 0,
2776 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2777 has_rep ? bitsize_zero_node : 0, 1);
2778 DECL_INTERNAL_P (gnu_field_list) = 1;
2779 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2782 /* Make the fields for the discriminants and put them into the record
2783 unless it's an Unchecked_Union. */
2784 if (Has_Discriminants (gnat_entity))
2785 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2786 Present (gnat_field);
2787 gnat_field = Next_Stored_Discriminant (gnat_field))
2789 /* If this is a record extension and this discriminant
2790 is the renaming of another discriminant, we've already
2791 handled the discriminant above. */
2792 if (Present (Parent_Subtype (gnat_entity))
2793 && Present (Corresponding_Discriminant (gnat_field)))
2794 continue;
2796 gnu_field
2797 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2799 /* Make an expression using a PLACEHOLDER_EXPR from the
2800 FIELD_DECL node just created and link that with the
2801 corresponding GNAT defining identifier. Then add to the
2802 list of fields. */
2803 save_gnu_tree (gnat_field,
2804 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2805 build0 (PLACEHOLDER_EXPR,
2806 DECL_CONTEXT (gnu_field)),
2807 gnu_field, NULL_TREE),
2808 true);
2810 if (!Is_Unchecked_Union (gnat_entity))
2812 TREE_CHAIN (gnu_field) = gnu_field_list;
2813 gnu_field_list = gnu_field;
2817 /* Put the discriminants into the record (backwards), so we can
2818 know the appropriate discriminant to use for the names of the
2819 variants. */
2820 TYPE_FIELDS (gnu_type) = gnu_field_list;
2822 /* Add the listed fields into the record and finish it up. */
2823 components_to_record (gnu_type, Component_List (record_definition),
2824 gnu_field_list, packed, definition, NULL,
2825 false, all_rep, false,
2826 Is_Unchecked_Union (gnat_entity));
2828 /* We used to remove the associations of the discriminants and
2829 _Parent for validity checking, but we may need them if there's
2830 Freeze_Node for a subtype used in this record. */
2831 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2832 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2834 /* If it is a tagged record force the type to BLKmode to insure
2835 that these objects will always be placed in memory. Do the
2836 same thing for limited record types. */
2837 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2838 TYPE_MODE (gnu_type) = BLKmode;
2840 /* If this is a derived type, we must make the alias set of this type
2841 the same as that of the type we are derived from. We assume here
2842 that the other type is already frozen. */
2843 if (Etype (gnat_entity) != gnat_entity
2844 && !(Is_Private_Type (Etype (gnat_entity))
2845 && Full_View (Etype (gnat_entity)) == gnat_entity))
2846 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2848 /* Fill in locations of fields. */
2849 annotate_rep (gnat_entity, gnu_type);
2851 /* If there are any entities in the chain corresponding to
2852 components that we did not elaborate, ensure we elaborate their
2853 types if they are Itypes. */
2854 for (gnat_temp = First_Entity (gnat_entity);
2855 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2856 if ((Ekind (gnat_temp) == E_Component
2857 || Ekind (gnat_temp) == E_Discriminant)
2858 && Is_Itype (Etype (gnat_temp))
2859 && !present_gnu_tree (gnat_temp))
2860 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2862 break;
2864 case E_Class_Wide_Subtype:
2865 /* If an equivalent type is present, that is what we should use.
2866 Otherwise, fall through to handle this like a record subtype
2867 since it may have constraints. */
2868 if (gnat_equiv_type != gnat_entity)
2870 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2871 maybe_present = true;
2872 break;
2875 /* ... fall through ... */
2877 case E_Record_Subtype:
2879 /* If Cloned_Subtype is Present it means this record subtype has
2880 identical layout to that type or subtype and we should use
2881 that GCC type for this one. The front end guarantees that
2882 the component list is shared. */
2883 if (Present (Cloned_Subtype (gnat_entity)))
2885 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2886 NULL_TREE, 0);
2887 maybe_present = true;
2890 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2891 changing the type, make a new type with each field having the
2892 type of the field in the new subtype but having the position
2893 computed by transforming every discriminant reference according
2894 to the constraints. We don't see any difference between
2895 private and nonprivate type here since derivations from types should
2896 have been deferred until the completion of the private type. */
2897 else
2899 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2900 tree gnu_base_type;
2901 tree gnu_orig_type;
2903 if (!definition)
2904 defer_incomplete_level++, this_deferred = true;
2906 /* Get the base type initially for its alignment and sizes. But
2907 if it is a padded type, we do all the other work with the
2908 unpadded type. */
2909 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2911 if (TREE_CODE (gnu_base_type) == RECORD_TYPE
2912 && TYPE_IS_PADDING_P (gnu_base_type))
2913 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2914 else
2915 gnu_type = gnu_orig_type = gnu_base_type;
2917 if (present_gnu_tree (gnat_entity))
2919 maybe_present = true;
2920 break;
2923 /* When the type has discriminants, and these discriminants
2924 affect the shape of what it built, factor them in.
2926 If we are making a subtype of an Unchecked_Union (must be an
2927 Itype), just return the type.
2929 We can't just use Is_Constrained because private subtypes without
2930 discriminants of full types with discriminants with default
2931 expressions are Is_Constrained but aren't constrained! */
2933 if (IN (Ekind (gnat_base_type), Record_Kind)
2934 && !Is_For_Access_Subtype (gnat_entity)
2935 && !Is_Unchecked_Union (gnat_base_type)
2936 && Is_Constrained (gnat_entity)
2937 && Stored_Constraint (gnat_entity) != No_Elist
2938 && Present (Discriminant_Constraint (gnat_entity)))
2940 Entity_Id gnat_field;
2941 tree gnu_field_list = 0;
2942 tree gnu_pos_list
2943 = compute_field_positions (gnu_orig_type, NULL_TREE,
2944 size_zero_node, bitsize_zero_node,
2945 BIGGEST_ALIGNMENT);
2946 tree gnu_subst_list
2947 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2948 definition);
2949 tree gnu_temp;
2951 gnu_type = make_node (RECORD_TYPE);
2952 TYPE_NAME (gnu_type) = gnu_entity_id;
2953 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2955 /* Set the size, alignment and alias set of the new type to
2956 match that of the old one, doing required substitutions.
2957 We do it this early because we need the size of the new
2958 type below to discard old fields if necessary. */
2959 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2960 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2961 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2962 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2963 copy_alias_set (gnu_type, gnu_base_type);
2965 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2966 for (gnu_temp = gnu_subst_list;
2967 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2968 TYPE_SIZE (gnu_type)
2969 = substitute_in_expr (TYPE_SIZE (gnu_type),
2970 TREE_PURPOSE (gnu_temp),
2971 TREE_VALUE (gnu_temp));
2973 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2974 for (gnu_temp = gnu_subst_list;
2975 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2976 TYPE_SIZE_UNIT (gnu_type)
2977 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2978 TREE_PURPOSE (gnu_temp),
2979 TREE_VALUE (gnu_temp));
2981 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2982 for (gnu_temp = gnu_subst_list;
2983 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2984 SET_TYPE_ADA_SIZE
2985 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2986 TREE_PURPOSE (gnu_temp),
2987 TREE_VALUE (gnu_temp)));
2989 for (gnat_field = First_Entity (gnat_entity);
2990 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2991 if ((Ekind (gnat_field) == E_Component
2992 || Ekind (gnat_field) == E_Discriminant)
2993 && (Underlying_Type (Scope (Original_Record_Component
2994 (gnat_field)))
2995 == gnat_base_type)
2996 && (No (Corresponding_Discriminant (gnat_field))
2997 || !Is_Tagged_Type (gnat_base_type)))
2999 tree gnu_old_field
3000 = gnat_to_gnu_field_decl (Original_Record_Component
3001 (gnat_field));
3002 tree gnu_offset
3003 = TREE_VALUE (purpose_member (gnu_old_field,
3004 gnu_pos_list));
3005 tree gnu_pos = TREE_PURPOSE (gnu_offset);
3006 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
3007 tree gnu_field_type
3008 = gnat_to_gnu_type (Etype (gnat_field));
3009 tree gnu_size = TYPE_SIZE (gnu_field_type);
3010 tree gnu_new_pos = NULL_TREE;
3011 unsigned int offset_align
3012 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
3014 tree gnu_field;
3016 /* If there was a component clause, the field types must be
3017 the same for the type and subtype, so copy the data from
3018 the old field to avoid recomputation here. Also if the
3019 field is justified modular and the optimization in
3020 gnat_to_gnu_field was applied. */
3021 if (Present (Component_Clause
3022 (Original_Record_Component (gnat_field)))
3023 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3024 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3025 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3026 == TREE_TYPE (gnu_old_field)))
3028 gnu_size = DECL_SIZE (gnu_old_field);
3029 gnu_field_type = TREE_TYPE (gnu_old_field);
3032 /* If the old field was packed and of constant size, we
3033 have to get the old size here, as it might differ from
3034 what the Etype conveys and the latter might overlap
3035 onto the following field. Try to arrange the type for
3036 possible better packing along the way. */
3037 else if (DECL_PACKED (gnu_old_field)
3038 && TREE_CODE (DECL_SIZE (gnu_old_field))
3039 == INTEGER_CST)
3041 gnu_size = DECL_SIZE (gnu_old_field);
3042 if (TYPE_MODE (gnu_field_type) == BLKmode
3043 && TREE_CODE (gnu_field_type) == RECORD_TYPE
3044 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3045 gnu_field_type
3046 = make_packable_type (gnu_field_type, true);
3049 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
3050 for (gnu_temp = gnu_subst_list;
3051 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3052 gnu_pos = substitute_in_expr (gnu_pos,
3053 TREE_PURPOSE (gnu_temp),
3054 TREE_VALUE (gnu_temp));
3056 /* If the position is now a constant, we can set it as the
3057 position of the field when we make it. Otherwise, we need
3058 to deal with it specially below. */
3059 if (TREE_CONSTANT (gnu_pos))
3061 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
3063 /* Discard old fields that are outside the new type.
3064 This avoids confusing code scanning it to decide
3065 how to pass it to functions on some platforms. */
3066 if (TREE_CODE (gnu_new_pos) == INTEGER_CST
3067 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
3068 && !integer_zerop (gnu_size)
3069 && !tree_int_cst_lt (gnu_new_pos,
3070 TYPE_SIZE (gnu_type)))
3071 continue;
3074 gnu_field
3075 = create_field_decl
3076 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
3077 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
3078 !DECL_NONADDRESSABLE_P (gnu_old_field));
3080 if (!TREE_CONSTANT (gnu_pos))
3082 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
3083 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
3084 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
3085 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
3086 DECL_SIZE (gnu_field) = gnu_size;
3087 DECL_SIZE_UNIT (gnu_field)
3088 = convert (sizetype,
3089 size_binop (CEIL_DIV_EXPR, gnu_size,
3090 bitsize_unit_node));
3091 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
3094 DECL_INTERNAL_P (gnu_field)
3095 = DECL_INTERNAL_P (gnu_old_field);
3096 SET_DECL_ORIGINAL_FIELD
3097 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
3098 ? DECL_ORIGINAL_FIELD (gnu_old_field)
3099 : gnu_old_field));
3100 DECL_DISCRIMINANT_NUMBER (gnu_field)
3101 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
3102 TREE_THIS_VOLATILE (gnu_field)
3103 = TREE_THIS_VOLATILE (gnu_old_field);
3104 TREE_CHAIN (gnu_field) = gnu_field_list;
3105 gnu_field_list = gnu_field;
3106 save_gnu_tree (gnat_field, gnu_field, false);
3109 /* Now go through the entities again looking for Itypes that
3110 we have not elaborated but should (e.g., Etypes of fields
3111 that have Original_Components). */
3112 for (gnat_field = First_Entity (gnat_entity);
3113 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3114 if ((Ekind (gnat_field) == E_Discriminant
3115 || Ekind (gnat_field) == E_Component)
3116 && !present_gnu_tree (Etype (gnat_field)))
3117 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3119 /* Do not finalize it since we're going to modify it below. */
3120 gnu_field_list = nreverse (gnu_field_list);
3121 finish_record_type (gnu_type, gnu_field_list, 2, true);
3123 /* Finalize size and mode. */
3124 TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
3125 TYPE_SIZE_UNIT (gnu_type)
3126 = variable_size (TYPE_SIZE_UNIT (gnu_type));
3128 compute_record_mode (gnu_type);
3130 /* Fill in locations of fields. */
3131 annotate_rep (gnat_entity, gnu_type);
3133 /* We've built a new type, make an XVS type to show what this
3134 is a subtype of. Some debuggers require the XVS type to be
3135 output first, so do it in that order. */
3136 if (debug_info_p)
3138 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3139 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
3141 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
3142 gnu_orig_name = DECL_NAME (gnu_orig_name);
3144 TYPE_NAME (gnu_subtype_marker)
3145 = create_concat_name (gnat_entity, "XVS");
3146 finish_record_type (gnu_subtype_marker,
3147 create_field_decl (gnu_orig_name,
3148 integer_type_node,
3149 gnu_subtype_marker,
3150 0, NULL_TREE,
3151 NULL_TREE, 0),
3152 0, false);
3154 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3155 gnu_subtype_marker);
3158 /* Now we can finalize it. */
3159 rest_of_record_type_compilation (gnu_type);
3162 /* Otherwise, go down all the components in the new type and
3163 make them equivalent to those in the base type. */
3164 else
3165 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3166 gnat_temp = Next_Entity (gnat_temp))
3167 if ((Ekind (gnat_temp) == E_Discriminant
3168 && !Is_Unchecked_Union (gnat_base_type))
3169 || Ekind (gnat_temp) == E_Component)
3170 save_gnu_tree (gnat_temp,
3171 gnat_to_gnu_field_decl
3172 (Original_Record_Component (gnat_temp)), false);
3174 break;
3176 case E_Access_Subprogram_Type:
3177 /* Use the special descriptor type for dispatch tables if needed,
3178 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3179 Note that we are only required to do so for static tables in
3180 order to be compatible with the C++ ABI, but Ada 2005 allows
3181 to extend library level tagged types at the local level so
3182 we do it in the non-static case as well. */
3183 if (TARGET_VTABLE_USES_DESCRIPTORS
3184 && Is_Dispatch_Table_Entity (gnat_entity))
3186 gnu_type = fdesc_type_node;
3187 gnu_size = TYPE_SIZE (gnu_type);
3188 break;
3191 /* ... fall through ... */
3193 case E_Anonymous_Access_Subprogram_Type:
3194 /* If we are not defining this entity, and we have incomplete
3195 entities being processed above us, make a dummy type and
3196 fill it in later. */
3197 if (!definition && defer_incomplete_level != 0)
3199 struct incomplete *p
3200 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3202 gnu_type
3203 = build_pointer_type
3204 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3205 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3206 !Comes_From_Source (gnat_entity),
3207 debug_info_p, gnat_entity);
3208 this_made_decl = true;
3209 gnu_type = TREE_TYPE (gnu_decl);
3210 save_gnu_tree (gnat_entity, gnu_decl, false);
3211 saved = true;
3213 p->old_type = TREE_TYPE (gnu_type);
3214 p->full_type = Directly_Designated_Type (gnat_entity);
3215 p->next = defer_incomplete_list;
3216 defer_incomplete_list = p;
3217 break;
3220 /* ... fall through ... */
3222 case E_Allocator_Type:
3223 case E_Access_Type:
3224 case E_Access_Attribute_Type:
3225 case E_Anonymous_Access_Type:
3226 case E_General_Access_Type:
3228 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3229 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3230 bool is_from_limited_with
3231 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3232 && From_With_Type (gnat_desig_equiv));
3234 /* Get the "full view" of this entity. If this is an incomplete
3235 entity from a limited with, treat its non-limited view as the full
3236 view. Otherwise, if this is an incomplete or private type, use the
3237 full view. In the former case, we might point to a private type,
3238 in which case, we need its full view. Also, we want to look at the
3239 actual type used for the representation, so this takes a total of
3240 three steps. */
3241 Entity_Id gnat_desig_full_direct_first
3242 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3243 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3244 ? Full_View (gnat_desig_equiv) : Empty));
3245 Entity_Id gnat_desig_full_direct
3246 = ((is_from_limited_with
3247 && Present (gnat_desig_full_direct_first)
3248 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3249 ? Full_View (gnat_desig_full_direct_first)
3250 : gnat_desig_full_direct_first);
3251 Entity_Id gnat_desig_full
3252 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3254 /* This the type actually used to represent the designated type,
3255 either gnat_desig_full or gnat_desig_equiv. */
3256 Entity_Id gnat_desig_rep;
3258 /* Nonzero if this is a pointer to an unconstrained array. */
3259 bool is_unconstrained_array;
3261 /* We want to know if we'll be seeing the freeze node for any
3262 incomplete type we may be pointing to. */
3263 bool in_main_unit
3264 = (Present (gnat_desig_full)
3265 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3266 : In_Extended_Main_Code_Unit (gnat_desig_type));
3268 /* Nonzero if we make a dummy type here. */
3269 bool got_fat_p = false;
3270 /* Nonzero if the dummy is a fat pointer. */
3271 bool made_dummy = false;
3272 tree gnu_desig_type = NULL_TREE;
3273 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3275 if (!targetm.valid_pointer_mode (p_mode))
3276 p_mode = ptr_mode;
3278 /* If either the designated type or its full view is an unconstrained
3279 array subtype, replace it with the type it's a subtype of. This
3280 avoids problems with multiple copies of unconstrained array types.
3281 Likewise, if the designated type is a subtype of an incomplete
3282 record type, use the parent type to avoid order of elaboration
3283 issues. This can lose some code efficiency, but there is no
3284 alternative. */
3285 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3286 && ! Is_Constrained (gnat_desig_equiv))
3287 gnat_desig_equiv = Etype (gnat_desig_equiv);
3288 if (Present (gnat_desig_full)
3289 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3290 && ! Is_Constrained (gnat_desig_full))
3291 || (Ekind (gnat_desig_full) == E_Record_Subtype
3292 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3293 gnat_desig_full = Etype (gnat_desig_full);
3295 /* Now set the type that actually marks the representation of
3296 the designated type and also flag whether we have a unconstrained
3297 array. */
3298 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3299 is_unconstrained_array
3300 = (Is_Array_Type (gnat_desig_rep)
3301 && ! Is_Constrained (gnat_desig_rep));
3303 /* If we are pointing to an incomplete type whose completion is an
3304 unconstrained array, make a fat pointer type. The two types in our
3305 fields will be pointers to dummy nodes and will be replaced in
3306 update_pointer_to. Similarly, if the type itself is a dummy type or
3307 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3308 in case we have any thin pointers to it. */
3309 if (is_unconstrained_array
3310 && (Present (gnat_desig_full)
3311 || (present_gnu_tree (gnat_desig_equiv)
3312 && TYPE_IS_DUMMY_P (TREE_TYPE
3313 (get_gnu_tree (gnat_desig_equiv))))
3314 || (No (gnat_desig_full) && ! in_main_unit
3315 && defer_incomplete_level != 0
3316 && ! present_gnu_tree (gnat_desig_equiv))
3317 || (in_main_unit && is_from_limited_with
3318 && Present (Freeze_Node (gnat_desig_rep)))))
3320 tree gnu_old
3321 = (present_gnu_tree (gnat_desig_rep)
3322 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
3323 : make_dummy_type (gnat_desig_rep));
3324 tree fields;
3326 /* Show the dummy we get will be a fat pointer. */
3327 got_fat_p = made_dummy = true;
3329 /* If the call above got something that has a pointer, that
3330 pointer is our type. This could have happened either
3331 because the type was elaborated or because somebody
3332 else executed the code below. */
3333 gnu_type = TYPE_POINTER_TO (gnu_old);
3334 if (!gnu_type)
3336 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3337 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3338 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3339 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3341 TYPE_NAME (gnu_template_type)
3342 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3343 "XUB");
3344 TYPE_DUMMY_P (gnu_template_type) = 1;
3346 TYPE_NAME (gnu_array_type)
3347 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3348 "XUA");
3349 TYPE_DUMMY_P (gnu_array_type) = 1;
3351 gnu_type = make_node (RECORD_TYPE);
3352 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3353 TYPE_POINTER_TO (gnu_old) = gnu_type;
3355 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3356 fields
3357 = chainon (chainon (NULL_TREE,
3358 create_field_decl
3359 (get_identifier ("P_ARRAY"),
3360 gnu_ptr_array,
3361 gnu_type, 0, 0, 0, 0)),
3362 create_field_decl (get_identifier ("P_BOUNDS"),
3363 gnu_ptr_template,
3364 gnu_type, 0, 0, 0, 0));
3366 /* Make sure we can place this into a register. */
3367 TYPE_ALIGN (gnu_type)
3368 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3369 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
3371 /* Do not finalize this record type since the types of
3372 its fields are incomplete. */
3373 finish_record_type (gnu_type, fields, 0, true);
3375 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3376 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3377 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3378 "XUT");
3379 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3383 /* If we already know what the full type is, use it. */
3384 else if (Present (gnat_desig_full)
3385 && present_gnu_tree (gnat_desig_full))
3386 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3388 /* Get the type of the thing we are to point to and build a pointer
3389 to it. If it is a reference to an incomplete or private type with a
3390 full view that is a record, make a dummy type node and get the
3391 actual type later when we have verified it is safe. */
3392 else if ((! in_main_unit
3393 && ! present_gnu_tree (gnat_desig_equiv)
3394 && Present (gnat_desig_full)
3395 && ! present_gnu_tree (gnat_desig_full)
3396 && Is_Record_Type (gnat_desig_full))
3397 /* Likewise if we are pointing to a record or array and we
3398 are to defer elaborating incomplete types. We do this
3399 since this access type may be the full view of some
3400 private type. Note that the unconstrained array case is
3401 handled above. */
3402 || ((! in_main_unit || imported_p)
3403 && defer_incomplete_level != 0
3404 && ! present_gnu_tree (gnat_desig_equiv)
3405 && ((Is_Record_Type (gnat_desig_rep)
3406 || Is_Array_Type (gnat_desig_rep))))
3407 /* If this is a reference from a limited_with type back to our
3408 main unit and there's a Freeze_Node for it, either we have
3409 already processed the declaration and made the dummy type,
3410 in which case we just reuse the latter, or we have not yet,
3411 in which case we make the dummy type and it will be reused
3412 when the declaration is processed. In both cases, the
3413 pointer eventually created below will be automatically
3414 adjusted when the Freeze_Node is processed. Note that the
3415 unconstrained array case is handled above. */
3416 || (in_main_unit && is_from_limited_with
3417 && Present (Freeze_Node (gnat_desig_rep))))
3419 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3420 made_dummy = true;
3423 /* Otherwise handle the case of a pointer to itself. */
3424 else if (gnat_desig_equiv == gnat_entity)
3426 gnu_type
3427 = build_pointer_type_for_mode (void_type_node, p_mode,
3428 No_Strict_Aliasing (gnat_entity));
3429 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3432 /* If expansion is disabled, the equivalent type of a concurrent
3433 type is absent, so build a dummy pointer type. */
3434 else if (type_annotate_only && No (gnat_desig_equiv))
3435 gnu_type = ptr_void_type_node;
3437 /* Finally, handle the straightforward case where we can just
3438 elaborate our designated type and point to it. */
3439 else
3440 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3442 /* It is possible that a call to gnat_to_gnu_type above resolved our
3443 type. If so, just return it. */
3444 if (present_gnu_tree (gnat_entity))
3446 maybe_present = true;
3447 break;
3450 /* If we have a GCC type for the designated type, possibly modify it
3451 if we are pointing only to constant objects and then make a pointer
3452 to it. Don't do this for unconstrained arrays. */
3453 if (!gnu_type && gnu_desig_type)
3455 if (Is_Access_Constant (gnat_entity)
3456 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3458 gnu_desig_type
3459 = build_qualified_type
3460 (gnu_desig_type,
3461 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3463 /* Some extra processing is required if we are building a
3464 pointer to an incomplete type (in the GCC sense). We might
3465 have such a type if we just made a dummy, or directly out
3466 of the call to gnat_to_gnu_type above if we are processing
3467 an access type for a record component designating the
3468 record type itself. */
3469 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3471 /* We must ensure that the pointer to variant we make will
3472 be processed by update_pointer_to when the initial type
3473 is completed. Pretend we made a dummy and let further
3474 processing act as usual. */
3475 made_dummy = true;
3477 /* We must ensure that update_pointer_to will not retrieve
3478 the dummy variant when building a properly qualified
3479 version of the complete type. We take advantage of the
3480 fact that get_qualified_type is requiring TYPE_NAMEs to
3481 match to influence build_qualified_type and then also
3482 update_pointer_to here. */
3483 TYPE_NAME (gnu_desig_type)
3484 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3488 gnu_type
3489 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3490 No_Strict_Aliasing (gnat_entity));
3493 /* If we are not defining this object and we made a dummy pointer,
3494 save our current definition, evaluate the actual type, and replace
3495 the tentative type we made with the actual one. If we are to defer
3496 actually looking up the actual type, make an entry in the
3497 deferred list. If this is from a limited with, we have to defer
3498 to the end of the current spec in two cases: first if the
3499 designated type is in the current unit and second if the access
3500 type is. */
3501 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3503 tree gnu_old_type
3504 = TYPE_FAT_POINTER_P (gnu_type)
3505 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3507 if (esize == POINTER_SIZE
3508 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3509 gnu_type
3510 = build_pointer_type
3511 (TYPE_OBJECT_RECORD_TYPE
3512 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3514 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3515 !Comes_From_Source (gnat_entity),
3516 debug_info_p, gnat_entity);
3517 this_made_decl = true;
3518 gnu_type = TREE_TYPE (gnu_decl);
3519 save_gnu_tree (gnat_entity, gnu_decl, false);
3520 saved = true;
3522 if (defer_incomplete_level == 0
3523 && ! (is_from_limited_with
3524 && (in_main_unit
3525 || In_Extended_Main_Code_Unit (gnat_entity))))
3526 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3527 gnat_to_gnu_type (gnat_desig_equiv));
3529 /* Note that the call to gnat_to_gnu_type here might have
3530 updated gnu_old_type directly, in which case it is not a
3531 dummy type any more when we get into update_pointer_to.
3533 This may happen for instance when the designated type is a
3534 record type, because their elaboration starts with an
3535 initial node from make_dummy_type, which may yield the same
3536 node as the one we got.
3538 Besides, variants of this non-dummy type might have been
3539 created along the way. update_pointer_to is expected to
3540 properly take care of those situations. */
3541 else
3543 struct incomplete *p
3544 = (struct incomplete *) xmalloc (sizeof
3545 (struct incomplete));
3546 struct incomplete **head
3547 = (is_from_limited_with
3548 && (in_main_unit
3549 || In_Extended_Main_Code_Unit (gnat_entity))
3550 ? &defer_limited_with : &defer_incomplete_list);
3552 p->old_type = gnu_old_type;
3553 p->full_type = gnat_desig_equiv;
3554 p->next = *head;
3555 *head = p;
3559 break;
3561 case E_Access_Protected_Subprogram_Type:
3562 case E_Anonymous_Access_Protected_Subprogram_Type:
3563 if (type_annotate_only && No (gnat_equiv_type))
3564 gnu_type = ptr_void_type_node;
3565 else
3567 /* The runtime representation is the equivalent type. */
3568 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3569 maybe_present = 1;
3572 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3573 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3574 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3575 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3576 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3577 NULL_TREE, 0);
3579 break;
3581 case E_Access_Subtype:
3583 /* We treat this as identical to its base type; any constraint is
3584 meaningful only to the front end.
3586 The designated type must be elaborated as well, if it does
3587 not have its own freeze node. Designated (sub)types created
3588 for constrained components of records with discriminants are
3589 not frozen by the front end and thus not elaborated by gigi,
3590 because their use may appear before the base type is frozen,
3591 and because it is not clear that they are needed anywhere in
3592 Gigi. With the current model, there is no correct place where
3593 they could be elaborated. */
3595 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3596 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3597 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3598 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3599 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3601 /* If we are not defining this entity, and we have incomplete
3602 entities being processed above us, make a dummy type and
3603 elaborate it later. */
3604 if (!definition && defer_incomplete_level != 0)
3606 struct incomplete *p
3607 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3608 tree gnu_ptr_type
3609 = build_pointer_type
3610 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3612 p->old_type = TREE_TYPE (gnu_ptr_type);
3613 p->full_type = Directly_Designated_Type (gnat_entity);
3614 p->next = defer_incomplete_list;
3615 defer_incomplete_list = p;
3617 else if (!IN (Ekind (Base_Type
3618 (Directly_Designated_Type (gnat_entity))),
3619 Incomplete_Or_Private_Kind))
3620 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3621 NULL_TREE, 0);
3624 maybe_present = true;
3625 break;
3627 /* Subprogram Entities
3629 The following access functions are defined for subprograms (functions
3630 or procedures):
3632 First_Formal The first formal parameter.
3633 Is_Imported Indicates that the subprogram has appeared in
3634 an INTERFACE or IMPORT pragma. For now we
3635 assume that the external language is C.
3636 Is_Exported Likewise but for an EXPORT pragma.
3637 Is_Inlined True if the subprogram is to be inlined.
3639 In addition for function subprograms we have:
3641 Etype Return type of the function.
3643 Each parameter is first checked by calling must_pass_by_ref on its
3644 type to determine if it is passed by reference. For parameters which
3645 are copied in, if they are Ada In Out or Out parameters, their return
3646 value becomes part of a record which becomes the return type of the
3647 function (C function - note that this applies only to Ada procedures
3648 so there is no Ada return type). Additional code to store back the
3649 parameters will be generated on the caller side. This transformation
3650 is done here, not in the front-end.
3652 The intended result of the transformation can be seen from the
3653 equivalent source rewritings that follow:
3655 struct temp {int a,b};
3656 procedure P (A,B: In Out ...) is temp P (int A,B)
3657 begin {
3658 .. ..
3659 end P; return {A,B};
3662 temp t;
3663 P(X,Y); t = P(X,Y);
3664 X = t.a , Y = t.b;
3666 For subprogram types we need to perform mainly the same conversions to
3667 GCC form that are needed for procedures and function declarations. The
3668 only difference is that at the end, we make a type declaration instead
3669 of a function declaration. */
3671 case E_Subprogram_Type:
3672 case E_Function:
3673 case E_Procedure:
3675 /* The first GCC parameter declaration (a PARM_DECL node). The
3676 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3677 actually is the head of this parameter list. */
3678 tree gnu_param_list = NULL_TREE;
3679 /* Likewise for the stub associated with an exported procedure. */
3680 tree gnu_stub_param_list = NULL_TREE;
3681 /* The type returned by a function. If the subprogram is a procedure
3682 this type should be void_type_node. */
3683 tree gnu_return_type = void_type_node;
3684 /* List of fields in return type of procedure with copy-in copy-out
3685 parameters. */
3686 tree gnu_field_list = NULL_TREE;
3687 /* Non-null for subprograms containing parameters passed by copy-in
3688 copy-out (Ada In Out or Out parameters not passed by reference),
3689 in which case it is the list of nodes used to specify the values of
3690 the in out/out parameters that are returned as a record upon
3691 procedure return. The TREE_PURPOSE of an element of this list is
3692 a field of the record and the TREE_VALUE is the PARM_DECL
3693 corresponding to that field. This list will be saved in the
3694 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3695 tree gnu_return_list = NULL_TREE;
3696 /* If an import pragma asks to map this subprogram to a GCC builtin,
3697 this is the builtin DECL node. */
3698 tree gnu_builtin_decl = NULL_TREE;
3699 /* For the stub associated with an exported procedure. */
3700 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3701 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3702 Entity_Id gnat_param;
3703 bool inline_flag = Is_Inlined (gnat_entity);
3704 bool public_flag = Is_Public (gnat_entity) || imported_p;
3705 bool extern_flag
3706 = (Is_Public (gnat_entity) && !definition) || imported_p;
3707 bool pure_flag = Is_Pure (gnat_entity);
3708 bool volatile_flag = No_Return (gnat_entity);
3709 bool returns_by_ref = false;
3710 bool returns_unconstrained = false;
3711 bool returns_by_target_ptr = false;
3712 bool has_copy_in_out = false;
3713 bool has_stub = false;
3714 int parmnum;
3716 if (kind == E_Subprogram_Type && !definition)
3717 /* A parameter may refer to this type, so defer completion
3718 of any incomplete types. */
3719 defer_incomplete_level++, this_deferred = true;
3721 /* If the subprogram has an alias, it is probably inherited, so
3722 we can use the original one. If the original "subprogram"
3723 is actually an enumeration literal, it may be the first use
3724 of its type, so we must elaborate that type now. */
3725 if (Present (Alias (gnat_entity)))
3727 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3728 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3730 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3731 gnu_expr, 0);
3733 /* Elaborate any Itypes in the parameters of this entity. */
3734 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3735 Present (gnat_temp);
3736 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3737 if (Is_Itype (Etype (gnat_temp)))
3738 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3740 break;
3743 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3744 corresponding DECL node.
3746 We still want the parameter associations to take place because the
3747 proper generation of calls depends on it (a GNAT parameter without
3748 a corresponding GCC tree has a very specific meaning), so we don't
3749 just break here. */
3750 if (Convention (gnat_entity) == Convention_Intrinsic)
3751 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3753 /* ??? What if we don't find the builtin node above ? warn ? err ?
3754 In the current state we neither warn nor err, and calls will just
3755 be handled as for regular subprograms. */
3757 if (kind == E_Function || kind == E_Subprogram_Type)
3758 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3760 /* If this function returns by reference, make the actual
3761 return type of this function the pointer and mark the decl. */
3762 if (Returns_By_Ref (gnat_entity))
3764 returns_by_ref = true;
3765 gnu_return_type = build_pointer_type (gnu_return_type);
3768 /* If the Mechanism is By_Reference, ensure the return type uses
3769 the machine's by-reference mechanism, which may not the same
3770 as above (e.g., it might be by passing a fake parameter). */
3771 else if (kind == E_Function
3772 && Mechanism (gnat_entity) == By_Reference)
3774 TREE_ADDRESSABLE (gnu_return_type) = 1;
3776 /* We expect this bit to be reset by gigi shortly, so can avoid a
3777 type node copy here. This actually also prevents troubles with
3778 the generation of debug information for the function, because
3779 we might have issued such info for this type already, and would
3780 be attaching a distinct type node to the function if we made a
3781 copy here. */
3784 /* If we are supposed to return an unconstrained array,
3785 actually return a fat pointer and make a note of that. Return
3786 a pointer to an unconstrained record of variable size. */
3787 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3789 gnu_return_type = TREE_TYPE (gnu_return_type);
3790 returns_unconstrained = true;
3793 /* If the type requires a transient scope, the result is allocated
3794 on the secondary stack, so the result type of the function is
3795 just a pointer. */
3796 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3798 gnu_return_type = build_pointer_type (gnu_return_type);
3799 returns_unconstrained = true;
3802 /* If the type is a padded type and the underlying type would not
3803 be passed by reference or this function has a foreign convention,
3804 return the underlying type. */
3805 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3806 && TYPE_IS_PADDING_P (gnu_return_type)
3807 && (!default_pass_by_ref (TREE_TYPE
3808 (TYPE_FIELDS (gnu_return_type)))
3809 || Has_Foreign_Convention (gnat_entity)))
3810 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3812 /* If the return type has a non-constant size, we convert the function
3813 into a procedure and its caller will pass a pointer to an object as
3814 the first parameter when we call the function. This can happen for
3815 an unconstrained type with a maximum size or a constrained type with
3816 a size not known at compile time. */
3817 if (TYPE_SIZE_UNIT (gnu_return_type)
3818 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3820 returns_by_target_ptr = true;
3821 gnu_param_list
3822 = create_param_decl (get_identifier ("TARGET"),
3823 build_reference_type (gnu_return_type),
3824 true);
3825 gnu_return_type = void_type_node;
3828 /* If the return type has a size that overflows, we cannot have
3829 a function that returns that type. This usage doesn't make
3830 sense anyway, so give an error here. */
3831 if (TYPE_SIZE_UNIT (gnu_return_type)
3832 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3833 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3835 post_error ("cannot return type whose size overflows",
3836 gnat_entity);
3837 gnu_return_type = copy_node (gnu_return_type);
3838 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3839 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3840 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3841 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3844 /* Look at all our parameters and get the type of
3845 each. While doing this, build a copy-out structure if
3846 we need one. */
3848 /* Loop over the parameters and get their associated GCC tree.
3849 While doing this, build a copy-out structure if we need one. */
3850 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3851 Present (gnat_param);
3852 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3854 tree gnu_param_name = get_entity_name (gnat_param);
3855 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3856 tree gnu_param, gnu_field;
3857 bool copy_in_copy_out = false;
3858 Mechanism_Type mech = Mechanism (gnat_param);
3860 /* Builtins are expanded inline and there is no real call sequence
3861 involved. So the type expected by the underlying expander is
3862 always the type of each argument "as is". */
3863 if (gnu_builtin_decl)
3864 mech = By_Copy;
3865 /* Handle the first parameter of a valued procedure specially. */
3866 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3867 mech = By_Copy_Return;
3868 /* Otherwise, see if a Mechanism was supplied that forced this
3869 parameter to be passed one way or another. */
3870 else if (mech == Default
3871 || mech == By_Copy || mech == By_Reference)
3873 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3874 mech = By_Descriptor;
3876 else if (By_Short_Descriptor_Last <= mech &&
3877 mech <= By_Short_Descriptor)
3878 mech = By_Short_Descriptor;
3880 else if (mech > 0)
3882 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3883 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3884 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3885 mech))
3886 mech = By_Reference;
3887 else
3888 mech = By_Copy;
3890 else
3892 post_error ("unsupported mechanism for&", gnat_param);
3893 mech = Default;
3896 gnu_param
3897 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
3898 Has_Foreign_Convention (gnat_entity),
3899 &copy_in_copy_out);
3901 /* We are returned either a PARM_DECL or a type if no parameter
3902 needs to be passed; in either case, adjust the type. */
3903 if (DECL_P (gnu_param))
3904 gnu_param_type = TREE_TYPE (gnu_param);
3905 else
3907 gnu_param_type = gnu_param;
3908 gnu_param = NULL_TREE;
3911 if (gnu_param)
3913 /* If it's an exported subprogram, we build a parameter list
3914 in parallel, in case we need to emit a stub for it. */
3915 if (Is_Exported (gnat_entity))
3917 gnu_stub_param_list
3918 = chainon (gnu_param, gnu_stub_param_list);
3919 /* Change By_Descriptor parameter to By_Reference for
3920 the internal version of an exported subprogram. */
3921 if (mech == By_Descriptor || mech == By_Short_Descriptor)
3923 gnu_param
3924 = gnat_to_gnu_param (gnat_param, By_Reference,
3925 gnat_entity, false,
3926 &copy_in_copy_out);
3927 has_stub = true;
3929 else
3930 gnu_param = copy_node (gnu_param);
3933 gnu_param_list = chainon (gnu_param, gnu_param_list);
3934 Sloc_to_locus (Sloc (gnat_param),
3935 &DECL_SOURCE_LOCATION (gnu_param));
3936 save_gnu_tree (gnat_param, gnu_param, false);
3938 /* If a parameter is a pointer, this function may modify
3939 memory through it and thus shouldn't be considered
3940 a pure function. Also, the memory may be modified
3941 between two calls, so they can't be CSE'ed. The latter
3942 case also handles by-ref parameters. */
3943 if (POINTER_TYPE_P (gnu_param_type)
3944 || TYPE_FAT_POINTER_P (gnu_param_type))
3945 pure_flag = false;
3948 if (copy_in_copy_out)
3950 if (!has_copy_in_out)
3952 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
3953 gnu_return_type = make_node (RECORD_TYPE);
3954 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3955 has_copy_in_out = true;
3958 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3959 gnu_return_type, 0, 0, 0, 0);
3960 Sloc_to_locus (Sloc (gnat_param),
3961 &DECL_SOURCE_LOCATION (gnu_field));
3962 TREE_CHAIN (gnu_field) = gnu_field_list;
3963 gnu_field_list = gnu_field;
3964 gnu_return_list = tree_cons (gnu_field, gnu_param,
3965 gnu_return_list);
3969 /* Do not compute record for out parameters if subprogram is
3970 stubbed since structures are incomplete for the back-end. */
3971 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
3972 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3973 0, false);
3975 /* If we have a CICO list but it has only one entry, we convert
3976 this function into a function that simply returns that one
3977 object. */
3978 if (list_length (gnu_return_list) == 1)
3979 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3981 if (Has_Stdcall_Convention (gnat_entity))
3982 prepend_one_attribute_to
3983 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3984 get_identifier ("stdcall"), NULL_TREE,
3985 gnat_entity);
3987 /* If we are on a target where stack realignment is needed for 'main'
3988 to honor GCC's implicit expectations (stack alignment greater than
3989 what the base ABI guarantees), ensure we do the same for foreign
3990 convention subprograms as they might be used as callbacks from code
3991 breaking such expectations. Note that this applies to task entry
3992 points in particular. */
3993 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
3994 && Has_Foreign_Convention (gnat_entity))
3995 prepend_one_attribute_to
3996 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3997 get_identifier ("force_align_arg_pointer"), NULL_TREE,
3998 gnat_entity);
4000 /* The lists have been built in reverse. */
4001 gnu_param_list = nreverse (gnu_param_list);
4002 if (has_stub)
4003 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4004 gnu_return_list = nreverse (gnu_return_list);
4006 if (Ekind (gnat_entity) == E_Function)
4007 Set_Mechanism (gnat_entity,
4008 (returns_by_ref || returns_unconstrained
4009 ? By_Reference : By_Copy));
4010 gnu_type
4011 = create_subprog_type (gnu_return_type, gnu_param_list,
4012 gnu_return_list, returns_unconstrained,
4013 returns_by_ref, returns_by_target_ptr);
4015 if (has_stub)
4016 gnu_stub_type
4017 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4018 gnu_return_list, returns_unconstrained,
4019 returns_by_ref, returns_by_target_ptr);
4021 /* A subprogram (something that doesn't return anything) shouldn't
4022 be considered Pure since there would be no reason for such a
4023 subprogram. Note that procedures with Out (or In Out) parameters
4024 have already been converted into a function with a return type. */
4025 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4026 pure_flag = false;
4028 /* The semantics of "pure" in Ada essentially matches that of "const"
4029 in the back-end. In particular, both properties are orthogonal to
4030 the "nothrow" property. But this is true only if the EH circuitry
4031 is explicit in the internal representation of the back-end. If we
4032 are to completely hide the EH circuitry from it, we need to declare
4033 that calls to pure Ada subprograms that can throw have side effects
4034 since they can trigger an "abnormal" transfer of control flow; thus
4035 they can be neither "const" nor "pure" in the back-end sense. */
4036 gnu_type
4037 = build_qualified_type (gnu_type,
4038 TYPE_QUALS (gnu_type)
4039 | (Exception_Mechanism == Back_End_Exceptions
4040 ? TYPE_QUAL_CONST * pure_flag : 0)
4041 | (TYPE_QUAL_VOLATILE * volatile_flag));
4043 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4045 if (has_stub)
4046 gnu_stub_type
4047 = build_qualified_type (gnu_stub_type,
4048 TYPE_QUALS (gnu_stub_type)
4049 | (Exception_Mechanism == Back_End_Exceptions
4050 ? TYPE_QUAL_CONST * pure_flag : 0)
4051 | (TYPE_QUAL_VOLATILE * volatile_flag));
4053 /* If we have a builtin decl for that function, check the signatures
4054 compatibilities. If the signatures are compatible, use the builtin
4055 decl. If they are not, we expect the checker predicate to have
4056 posted the appropriate errors, and just continue with what we have
4057 so far. */
4058 if (gnu_builtin_decl)
4060 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4062 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4064 gnu_decl = gnu_builtin_decl;
4065 gnu_type = gnu_builtin_type;
4066 break;
4070 /* If there was no specified Interface_Name and the external and
4071 internal names of the subprogram are the same, only use the
4072 internal name to allow disambiguation of nested subprograms. */
4073 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
4074 gnu_ext_name = NULL_TREE;
4076 /* If we are defining the subprogram and it has an Address clause
4077 we must get the address expression from the saved GCC tree for the
4078 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4079 the address expression here since the front-end has guaranteed
4080 in that case that the elaboration has no effects. If there is
4081 an Address clause and we are not defining the object, just
4082 make it a constant. */
4083 if (Present (Address_Clause (gnat_entity)))
4085 tree gnu_address = NULL_TREE;
4087 if (definition)
4088 gnu_address
4089 = (present_gnu_tree (gnat_entity)
4090 ? get_gnu_tree (gnat_entity)
4091 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4093 save_gnu_tree (gnat_entity, NULL_TREE, false);
4095 /* Convert the type of the object to a reference type that can
4096 alias everything as per 13.3(19). */
4097 gnu_type
4098 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4099 if (gnu_address)
4100 gnu_address = convert (gnu_type, gnu_address);
4102 gnu_decl
4103 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
4104 gnu_address, false, Is_Public (gnat_entity),
4105 extern_flag, false, NULL, gnat_entity);
4106 DECL_BY_REF_P (gnu_decl) = 1;
4109 else if (kind == E_Subprogram_Type)
4110 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4111 !Comes_From_Source (gnat_entity),
4112 debug_info_p, gnat_entity);
4113 else
4115 if (has_stub)
4117 gnu_stub_name = gnu_ext_name;
4118 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4119 public_flag = false;
4122 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
4123 gnu_type, gnu_param_list,
4124 inline_flag, public_flag,
4125 extern_flag, attr_list,
4126 gnat_entity);
4127 if (has_stub)
4129 tree gnu_stub_decl
4130 = create_subprog_decl (gnu_entity_id, gnu_stub_name,
4131 gnu_stub_type, gnu_stub_param_list,
4132 inline_flag, true,
4133 extern_flag, attr_list,
4134 gnat_entity);
4135 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4138 /* This is unrelated to the stub built right above. */
4139 DECL_STUBBED_P (gnu_decl)
4140 = Convention (gnat_entity) == Convention_Stubbed;
4143 break;
4145 case E_Incomplete_Type:
4146 case E_Incomplete_Subtype:
4147 case E_Private_Type:
4148 case E_Private_Subtype:
4149 case E_Limited_Private_Type:
4150 case E_Limited_Private_Subtype:
4151 case E_Record_Type_With_Private:
4152 case E_Record_Subtype_With_Private:
4154 /* Get the "full view" of this entity. If this is an incomplete
4155 entity from a limited with, treat its non-limited view as the
4156 full view. Otherwise, use either the full view or the underlying
4157 full view, whichever is present. This is used in all the tests
4158 below. */
4159 Entity_Id full_view
4160 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4161 && From_With_Type (gnat_entity))
4162 ? Non_Limited_View (gnat_entity)
4163 : Present (Full_View (gnat_entity))
4164 ? Full_View (gnat_entity)
4165 : Underlying_Full_View (gnat_entity);
4167 /* If this is an incomplete type with no full view, it must be a Taft
4168 Amendment type, in which case we return a dummy type. Otherwise,
4169 just get the type from its Etype. */
4170 if (No (full_view))
4172 if (kind == E_Incomplete_Type)
4173 gnu_type = make_dummy_type (gnat_entity);
4174 else
4176 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4177 NULL_TREE, 0);
4178 maybe_present = true;
4180 break;
4183 /* If we already made a type for the full view, reuse it. */
4184 else if (present_gnu_tree (full_view))
4186 gnu_decl = get_gnu_tree (full_view);
4187 break;
4190 /* Otherwise, if we are not defining the type now, get the type
4191 from the full view. But always get the type from the full view
4192 for define on use types, since otherwise we won't see them! */
4193 else if (!definition
4194 || (Is_Itype (full_view)
4195 && No (Freeze_Node (gnat_entity)))
4196 || (Is_Itype (gnat_entity)
4197 && No (Freeze_Node (full_view))))
4199 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4200 maybe_present = true;
4201 break;
4204 /* For incomplete types, make a dummy type entry which will be
4205 replaced later. */
4206 gnu_type = make_dummy_type (gnat_entity);
4208 /* Save this type as the full declaration's type so we can do any
4209 needed updates when we see it. */
4210 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4211 !Comes_From_Source (gnat_entity),
4212 debug_info_p, gnat_entity);
4213 save_gnu_tree (full_view, gnu_decl, 0);
4214 break;
4217 /* Simple class_wide types are always viewed as their root_type
4218 by Gigi unless an Equivalent_Type is specified. */
4219 case E_Class_Wide_Type:
4220 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4221 maybe_present = true;
4222 break;
4224 case E_Task_Type:
4225 case E_Task_Subtype:
4226 case E_Protected_Type:
4227 case E_Protected_Subtype:
4228 if (type_annotate_only && No (gnat_equiv_type))
4229 gnu_type = void_type_node;
4230 else
4231 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4233 maybe_present = true;
4234 break;
4236 case E_Label:
4237 gnu_decl = create_label_decl (gnu_entity_id);
4238 break;
4240 case E_Block:
4241 case E_Loop:
4242 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4243 we've already saved it, so we don't try to. */
4244 gnu_decl = error_mark_node;
4245 saved = true;
4246 break;
4248 default:
4249 gcc_unreachable ();
4252 /* If we had a case where we evaluated another type and it might have
4253 defined this one, handle it here. */
4254 if (maybe_present && present_gnu_tree (gnat_entity))
4256 gnu_decl = get_gnu_tree (gnat_entity);
4257 saved = true;
4260 /* If we are processing a type and there is either no decl for it or
4261 we just made one, do some common processing for the type, such as
4262 handling alignment and possible padding. */
4264 if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
4266 if (Is_Tagged_Type (gnat_entity)
4267 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4268 TYPE_ALIGN_OK (gnu_type) = 1;
4270 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4271 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4273 /* ??? Don't set the size for a String_Literal since it is either
4274 confirming or we don't handle it properly (if the low bound is
4275 non-constant). */
4276 if (!gnu_size && kind != E_String_Literal_Subtype)
4277 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4278 TYPE_DECL, false,
4279 Has_Size_Clause (gnat_entity));
4281 /* If a size was specified, see if we can make a new type of that size
4282 by rearranging the type, for example from a fat to a thin pointer. */
4283 if (gnu_size)
4285 gnu_type
4286 = make_type_from_size (gnu_type, gnu_size,
4287 Has_Biased_Representation (gnat_entity));
4289 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4290 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4291 gnu_size = 0;
4294 /* If the alignment hasn't already been processed and this is
4295 not an unconstrained array, see if an alignment is specified.
4296 If not, we pick a default alignment for atomic objects. */
4297 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4299 else if (Known_Alignment (gnat_entity))
4301 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4302 TYPE_ALIGN (gnu_type));
4304 /* Warn on suspiciously large alignments. This should catch
4305 errors about the (alignment,byte)/(size,bit) discrepancy. */
4306 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4308 tree size;
4310 /* If a size was specified, take it into account. Otherwise
4311 use the RM size for records as the type size has already
4312 been adjusted to the alignment. */
4313 if (gnu_size)
4314 size = gnu_size;
4315 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4316 || TREE_CODE (gnu_type) == UNION_TYPE
4317 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4318 && !TYPE_IS_FAT_POINTER_P (gnu_type))
4319 size = rm_size (gnu_type);
4320 else
4321 size = TYPE_SIZE (gnu_type);
4323 /* Consider an alignment as suspicious if the alignment/size
4324 ratio is greater or equal to the byte/bit ratio. */
4325 if (host_integerp (size, 1)
4326 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4327 post_error_ne ("?suspiciously large alignment specified for&",
4328 Expression (Alignment_Clause (gnat_entity)),
4329 gnat_entity);
4332 else if (Is_Atomic (gnat_entity) && !gnu_size
4333 && host_integerp (TYPE_SIZE (gnu_type), 1)
4334 && integer_pow2p (TYPE_SIZE (gnu_type)))
4335 align = MIN (BIGGEST_ALIGNMENT,
4336 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4337 else if (Is_Atomic (gnat_entity) && gnu_size
4338 && host_integerp (gnu_size, 1)
4339 && integer_pow2p (gnu_size))
4340 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4342 /* See if we need to pad the type. If we did, and made a record,
4343 the name of the new type may be changed. So get it back for
4344 us when we make the new TYPE_DECL below. */
4345 if (gnu_size || align > 0)
4346 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4347 "PAD", true, definition, false);
4349 if (TREE_CODE (gnu_type) == RECORD_TYPE
4350 && TYPE_IS_PADDING_P (gnu_type))
4352 gnu_entity_id = TYPE_NAME (gnu_type);
4353 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
4354 gnu_entity_id = DECL_NAME (gnu_entity_id);
4357 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4359 /* If we are at global level, GCC will have applied variable_size to
4360 the type, but that won't have done anything. So, if it's not
4361 a constant or self-referential, call elaborate_expression_1 to
4362 make a variable for the size rather than calculating it each time.
4363 Handle both the RM size and the actual size. */
4364 if (global_bindings_p ()
4365 && TYPE_SIZE (gnu_type)
4366 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4367 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4369 if (TREE_CODE (gnu_type) == RECORD_TYPE
4370 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4371 TYPE_SIZE (gnu_type), 0))
4373 TYPE_SIZE (gnu_type)
4374 = elaborate_expression_1 (gnat_entity, gnat_entity,
4375 TYPE_SIZE (gnu_type),
4376 get_identifier ("SIZE"),
4377 definition, 0);
4378 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4380 else
4382 TYPE_SIZE (gnu_type)
4383 = elaborate_expression_1 (gnat_entity, gnat_entity,
4384 TYPE_SIZE (gnu_type),
4385 get_identifier ("SIZE"),
4386 definition, 0);
4388 /* ??? For now, store the size as a multiple of the alignment
4389 in bytes so that we can see the alignment from the tree. */
4390 TYPE_SIZE_UNIT (gnu_type)
4391 = build_binary_op
4392 (MULT_EXPR, sizetype,
4393 elaborate_expression_1
4394 (gnat_entity, gnat_entity,
4395 build_binary_op (EXACT_DIV_EXPR, sizetype,
4396 TYPE_SIZE_UNIT (gnu_type),
4397 size_int (TYPE_ALIGN (gnu_type)
4398 / BITS_PER_UNIT)),
4399 get_identifier ("SIZE_A_UNIT"),
4400 definition, 0),
4401 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4403 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4404 SET_TYPE_ADA_SIZE
4405 (gnu_type,
4406 elaborate_expression_1 (gnat_entity,
4407 gnat_entity,
4408 TYPE_ADA_SIZE (gnu_type),
4409 get_identifier ("RM_SIZE"),
4410 definition, 0));
4414 /* If this is a record type or subtype, call elaborate_expression_1 on
4415 any field position. Do this for both global and local types.
4416 Skip any fields that we haven't made trees for to avoid problems with
4417 class wide types. */
4418 if (IN (kind, Record_Kind))
4419 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4420 gnat_temp = Next_Entity (gnat_temp))
4421 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4423 tree gnu_field = get_gnu_tree (gnat_temp);
4425 /* ??? Unfortunately, GCC needs to be able to prove the
4426 alignment of this offset and if it's a variable, it can't.
4427 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4428 right now, we have to put in an explicit multiply and
4429 divide by that value. */
4430 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4432 DECL_FIELD_OFFSET (gnu_field)
4433 = build_binary_op
4434 (MULT_EXPR, sizetype,
4435 elaborate_expression_1
4436 (gnat_temp, gnat_temp,
4437 build_binary_op (EXACT_DIV_EXPR, sizetype,
4438 DECL_FIELD_OFFSET (gnu_field),
4439 size_int (DECL_OFFSET_ALIGN (gnu_field)
4440 / BITS_PER_UNIT)),
4441 get_identifier ("OFFSET"),
4442 definition, 0),
4443 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4445 /* ??? The context of gnu_field is not necessarily gnu_type so
4446 the MULT_EXPR node built above may not be marked by the call
4447 to create_type_decl below. */
4448 if (global_bindings_p ())
4449 mark_visited (&DECL_FIELD_OFFSET (gnu_field));
4453 gnu_type = build_qualified_type (gnu_type,
4454 (TYPE_QUALS (gnu_type)
4455 | (TYPE_QUAL_VOLATILE
4456 * Treat_As_Volatile (gnat_entity))));
4458 if (Is_Atomic (gnat_entity))
4459 check_ok_for_atomic (gnu_type, gnat_entity, false);
4461 if (Present (Alignment_Clause (gnat_entity)))
4462 TYPE_USER_ALIGN (gnu_type) = 1;
4464 if (Universal_Aliasing (gnat_entity))
4465 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4467 if (!gnu_decl)
4468 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4469 !Comes_From_Source (gnat_entity),
4470 debug_info_p, gnat_entity);
4471 else
4472 TREE_TYPE (gnu_decl) = gnu_type;
4475 if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4477 gnu_type = TREE_TYPE (gnu_decl);
4479 /* Back-annotate the Alignment of the type if not already in the
4480 tree. Likewise for sizes. */
4481 if (Unknown_Alignment (gnat_entity))
4482 Set_Alignment (gnat_entity,
4483 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4485 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4487 /* If the size is self-referential, we annotate the maximum
4488 value of that size. */
4489 tree gnu_size = TYPE_SIZE (gnu_type);
4491 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4492 gnu_size = max_size (gnu_size, true);
4494 Set_Esize (gnat_entity, annotate_value (gnu_size));
4496 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4498 /* In this mode the tag and the parent components are not
4499 generated by the front-end, so the sizes must be adjusted
4500 explicitly now. */
4501 int size_offset, new_size;
4503 if (Is_Derived_Type (gnat_entity))
4505 size_offset
4506 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4507 Set_Alignment (gnat_entity,
4508 Alignment (Etype (Base_Type (gnat_entity))));
4510 else
4511 size_offset = POINTER_SIZE;
4513 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4514 Set_Esize (gnat_entity,
4515 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4516 / POINTER_SIZE) * POINTER_SIZE));
4517 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4521 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4522 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4525 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4526 DECL_ARTIFICIAL (gnu_decl) = 1;
4528 if (!debug_info_p && DECL_P (gnu_decl)
4529 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4530 && No (Renamed_Object (gnat_entity)))
4531 DECL_IGNORED_P (gnu_decl) = 1;
4533 /* If we haven't already, associate the ..._DECL node that we just made with
4534 the input GNAT entity node. */
4535 if (!saved)
4536 save_gnu_tree (gnat_entity, gnu_decl, false);
4538 /* If this is an enumeral or floating-point type, we were not able to set
4539 the bounds since they refer to the type. These bounds are always static.
4541 For enumeration types, also write debugging information and declare the
4542 enumeration literal table, if needed. */
4544 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4545 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4547 tree gnu_scalar_type = gnu_type;
4549 /* If this is a padded type, we need to use the underlying type. */
4550 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
4551 && TYPE_IS_PADDING_P (gnu_scalar_type))
4552 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4554 /* If this is a floating point type and we haven't set a floating
4555 point type yet, use this in the evaluation of the bounds. */
4556 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4557 longest_float_type_node = gnu_type;
4559 TYPE_MIN_VALUE (gnu_scalar_type)
4560 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4561 TYPE_MAX_VALUE (gnu_scalar_type)
4562 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4564 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4566 /* Since this has both a typedef and a tag, avoid outputting
4567 the name twice. */
4568 DECL_ARTIFICIAL (gnu_decl) = 1;
4569 rest_of_type_decl_compilation (gnu_decl);
4573 /* If we deferred processing of incomplete types, re-enable it. If there
4574 were no other disables and we have some to process, do so. */
4575 if (this_deferred && --defer_incomplete_level == 0)
4577 if (defer_incomplete_list)
4579 struct incomplete *incp, *next;
4581 /* We are back to level 0 for the deferring of incomplete types.
4582 But processing these incomplete types below may itself require
4583 deferring, so preserve what we have and restart from scratch. */
4584 incp = defer_incomplete_list;
4585 defer_incomplete_list = NULL;
4587 /* For finalization, however, all types must be complete so we
4588 cannot do the same because deferred incomplete types may end up
4589 referencing each other. Process them all recursively first. */
4590 defer_finalize_level++;
4592 for (; incp; incp = next)
4594 next = incp->next;
4596 if (incp->old_type)
4597 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4598 gnat_to_gnu_type (incp->full_type));
4599 free (incp);
4602 defer_finalize_level--;
4605 /* All the deferred incomplete types have been processed so we can
4606 now proceed with the finalization of the deferred types. */
4607 if (defer_finalize_level == 0 && defer_finalize_list)
4609 unsigned int i;
4610 tree t;
4612 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4613 rest_of_type_decl_compilation_no_defer (t);
4615 VEC_free (tree, heap, defer_finalize_list);
4619 /* If we are not defining this type, see if it's in the incomplete list.
4620 If so, handle that list entry now. */
4621 else if (!definition)
4623 struct incomplete *incp;
4625 for (incp = defer_incomplete_list; incp; incp = incp->next)
4626 if (incp->old_type && incp->full_type == gnat_entity)
4628 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4629 TREE_TYPE (gnu_decl));
4630 incp->old_type = NULL_TREE;
4634 if (this_global)
4635 force_global--;
4637 if (Is_Packed_Array_Type (gnat_entity)
4638 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4639 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4640 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4641 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4643 return gnu_decl;
4646 /* Similar, but if the returned value is a COMPONENT_REF, return the
4647 FIELD_DECL. */
4649 tree
4650 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4652 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4654 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4655 gnu_field = TREE_OPERAND (gnu_field, 1);
4657 return gnu_field;
4660 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4661 Every TYPE_DECL generated for a type definition must be passed
4662 to this function once everything else has been done for it. */
4664 void
4665 rest_of_type_decl_compilation (tree decl)
4667 /* We need to defer finalizing the type if incomplete types
4668 are being deferred or if they are being processed. */
4669 if (defer_incomplete_level || defer_finalize_level)
4670 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4671 else
4672 rest_of_type_decl_compilation_no_defer (decl);
4675 /* Same as above but without deferring the compilation. This
4676 function should not be invoked directly on a TYPE_DECL. */
4678 static void
4679 rest_of_type_decl_compilation_no_defer (tree decl)
4681 const int toplev = global_bindings_p ();
4682 tree t = TREE_TYPE (decl);
4684 rest_of_decl_compilation (decl, toplev, 0);
4686 /* Now process all the variants. This is needed for STABS. */
4687 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4689 if (t == TREE_TYPE (decl))
4690 continue;
4692 if (!TYPE_STUB_DECL (t))
4694 TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t);
4695 DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1;
4698 rest_of_type_compilation (t, toplev);
4702 /* Finalize any From_With_Type incomplete types. We do this after processing
4703 our compilation unit and after processing its spec, if this is a body. */
4705 void
4706 finalize_from_with_types (void)
4708 struct incomplete *incp = defer_limited_with;
4709 struct incomplete *next;
4711 defer_limited_with = 0;
4712 for (; incp; incp = next)
4714 next = incp->next;
4716 if (incp->old_type != 0)
4717 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4718 gnat_to_gnu_type (incp->full_type));
4719 free (incp);
4723 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4724 kind of type (such E_Task_Type) that has a different type which Gigi
4725 uses for its representation. If the type does not have a special type
4726 for its representation, return GNAT_ENTITY. If a type is supposed to
4727 exist, but does not, abort unless annotating types, in which case
4728 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4730 Entity_Id
4731 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4733 Entity_Id gnat_equiv = gnat_entity;
4735 if (No (gnat_entity))
4736 return gnat_entity;
4738 switch (Ekind (gnat_entity))
4740 case E_Class_Wide_Subtype:
4741 if (Present (Equivalent_Type (gnat_entity)))
4742 gnat_equiv = Equivalent_Type (gnat_entity);
4743 break;
4745 case E_Access_Protected_Subprogram_Type:
4746 case E_Anonymous_Access_Protected_Subprogram_Type:
4747 gnat_equiv = Equivalent_Type (gnat_entity);
4748 break;
4750 case E_Class_Wide_Type:
4751 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4752 ? Equivalent_Type (gnat_entity)
4753 : Root_Type (gnat_entity));
4754 break;
4756 case E_Task_Type:
4757 case E_Task_Subtype:
4758 case E_Protected_Type:
4759 case E_Protected_Subtype:
4760 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4761 break;
4763 default:
4764 break;
4767 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4768 return gnat_equiv;
4771 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4772 using MECH as its passing mechanism, to be placed in the parameter
4773 list built for GNAT_SUBPROG. Assume a foreign convention for the
4774 latter if FOREIGN is true. Also set CICO to true if the parameter
4775 must use the copy-in copy-out implementation mechanism.
4777 The returned tree is a PARM_DECL, except for those cases where no
4778 parameter needs to be actually passed to the subprogram; the type
4779 of this "shadow" parameter is then returned instead. */
4781 static tree
4782 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
4783 Entity_Id gnat_subprog, bool foreign, bool *cico)
4785 tree gnu_param_name = get_entity_name (gnat_param);
4786 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4787 tree gnu_param_type_alt = NULL_TREE;
4788 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4789 /* The parameter can be indirectly modified if its address is taken. */
4790 bool ro_param = in_param && !Address_Taken (gnat_param);
4791 bool by_return = false, by_component_ptr = false, by_ref = false;
4792 tree gnu_param;
4794 /* Copy-return is used only for the first parameter of a valued procedure.
4795 It's a copy mechanism for which a parameter is never allocated. */
4796 if (mech == By_Copy_Return)
4798 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4799 mech = By_Copy;
4800 by_return = true;
4803 /* If this is either a foreign function or if the underlying type won't
4804 be passed by reference, strip off possible padding type. */
4805 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4806 && TYPE_IS_PADDING_P (gnu_param_type))
4808 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4810 if (mech == By_Reference
4811 || foreign
4812 || (!must_pass_by_ref (unpadded_type)
4813 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4814 gnu_param_type = unpadded_type;
4817 /* If this is a read-only parameter, make a variant of the type that is
4818 read-only. ??? However, if this is an unconstrained array, that type
4819 can be very complex, so skip it for now. Likewise for any other
4820 self-referential type. */
4821 if (ro_param
4822 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4823 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4824 gnu_param_type = build_qualified_type (gnu_param_type,
4825 (TYPE_QUALS (gnu_param_type)
4826 | TYPE_QUAL_CONST));
4828 /* For foreign conventions, pass arrays as pointers to the element type.
4829 First check for unconstrained array and get the underlying array. */
4830 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4831 gnu_param_type
4832 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4834 /* VMS descriptors are themselves passed by reference.
4835 Build both a 32bit and 64bit descriptor, one of which will be chosen
4836 in fill_vms_descriptor. */
4837 if (mech == By_Descriptor)
4839 gnu_param_type_alt
4840 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
4841 Mechanism (gnat_param),
4842 gnat_subprog));
4843 gnu_param_type
4844 = build_pointer_type (build_vms_descriptor (gnu_param_type,
4845 Mechanism (gnat_param),
4846 gnat_subprog));
4848 else if (mech == By_Short_Descriptor)
4850 gnu_param_type_alt = NULL_TREE;
4852 gnu_param_type
4853 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
4854 Mechanism (gnat_param),
4855 gnat_subprog));
4858 /* Arrays are passed as pointers to element type for foreign conventions. */
4859 else if (foreign
4860 && mech != By_Copy
4861 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4863 /* Strip off any multi-dimensional entries, then strip
4864 off the last array to get the component type. */
4865 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4866 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4867 gnu_param_type = TREE_TYPE (gnu_param_type);
4869 by_component_ptr = true;
4870 gnu_param_type = TREE_TYPE (gnu_param_type);
4872 if (ro_param)
4873 gnu_param_type = build_qualified_type (gnu_param_type,
4874 (TYPE_QUALS (gnu_param_type)
4875 | TYPE_QUAL_CONST));
4877 gnu_param_type = build_pointer_type (gnu_param_type);
4880 /* Fat pointers are passed as thin pointers for foreign conventions. */
4881 else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
4882 gnu_param_type
4883 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
4885 /* If we must pass or were requested to pass by reference, do so.
4886 If we were requested to pass by copy, do so.
4887 Otherwise, for foreign conventions, pass In Out or Out parameters
4888 or aggregates by reference. For COBOL and Fortran, pass all
4889 integer and FP types that way too. For Convention Ada, use
4890 the standard Ada default. */
4891 else if (must_pass_by_ref (gnu_param_type)
4892 || mech == By_Reference
4893 || (mech != By_Copy
4894 && ((foreign
4895 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
4896 || (foreign
4897 && (Convention (gnat_subprog) == Convention_Fortran
4898 || Convention (gnat_subprog) == Convention_COBOL)
4899 && (INTEGRAL_TYPE_P (gnu_param_type)
4900 || FLOAT_TYPE_P (gnu_param_type)))
4901 || (!foreign
4902 && default_pass_by_ref (gnu_param_type)))))
4904 gnu_param_type = build_reference_type (gnu_param_type);
4905 by_ref = true;
4908 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
4909 else if (!in_param)
4910 *cico = true;
4912 if (mech == By_Copy && (by_ref || by_component_ptr))
4913 post_error ("?cannot pass & by copy", gnat_param);
4915 /* If this is an Out parameter that isn't passed by reference and isn't
4916 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4917 it will be a VAR_DECL created when we process the procedure, so just
4918 return its type. For the special parameter of a valued procedure,
4919 never pass it in.
4921 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4922 Out parameters with discriminants or implicit initial values to be
4923 handled like In Out parameters. These type are normally built as
4924 aggregates, hence passed by reference, except for some packed arrays
4925 which end up encoded in special integer types.
4927 The exception we need to make is then for packed arrays of records
4928 with discriminants or implicit initial values. We have no light/easy
4929 way to check for the latter case, so we merely check for packed arrays
4930 of records. This may lead to useless copy-in operations, but in very
4931 rare cases only, as these would be exceptions in a set of already
4932 exceptional situations. */
4933 if (Ekind (gnat_param) == E_Out_Parameter
4934 && !by_ref
4935 && (by_return
4936 || (mech != By_Descriptor
4937 && mech != By_Short_Descriptor
4938 && !POINTER_TYPE_P (gnu_param_type)
4939 && !AGGREGATE_TYPE_P (gnu_param_type)))
4940 && !(Is_Array_Type (Etype (gnat_param))
4941 && Is_Packed (Etype (gnat_param))
4942 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
4943 return gnu_param_type;
4945 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
4946 ro_param || by_ref || by_component_ptr);
4947 DECL_BY_REF_P (gnu_param) = by_ref;
4948 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
4949 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
4950 mech == By_Short_Descriptor);
4951 DECL_POINTS_TO_READONLY_P (gnu_param)
4952 = (ro_param && (by_ref || by_component_ptr));
4954 /* Save the alternate descriptor for later. */
4955 SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
4957 /* If no Mechanism was specified, indicate what we're using, then
4958 back-annotate it. */
4959 if (mech == Default)
4960 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
4962 Set_Mechanism (gnat_param, mech);
4963 return gnu_param;
4966 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4968 static bool
4969 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4971 while (Present (Corresponding_Discriminant (discr1)))
4972 discr1 = Corresponding_Discriminant (discr1);
4974 while (Present (Corresponding_Discriminant (discr2)))
4975 discr2 = Corresponding_Discriminant (discr2);
4977 return
4978 Original_Record_Component (discr1) == Original_Record_Component (discr2);
4981 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4982 a non-aliased component in the back-end sense. */
4984 static bool
4985 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
4987 /* If the type below this is a multi-array type, then
4988 this does not have aliased components. */
4989 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4990 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
4991 return true;
4993 if (Has_Aliased_Components (gnat_type))
4994 return false;
4996 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
4999 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5000 be elaborated at the point of its definition, but do nothing else. */
5002 void
5003 elaborate_entity (Entity_Id gnat_entity)
5005 switch (Ekind (gnat_entity))
5007 case E_Signed_Integer_Subtype:
5008 case E_Modular_Integer_Subtype:
5009 case E_Enumeration_Subtype:
5010 case E_Ordinary_Fixed_Point_Subtype:
5011 case E_Decimal_Fixed_Point_Subtype:
5012 case E_Floating_Point_Subtype:
5014 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5015 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5017 /* ??? Tests for avoiding static constraint error expression
5018 is needed until the front stops generating bogus conversions
5019 on bounds of real types. */
5021 if (!Raises_Constraint_Error (gnat_lb))
5022 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5023 1, 0, Needs_Debug_Info (gnat_entity));
5024 if (!Raises_Constraint_Error (gnat_hb))
5025 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5026 1, 0, Needs_Debug_Info (gnat_entity));
5027 break;
5030 case E_Record_Type:
5032 Node_Id full_definition = Declaration_Node (gnat_entity);
5033 Node_Id record_definition = Type_Definition (full_definition);
5035 /* If this is a record extension, go a level further to find the
5036 record definition. */
5037 if (Nkind (record_definition) == N_Derived_Type_Definition)
5038 record_definition = Record_Extension_Part (record_definition);
5040 break;
5042 case E_Record_Subtype:
5043 case E_Private_Subtype:
5044 case E_Limited_Private_Subtype:
5045 case E_Record_Subtype_With_Private:
5046 if (Is_Constrained (gnat_entity)
5047 && Has_Discriminants (Base_Type (gnat_entity))
5048 && Present (Discriminant_Constraint (gnat_entity)))
5050 Node_Id gnat_discriminant_expr;
5051 Entity_Id gnat_field;
5053 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
5054 gnat_discriminant_expr
5055 = First_Elmt (Discriminant_Constraint (gnat_entity));
5056 Present (gnat_field);
5057 gnat_field = Next_Discriminant (gnat_field),
5058 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5059 /* ??? For now, ignore access discriminants. */
5060 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5061 elaborate_expression (Node (gnat_discriminant_expr),
5062 gnat_entity,
5063 get_entity_name (gnat_field), 1, 0, 0);
5065 break;
5070 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5071 any entities on its entity chain similarly. */
5073 void
5074 mark_out_of_scope (Entity_Id gnat_entity)
5076 Entity_Id gnat_sub_entity;
5077 unsigned int kind = Ekind (gnat_entity);
5079 /* If this has an entity list, process all in the list. */
5080 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5081 || IN (kind, Private_Kind)
5082 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5083 || kind == E_Function || kind == E_Generic_Function
5084 || kind == E_Generic_Package || kind == E_Generic_Procedure
5085 || kind == E_Loop || kind == E_Operator || kind == E_Package
5086 || kind == E_Package_Body || kind == E_Procedure
5087 || kind == E_Record_Type || kind == E_Record_Subtype
5088 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5089 for (gnat_sub_entity = First_Entity (gnat_entity);
5090 Present (gnat_sub_entity);
5091 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5092 if (Scope (gnat_sub_entity) == gnat_entity
5093 && gnat_sub_entity != gnat_entity)
5094 mark_out_of_scope (gnat_sub_entity);
5096 /* Now clear this if it has been defined, but only do so if it isn't
5097 a subprogram or parameter. We could refine this, but it isn't
5098 worth it. If this is statically allocated, it is supposed to
5099 hang around out of cope. */
5100 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5101 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5103 save_gnu_tree (gnat_entity, NULL_TREE, true);
5104 save_gnu_tree (gnat_entity, error_mark_node, true);
5108 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
5109 is a multi-dimensional array type, do this recursively. */
5111 static void
5112 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
5114 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5115 of a one-dimensional array, since the padding has the same alias set
5116 as the field type, but if it's a multi-dimensional array, we need to
5117 see the inner types. */
5118 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5119 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5120 || TYPE_IS_PADDING_P (gnu_old_type)))
5121 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5123 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
5124 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
5125 so we need to go down to what does. */
5126 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5127 gnu_old_type
5128 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5130 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5131 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5132 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5133 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
5135 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5136 record_component_aliases (gnu_new_type);
5139 /* Return a TREE_LIST describing the substitutions needed to reflect
5140 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5141 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
5142 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
5143 gives the tree for the discriminant and TREE_VALUES is the replacement
5144 value. They are in the form of operands to substitute_in_expr.
5145 DEFINITION is as in gnat_to_gnu_entity. */
5147 static tree
5148 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
5149 tree gnu_list, bool definition)
5151 Entity_Id gnat_discrim;
5152 Node_Id gnat_value;
5154 if (No (gnat_type))
5155 gnat_type = Implementation_Base_Type (gnat_subtype);
5157 if (Has_Discriminants (gnat_type))
5158 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
5159 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
5160 Present (gnat_discrim);
5161 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
5162 gnat_value = Next_Elmt (gnat_value))
5163 /* Ignore access discriminants. */
5164 if (!Is_Access_Type (Etype (Node (gnat_value))))
5165 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
5166 elaborate_expression
5167 (Node (gnat_value), gnat_subtype,
5168 get_entity_name (gnat_discrim), definition,
5169 1, 0),
5170 gnu_list);
5172 return gnu_list;
5175 /* Return true if the size represented by GNU_SIZE can be handled by an
5176 allocation. If STATIC_P is true, consider only what can be done with a
5177 static allocation. */
5179 static bool
5180 allocatable_size_p (tree gnu_size, bool static_p)
5182 HOST_WIDE_INT our_size;
5184 /* If this is not a static allocation, the only case we want to forbid
5185 is an overflowing size. That will be converted into a raise a
5186 Storage_Error. */
5187 if (!static_p)
5188 return !(TREE_CODE (gnu_size) == INTEGER_CST
5189 && TREE_OVERFLOW (gnu_size));
5191 /* Otherwise, we need to deal with both variable sizes and constant
5192 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5193 since assemblers may not like very large sizes. */
5194 if (!host_integerp (gnu_size, 1))
5195 return false;
5197 our_size = tree_low_cst (gnu_size, 1);
5198 return (int) our_size == our_size;
5201 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5202 NAME, ARGS and ERROR_POINT. */
5204 static void
5205 prepend_one_attribute_to (struct attrib ** attr_list,
5206 enum attr_type attr_type,
5207 tree attr_name,
5208 tree attr_args,
5209 Node_Id attr_error_point)
5211 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5213 attr->type = attr_type;
5214 attr->name = attr_name;
5215 attr->args = attr_args;
5216 attr->error_point = attr_error_point;
5218 attr->next = *attr_list;
5219 *attr_list = attr;
5222 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5224 static void
5225 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5227 Node_Id gnat_temp;
5229 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5230 gnat_temp = Next_Rep_Item (gnat_temp))
5231 if (Nkind (gnat_temp) == N_Pragma)
5233 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5234 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5235 enum attr_type etype;
5237 if (Present (gnat_assoc) && Present (First (gnat_assoc))
5238 && Present (Next (First (gnat_assoc)))
5239 && (Nkind (Expression (Next (First (gnat_assoc))))
5240 == N_String_Literal))
5242 gnu_arg0 = get_identifier (TREE_STRING_POINTER
5243 (gnat_to_gnu
5244 (Expression (Next
5245 (First (gnat_assoc))))));
5246 if (Present (Next (Next (First (gnat_assoc))))
5247 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
5248 == N_String_Literal))
5249 gnu_arg1 = get_identifier (TREE_STRING_POINTER
5250 (gnat_to_gnu
5251 (Expression
5252 (Next (Next
5253 (First (gnat_assoc)))))));
5256 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5258 case Pragma_Machine_Attribute:
5259 etype = ATTR_MACHINE_ATTRIBUTE;
5260 break;
5262 case Pragma_Linker_Alias:
5263 etype = ATTR_LINK_ALIAS;
5264 break;
5266 case Pragma_Linker_Section:
5267 etype = ATTR_LINK_SECTION;
5268 break;
5270 case Pragma_Linker_Constructor:
5271 etype = ATTR_LINK_CONSTRUCTOR;
5272 break;
5274 case Pragma_Linker_Destructor:
5275 etype = ATTR_LINK_DESTRUCTOR;
5276 break;
5278 case Pragma_Weak_External:
5279 etype = ATTR_WEAK_EXTERNAL;
5280 break;
5282 default:
5283 continue;
5287 /* Prepend to the list now. Make a list of the argument we might
5288 have, as GCC expects it. */
5289 prepend_one_attribute_to
5290 (attr_list,
5291 etype, gnu_arg0,
5292 (gnu_arg1 != NULL_TREE)
5293 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5294 Present (Next (First (gnat_assoc)))
5295 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5299 /* Get the unpadded version of a GNAT type. */
5301 tree
5302 get_unpadded_type (Entity_Id gnat_entity)
5304 tree type = gnat_to_gnu_type (gnat_entity);
5306 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5307 type = TREE_TYPE (TYPE_FIELDS (type));
5309 return type;
5312 /* Called when we need to protect a variable object using a save_expr. */
5314 tree
5315 maybe_variable (tree gnu_operand)
5317 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
5318 || TREE_CODE (gnu_operand) == SAVE_EXPR
5319 || TREE_CODE (gnu_operand) == NULL_EXPR)
5320 return gnu_operand;
5322 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5324 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
5325 TREE_TYPE (gnu_operand),
5326 variable_size (TREE_OPERAND (gnu_operand, 0)));
5328 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5329 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5330 return gnu_result;
5332 else
5333 return variable_size (gnu_operand);
5336 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5337 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5338 return the GCC tree to use for that expression. GNU_NAME is the
5339 qualification to use if an external name is appropriate and DEFINITION is
5340 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
5341 we need a result. Otherwise, we are just elaborating this for
5342 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
5343 purposes even if it isn't needed for code generation. */
5345 static tree
5346 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
5347 tree gnu_name, bool definition, bool need_value,
5348 bool need_debug)
5350 tree gnu_expr;
5352 /* If we already elaborated this expression (e.g., it was involved
5353 in the definition of a private type), use the old value. */
5354 if (present_gnu_tree (gnat_expr))
5355 return get_gnu_tree (gnat_expr);
5357 /* If we don't need a value and this is static or a discriminant, we
5358 don't need to do anything. */
5359 else if (!need_value
5360 && (Is_OK_Static_Expression (gnat_expr)
5361 || (Nkind (gnat_expr) == N_Identifier
5362 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5363 return 0;
5365 /* Otherwise, convert this tree to its GCC equivalent. */
5366 gnu_expr
5367 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5368 gnu_name, definition, need_debug);
5370 /* Save the expression in case we try to elaborate this entity again. Since
5371 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5372 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5373 save_gnu_tree (gnat_expr, gnu_expr, true);
5375 return need_value ? gnu_expr : error_mark_node;
5378 /* Similar, but take a GNU expression. */
5380 static tree
5381 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5382 tree gnu_expr, tree gnu_name, bool definition,
5383 bool need_debug)
5385 tree gnu_decl = NULL_TREE;
5386 /* Skip any conversions and simple arithmetics to see if the expression
5387 is a read-only variable.
5388 ??? This really should remain read-only, but we have to think about
5389 the typing of the tree here. */
5390 tree gnu_inner_expr
5391 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5392 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5393 bool expr_variable;
5395 /* In most cases, we won't see a naked FIELD_DECL here because a
5396 discriminant reference will have been replaced with a COMPONENT_REF
5397 when the type is being elaborated. However, there are some cases
5398 involving child types where we will. So convert it to a COMPONENT_REF
5399 here. We have to hope it will be at the highest level of the
5400 expression in these cases. */
5401 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5402 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5403 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5404 gnu_expr, NULL_TREE);
5406 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5407 that is read-only, make a variable that is initialized to contain the
5408 bound when the package containing the definition is elaborated. If
5409 this entity is defined at top level and a bound or discriminant value
5410 isn't a constant or a reference to a discriminant, replace the bound
5411 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5412 rely here on the fact that an expression cannot contain both the
5413 discriminant and some other variable. */
5415 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5416 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5417 && (TREE_READONLY (gnu_inner_expr)
5418 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5419 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5421 /* If this is a static expression or contains a discriminant, we don't
5422 need the variable for debugging (and can't elaborate anyway if a
5423 discriminant). */
5424 if (need_debug
5425 && (Is_OK_Static_Expression (gnat_expr)
5426 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5427 need_debug = false;
5429 /* Now create the variable if we need it. */
5430 if (need_debug || (expr_variable && expr_global))
5431 gnu_decl
5432 = create_var_decl (create_concat_name (gnat_entity,
5433 IDENTIFIER_POINTER (gnu_name)),
5434 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5435 !need_debug, Is_Public (gnat_entity),
5436 !definition, false, NULL, gnat_entity);
5438 /* We only need to use this variable if we are in global context since GCC
5439 can do the right thing in the local case. */
5440 if (expr_global && expr_variable)
5441 return gnu_decl;
5442 else if (!expr_variable)
5443 return gnu_expr;
5444 else
5445 return maybe_variable (gnu_expr);
5448 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5449 starting bit position so that it is aligned to ALIGN bits, and leaving at
5450 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5451 record is guaranteed to get. */
5453 tree
5454 make_aligning_type (tree type, unsigned int align, tree size,
5455 unsigned int base_align, int room)
5457 /* We will be crafting a record type with one field at a position set to be
5458 the next multiple of ALIGN past record'address + room bytes. We use a
5459 record placeholder to express record'address. */
5461 tree record_type = make_node (RECORD_TYPE);
5462 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5464 tree record_addr_st
5465 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5467 /* The diagram below summarizes the shape of what we manipulate:
5469 <--------- pos ---------->
5470 { +------------+-------------+-----------------+
5471 record =>{ |############| ... | field (type) |
5472 { +------------+-------------+-----------------+
5473 |<-- room -->|<- voffset ->|<---- size ----->|
5476 record_addr vblock_addr
5478 Every length is in sizetype bytes there, except "pos" which has to be
5479 set as a bit position in the GCC tree for the record. */
5481 tree room_st = size_int (room);
5482 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5483 tree voffset_st, pos, field;
5485 tree name = TYPE_NAME (type);
5487 if (TREE_CODE (name) == TYPE_DECL)
5488 name = DECL_NAME (name);
5490 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
5492 /* Compute VOFFSET and then POS. The next byte position multiple of some
5493 alignment after some address is obtained by "and"ing the alignment minus
5494 1 with the two's complement of the address. */
5496 voffset_st = size_binop (BIT_AND_EXPR,
5497 size_diffop (size_zero_node, vblock_addr_st),
5498 ssize_int ((align / BITS_PER_UNIT) - 1));
5500 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5502 pos = size_binop (MULT_EXPR,
5503 convert (bitsizetype,
5504 size_binop (PLUS_EXPR, room_st, voffset_st)),
5505 bitsize_unit_node);
5507 /* Craft the GCC record representation. We exceptionally do everything
5508 manually here because 1) our generic circuitry is not quite ready to
5509 handle the complex position/size expressions we are setting up, 2) we
5510 have a strong simplifying factor at hand: we know the maximum possible
5511 value of voffset, and 3) we have to set/reset at least the sizes in
5512 accordance with this maximum value anyway, as we need them to convey
5513 what should be "alloc"ated for this type.
5515 Use -1 as the 'addressable' indication for the field to prevent the
5516 creation of a bitfield. We don't need one, it would have damaging
5517 consequences on the alignment computation, and create_field_decl would
5518 make one without this special argument, for instance because of the
5519 complex position expression. */
5521 field = create_field_decl (get_identifier ("F"), type, record_type,
5522 1, size, pos, -1);
5523 TYPE_FIELDS (record_type) = field;
5525 TYPE_ALIGN (record_type) = base_align;
5526 TYPE_USER_ALIGN (record_type) = 1;
5528 TYPE_SIZE (record_type)
5529 = size_binop (PLUS_EXPR,
5530 size_binop (MULT_EXPR, convert (bitsizetype, size),
5531 bitsize_unit_node),
5532 bitsize_int (align + room * BITS_PER_UNIT));
5533 TYPE_SIZE_UNIT (record_type)
5534 = size_binop (PLUS_EXPR, size,
5535 size_int (room + align / BITS_PER_UNIT));
5537 TYPE_MODE (record_type) = BLKmode;
5539 copy_alias_set (record_type, type);
5540 return record_type;
5543 /* Return the result of rounding T up to ALIGN. */
5545 static inline unsigned HOST_WIDE_INT
5546 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5548 t += align - 1;
5549 t /= align;
5550 t *= align;
5551 return t;
5554 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5555 as the field type of a packed record if IN_RECORD is true, or as the
5556 component type of a packed array if IN_RECORD is false. See if we can
5557 rewrite it either as a type that has a non-BLKmode, which we can pack
5558 tighter in the packed record case, or as a smaller type with BLKmode.
5559 If so, return the new type. If not, return the original type. */
5561 static tree
5562 make_packable_type (tree type, bool in_record)
5564 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5565 unsigned HOST_WIDE_INT new_size;
5566 tree new_type, old_field, field_list = NULL_TREE;
5568 /* No point in doing anything if the size is zero. */
5569 if (size == 0)
5570 return type;
5572 new_type = make_node (TREE_CODE (type));
5574 /* Copy the name and flags from the old type to that of the new.
5575 Note that we rely on the pointer equality created here for
5576 TYPE_NAME to look through conversions in various places. */
5577 TYPE_NAME (new_type) = TYPE_NAME (type);
5578 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5579 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5580 if (TREE_CODE (type) == RECORD_TYPE)
5581 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5583 /* If we are in a record and have a small size, set the alignment to
5584 try for an integral mode. Otherwise set it to try for a smaller
5585 type with BLKmode. */
5586 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5588 TYPE_ALIGN (new_type) = ceil_alignment (size);
5589 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5591 else
5593 unsigned HOST_WIDE_INT align;
5595 /* Do not try to shrink the size if the RM size is not constant. */
5596 if (TYPE_CONTAINS_TEMPLATE_P (type)
5597 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5598 return type;
5600 /* Round the RM size up to a unit boundary to get the minimal size
5601 for a BLKmode record. Give up if it's already the size. */
5602 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5603 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5604 if (new_size == size)
5605 return type;
5607 align = new_size & -new_size;
5608 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5611 TYPE_USER_ALIGN (new_type) = 1;
5613 /* Now copy the fields, keeping the position and size as we don't want
5614 to change the layout by propagating the packedness downwards. */
5615 for (old_field = TYPE_FIELDS (type); old_field;
5616 old_field = TREE_CHAIN (old_field))
5618 tree new_field_type = TREE_TYPE (old_field);
5619 tree new_field, new_size;
5621 if (TYPE_MODE (new_field_type) == BLKmode
5622 && (TREE_CODE (new_field_type) == RECORD_TYPE
5623 || TREE_CODE (new_field_type) == UNION_TYPE
5624 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5625 && host_integerp (TYPE_SIZE (new_field_type), 1))
5626 new_field_type = make_packable_type (new_field_type, true);
5628 /* However, for the last field in a not already packed record type
5629 that is of an aggregate type, we need to use the RM_Size in the
5630 packable version of the record type, see finish_record_type. */
5631 if (!TREE_CHAIN (old_field)
5632 && !TYPE_PACKED (type)
5633 && (TREE_CODE (new_field_type) == RECORD_TYPE
5634 || TREE_CODE (new_field_type) == UNION_TYPE
5635 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5636 && !TYPE_IS_FAT_POINTER_P (new_field_type)
5637 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5638 && TYPE_ADA_SIZE (new_field_type))
5639 new_size = TYPE_ADA_SIZE (new_field_type);
5640 else
5641 new_size = DECL_SIZE (old_field);
5643 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5644 new_type, TYPE_PACKED (type), new_size,
5645 bit_position (old_field),
5646 !DECL_NONADDRESSABLE_P (old_field));
5648 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5649 SET_DECL_ORIGINAL_FIELD
5650 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5651 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5653 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5654 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5656 TREE_CHAIN (new_field) = field_list;
5657 field_list = new_field;
5660 finish_record_type (new_type, nreverse (field_list), 2, true);
5661 copy_alias_set (new_type, type);
5663 /* If this is a padding record, we never want to make the size smaller
5664 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5665 if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5666 || TREE_CODE (type) == QUAL_UNION_TYPE)
5668 TYPE_SIZE (new_type) = TYPE_SIZE (type);
5669 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5671 else
5673 TYPE_SIZE (new_type) = bitsize_int (new_size);
5674 TYPE_SIZE_UNIT (new_type)
5675 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
5678 if (!TYPE_CONTAINS_TEMPLATE_P (type))
5679 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
5681 compute_record_mode (new_type);
5683 /* Try harder to get a packable type if necessary, for example
5684 in case the record itself contains a BLKmode field. */
5685 if (in_record && TYPE_MODE (new_type) == BLKmode)
5686 TYPE_MODE (new_type)
5687 = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
5689 /* If neither the mode nor the size has shrunk, return the old type. */
5690 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
5691 return type;
5693 return new_type;
5696 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5697 if needed. We have already verified that SIZE and TYPE are large enough.
5699 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5700 to issue a warning.
5702 IS_USER_TYPE is true if we must complete the original type.
5704 DEFINITION is true if this type is being defined.
5706 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
5707 to SIZE too; otherwise, it's set to the RM_Size of the original type. */
5709 tree
5710 maybe_pad_type (tree type, tree size, unsigned int align,
5711 Entity_Id gnat_entity, const char *name_trailer,
5712 bool is_user_type, bool definition, bool same_rm_size)
5714 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
5715 tree orig_size = TYPE_SIZE (type);
5716 unsigned int orig_align = align;
5717 tree record, field;
5719 /* If TYPE is a padded type, see if it agrees with any size and alignment
5720 we were given. If so, return the original type. Otherwise, strip
5721 off the padding, since we will either be returning the inner type
5722 or repadding it. If no size or alignment is specified, use that of
5723 the original padded type. */
5724 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5726 if ((!size
5727 || operand_equal_p (round_up (size,
5728 MAX (align, TYPE_ALIGN (type))),
5729 round_up (TYPE_SIZE (type),
5730 MAX (align, TYPE_ALIGN (type))),
5732 && (align == 0 || align == TYPE_ALIGN (type)))
5733 return type;
5735 if (!size)
5736 size = TYPE_SIZE (type);
5737 if (align == 0)
5738 align = TYPE_ALIGN (type);
5740 type = TREE_TYPE (TYPE_FIELDS (type));
5741 orig_size = TYPE_SIZE (type);
5744 /* If the size is either not being changed or is being made smaller (which
5745 is not done here (and is only valid for bitfields anyway), show the size
5746 isn't changing. Likewise, clear the alignment if it isn't being
5747 changed. Then return if we aren't doing anything. */
5748 if (size
5749 && (operand_equal_p (size, orig_size, 0)
5750 || (TREE_CODE (orig_size) == INTEGER_CST
5751 && tree_int_cst_lt (size, orig_size))))
5752 size = NULL_TREE;
5754 if (align == TYPE_ALIGN (type))
5755 align = 0;
5757 if (align == 0 && !size)
5758 return type;
5760 /* If requested, complete the original type and give it a name. */
5761 if (is_user_type)
5762 create_type_decl (get_entity_name (gnat_entity), type,
5763 NULL, !Comes_From_Source (gnat_entity),
5764 !(TYPE_NAME (type)
5765 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5766 && DECL_IGNORED_P (TYPE_NAME (type))),
5767 gnat_entity);
5769 /* We used to modify the record in place in some cases, but that could
5770 generate incorrect debugging information. So make a new record
5771 type and name. */
5772 record = make_node (RECORD_TYPE);
5773 TYPE_IS_PADDING_P (record) = 1;
5775 if (Present (gnat_entity))
5776 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5778 TYPE_VOLATILE (record)
5779 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5781 TYPE_ALIGN (record) = align;
5782 if (orig_align)
5783 TYPE_USER_ALIGN (record) = align;
5785 TYPE_SIZE (record) = size ? size : orig_size;
5786 TYPE_SIZE_UNIT (record)
5787 = convert (sizetype,
5788 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
5789 bitsize_unit_node));
5791 /* If we are changing the alignment and the input type is a record with
5792 BLKmode and a small constant size, try to make a form that has an
5793 integral mode. This might allow the padding record to also have an
5794 integral mode, which will be much more efficient. There is no point
5795 in doing so if a size is specified unless it is also a small constant
5796 size and it is incorrect to do so if we cannot guarantee that the mode
5797 will be naturally aligned since the field must always be addressable.
5799 ??? This might not always be a win when done for a stand-alone object:
5800 since the nominal and the effective type of the object will now have
5801 different modes, a VIEW_CONVERT_EXPR will be required for converting
5802 between them and it might be hard to overcome afterwards, including
5803 at the RTL level when the stand-alone object is accessed as a whole. */
5804 if (align != 0
5805 && TREE_CODE (type) == RECORD_TYPE
5806 && TYPE_MODE (type) == BLKmode
5807 && TREE_CODE (orig_size) == INTEGER_CST
5808 && !TREE_CONSTANT_OVERFLOW (orig_size)
5809 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
5810 && (!size
5811 || (TREE_CODE (size) == INTEGER_CST
5812 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
5814 tree packable_type = make_packable_type (type, true);
5815 if (TYPE_MODE (packable_type) != BLKmode
5816 && align >= TYPE_ALIGN (packable_type))
5817 type = packable_type;
5820 /* Now create the field with the original size. */
5821 field = create_field_decl (get_identifier ("F"), type, record, 0,
5822 orig_size, bitsize_zero_node, 1);
5823 DECL_INTERNAL_P (field) = 1;
5825 /* Do not finalize it until after the auxiliary record is built. */
5826 finish_record_type (record, field, 1, true);
5828 /* Set the same size for its RM_size if requested; otherwise reuse
5829 the RM_size of the original type. */
5830 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
5832 /* Unless debugging information isn't being written for the input type,
5833 write a record that shows what we are a subtype of and also make a
5834 variable that indicates our size, if still variable. */
5835 if (TYPE_NAME (record)
5836 && AGGREGATE_TYPE_P (type)
5837 && TREE_CODE (orig_size) != INTEGER_CST
5838 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5839 && DECL_IGNORED_P (TYPE_NAME (type))))
5841 tree marker = make_node (RECORD_TYPE);
5842 tree name = TYPE_NAME (record);
5843 tree orig_name = TYPE_NAME (type);
5845 if (TREE_CODE (name) == TYPE_DECL)
5846 name = DECL_NAME (name);
5848 if (TREE_CODE (orig_name) == TYPE_DECL)
5849 orig_name = DECL_NAME (orig_name);
5851 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5852 finish_record_type (marker,
5853 create_field_decl (orig_name, integer_type_node,
5854 marker, 0, NULL_TREE, NULL_TREE,
5856 0, false);
5858 add_parallel_type (TYPE_STUB_DECL (record), marker);
5860 if (size && TREE_CODE (size) != INTEGER_CST && definition)
5861 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5862 bitsizetype, TYPE_SIZE (record), false, false, false,
5863 false, NULL, gnat_entity);
5866 rest_of_record_type_compilation (record);
5868 /* If the size was widened explicitly, maybe give a warning. Take the
5869 original size as the maximum size of the input if there was an
5870 unconstrained record involved and round it up to the specified alignment,
5871 if one was specified. */
5872 if (CONTAINS_PLACEHOLDER_P (orig_size))
5873 orig_size = max_size (orig_size, true);
5875 if (align)
5876 orig_size = round_up (orig_size, align);
5878 if (size && Present (gnat_entity)
5879 && !operand_equal_p (size, orig_size, 0)
5880 && !(TREE_CODE (size) == INTEGER_CST
5881 && TREE_CODE (orig_size) == INTEGER_CST
5882 && tree_int_cst_lt (size, orig_size)))
5884 Node_Id gnat_error_node = Empty;
5886 if (Is_Packed_Array_Type (gnat_entity))
5887 gnat_entity = Original_Array_Type (gnat_entity);
5889 if ((Ekind (gnat_entity) == E_Component
5890 || Ekind (gnat_entity) == E_Discriminant)
5891 && Present (Component_Clause (gnat_entity)))
5892 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5893 else if (Present (Size_Clause (gnat_entity)))
5894 gnat_error_node = Expression (Size_Clause (gnat_entity));
5896 /* Generate message only for entities that come from source, since
5897 if we have an entity created by expansion, the message will be
5898 generated for some other corresponding source entity. */
5899 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5900 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5901 gnat_entity,
5902 size_diffop (size, orig_size));
5904 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5905 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5906 gnat_entity, gnat_entity,
5907 size_diffop (size, orig_size));
5910 return record;
5913 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5914 the value passed against the list of choices. */
5916 tree
5917 choices_to_gnu (tree operand, Node_Id choices)
5919 Node_Id choice;
5920 Node_Id gnat_temp;
5921 tree result = integer_zero_node;
5922 tree this_test, low = 0, high = 0, single = 0;
5924 for (choice = First (choices); Present (choice); choice = Next (choice))
5926 switch (Nkind (choice))
5928 case N_Range:
5929 low = gnat_to_gnu (Low_Bound (choice));
5930 high = gnat_to_gnu (High_Bound (choice));
5932 /* There's no good type to use here, so we might as well use
5933 integer_type_node. */
5934 this_test
5935 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5936 build_binary_op (GE_EXPR, integer_type_node,
5937 operand, low),
5938 build_binary_op (LE_EXPR, integer_type_node,
5939 operand, high));
5941 break;
5943 case N_Subtype_Indication:
5944 gnat_temp = Range_Expression (Constraint (choice));
5945 low = gnat_to_gnu (Low_Bound (gnat_temp));
5946 high = gnat_to_gnu (High_Bound (gnat_temp));
5948 this_test
5949 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5950 build_binary_op (GE_EXPR, integer_type_node,
5951 operand, low),
5952 build_binary_op (LE_EXPR, integer_type_node,
5953 operand, high));
5954 break;
5956 case N_Identifier:
5957 case N_Expanded_Name:
5958 /* This represents either a subtype range, an enumeration
5959 literal, or a constant Ekind says which. If an enumeration
5960 literal or constant, fall through to the next case. */
5961 if (Ekind (Entity (choice)) != E_Enumeration_Literal
5962 && Ekind (Entity (choice)) != E_Constant)
5964 tree type = gnat_to_gnu_type (Entity (choice));
5966 low = TYPE_MIN_VALUE (type);
5967 high = TYPE_MAX_VALUE (type);
5969 this_test
5970 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5971 build_binary_op (GE_EXPR, integer_type_node,
5972 operand, low),
5973 build_binary_op (LE_EXPR, integer_type_node,
5974 operand, high));
5975 break;
5977 /* ... fall through ... */
5978 case N_Character_Literal:
5979 case N_Integer_Literal:
5980 single = gnat_to_gnu (choice);
5981 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5982 single);
5983 break;
5985 case N_Others_Choice:
5986 this_test = integer_one_node;
5987 break;
5989 default:
5990 gcc_unreachable ();
5993 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5994 result, this_test);
5997 return result;
6000 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6001 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6003 static int
6004 adjust_packed (tree field_type, tree record_type, int packed)
6006 /* If the field contains an item of variable size, we cannot pack it
6007 because we cannot create temporaries of non-fixed size in case
6008 we need to take the address of the field. See addressable_p and
6009 the notes on the addressability issues for further details. */
6010 if (is_variable_size (field_type))
6011 return 0;
6013 /* If the alignment of the record is specified and the field type
6014 is over-aligned, request Storage_Unit alignment for the field. */
6015 if (packed == -2)
6017 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6018 return -1;
6019 else
6020 return 0;
6023 return packed;
6026 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6027 placed in GNU_RECORD_TYPE.
6029 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6030 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6031 record has a specified alignment.
6033 DEFINITION is true if this field is for a record being defined. */
6035 static tree
6036 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6037 bool definition)
6039 tree gnu_field_id = get_entity_name (gnat_field);
6040 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6041 tree gnu_field, gnu_size, gnu_pos;
6042 bool needs_strict_alignment
6043 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6044 || Treat_As_Volatile (gnat_field));
6046 /* If this field requires strict alignment, we cannot pack it because
6047 it would very likely be under-aligned in the record. */
6048 if (needs_strict_alignment)
6049 packed = 0;
6050 else
6051 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6053 /* If a size is specified, use it. Otherwise, if the record type is packed,
6054 use the official RM size. See "Handling of Type'Size Values" in Einfo
6055 for further details. */
6056 if (Known_Static_Esize (gnat_field))
6057 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6058 gnat_field, FIELD_DECL, false, true);
6059 else if (packed == 1)
6060 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6061 gnat_field, FIELD_DECL, false, true);
6062 else
6063 gnu_size = NULL_TREE;
6065 /* If we have a specified size that's smaller than that of the field type,
6066 or a position is specified, and the field type is also a record that's
6067 BLKmode, see if we can get either an integral mode form of the type or
6068 a smaller BLKmode form. If we can, show a size was specified for the
6069 field if there wasn't one already, so we know to make this a bitfield
6070 and avoid making things wider.
6072 Doing this is first useful if the record is packed because we may then
6073 place the field at a non-byte-aligned position and so achieve tighter
6074 packing.
6076 This is in addition *required* if the field shares a byte with another
6077 field and the front-end lets the back-end handle the references, because
6078 GCC does not handle BLKmode bitfields properly.
6080 We avoid the transformation if it is not required or potentially useful,
6081 as it might entail an increase of the field's alignment and have ripple
6082 effects on the outer record type. A typical case is a field known to be
6083 byte aligned and not to share a byte with another field.
6085 Besides, we don't even look the possibility of a transformation in cases
6086 known to be in error already, for instance when an invalid size results
6087 from a component clause. */
6089 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6090 && TYPE_MODE (gnu_field_type) == BLKmode
6091 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6092 && (packed == 1
6093 || (gnu_size
6094 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6095 || Present (Component_Clause (gnat_field))))))
6097 /* See what the alternate type and size would be. */
6098 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6100 bool has_byte_aligned_clause
6101 = Present (Component_Clause (gnat_field))
6102 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6103 % BITS_PER_UNIT == 0);
6105 /* Compute whether we should avoid the substitution. */
6106 bool reject
6107 /* There is no point substituting if there is no change... */
6108 = (gnu_packable_type == gnu_field_type)
6109 /* ... nor when the field is known to be byte aligned and not to
6110 share a byte with another field. */
6111 || (has_byte_aligned_clause
6112 && value_factor_p (gnu_size, BITS_PER_UNIT))
6113 /* The size of an aliased field must be an exact multiple of the
6114 type's alignment, which the substitution might increase. Reject
6115 substitutions that would so invalidate a component clause when the
6116 specified position is byte aligned, as the change would have no
6117 real benefit from the packing standpoint anyway. */
6118 || (Is_Aliased (gnat_field)
6119 && has_byte_aligned_clause
6120 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6122 /* Substitute unless told otherwise. */
6123 if (!reject)
6125 gnu_field_type = gnu_packable_type;
6127 if (!gnu_size)
6128 gnu_size = rm_size (gnu_field_type);
6132 /* If we are packing the record and the field is BLKmode, round the
6133 size up to a byte boundary. */
6134 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6135 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6137 if (Present (Component_Clause (gnat_field)))
6139 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6140 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6141 gnat_field, FIELD_DECL, false, true);
6143 /* Ensure the position does not overlap with the parent subtype,
6144 if there is one. */
6145 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
6147 tree gnu_parent
6148 = gnat_to_gnu_type (Parent_Subtype
6149 (Underlying_Type (Scope (gnat_field))));
6151 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6152 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6154 post_error_ne_tree
6155 ("offset of& must be beyond parent{, minimum allowed is ^}",
6156 First_Bit (Component_Clause (gnat_field)), gnat_field,
6157 TYPE_SIZE_UNIT (gnu_parent));
6161 /* If this field needs strict alignment, ensure the record is
6162 sufficiently aligned and that that position and size are
6163 consistent with the alignment. */
6164 if (needs_strict_alignment)
6166 TYPE_ALIGN (gnu_record_type)
6167 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6169 if (gnu_size
6170 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6172 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6173 post_error_ne_tree
6174 ("atomic field& must be natural size of type{ (^)}",
6175 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6176 TYPE_SIZE (gnu_field_type));
6178 else if (Is_Aliased (gnat_field))
6179 post_error_ne_tree
6180 ("size of aliased field& must be ^ bits",
6181 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6182 TYPE_SIZE (gnu_field_type));
6184 else if (Strict_Alignment (Etype (gnat_field)))
6185 post_error_ne_tree
6186 ("size of & with aliased or tagged components not ^ bits",
6187 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6188 TYPE_SIZE (gnu_field_type));
6190 gnu_size = NULL_TREE;
6193 if (!integer_zerop (size_binop
6194 (TRUNC_MOD_EXPR, gnu_pos,
6195 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6197 if (Is_Aliased (gnat_field))
6198 post_error_ne_num
6199 ("position of aliased field& must be multiple of ^ bits",
6200 First_Bit (Component_Clause (gnat_field)), gnat_field,
6201 TYPE_ALIGN (gnu_field_type));
6203 else if (Treat_As_Volatile (gnat_field))
6204 post_error_ne_num
6205 ("position of volatile field& must be multiple of ^ bits",
6206 First_Bit (Component_Clause (gnat_field)), gnat_field,
6207 TYPE_ALIGN (gnu_field_type));
6209 else if (Strict_Alignment (Etype (gnat_field)))
6210 post_error_ne_num
6211 ("position of & with aliased or tagged components not multiple of ^ bits",
6212 First_Bit (Component_Clause (gnat_field)), gnat_field,
6213 TYPE_ALIGN (gnu_field_type));
6215 else
6216 gcc_unreachable ();
6218 gnu_pos = NULL_TREE;
6222 if (Is_Atomic (gnat_field))
6223 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6226 /* If the record has rep clauses and this is the tag field, make a rep
6227 clause for it as well. */
6228 else if (Has_Specified_Layout (Scope (gnat_field))
6229 && Chars (gnat_field) == Name_uTag)
6231 gnu_pos = bitsize_zero_node;
6232 gnu_size = TYPE_SIZE (gnu_field_type);
6235 else
6236 gnu_pos = NULL_TREE;
6238 /* We need to make the size the maximum for the type if it is
6239 self-referential and an unconstrained type. In that case, we can't
6240 pack the field since we can't make a copy to align it. */
6241 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6242 && !gnu_size
6243 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6244 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6246 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6247 packed = 0;
6250 /* If a size is specified, adjust the field's type to it. */
6251 if (gnu_size)
6253 /* If the field's type is justified modular, we would need to remove
6254 the wrapper to (better) meet the layout requirements. However we
6255 can do so only if the field is not aliased to preserve the unique
6256 layout and if the prescribed size is not greater than that of the
6257 packed array to preserve the justification. */
6258 if (!needs_strict_alignment
6259 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6260 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6261 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6262 <= 0)
6263 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6265 gnu_field_type
6266 = make_type_from_size (gnu_field_type, gnu_size,
6267 Has_Biased_Representation (gnat_field));
6268 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6269 "PAD", false, definition, true);
6272 /* Otherwise (or if there was an error), don't specify a position. */
6273 else
6274 gnu_pos = NULL_TREE;
6276 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6277 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6279 /* Now create the decl for the field. */
6280 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6281 packed, gnu_size, gnu_pos,
6282 Is_Aliased (gnat_field));
6283 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6284 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6286 if (Ekind (gnat_field) == E_Discriminant)
6287 DECL_DISCRIMINANT_NUMBER (gnu_field)
6288 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6290 return gnu_field;
6293 /* Return true if TYPE is a type with variable size, a padding type with a
6294 field of variable size or is a record that has a field such a field. */
6296 static bool
6297 is_variable_size (tree type)
6299 tree field;
6301 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6302 return true;
6304 if (TREE_CODE (type) == RECORD_TYPE
6305 && TYPE_IS_PADDING_P (type)
6306 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6307 return true;
6309 if (TREE_CODE (type) != RECORD_TYPE
6310 && TREE_CODE (type) != UNION_TYPE
6311 && TREE_CODE (type) != QUAL_UNION_TYPE)
6312 return false;
6314 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6315 if (is_variable_size (TREE_TYPE (field)))
6316 return true;
6318 return false;
6321 /* qsort comparer for the bit positions of two record components. */
6323 static int
6324 compare_field_bitpos (const PTR rt1, const PTR rt2)
6326 const_tree const field1 = * (const_tree const *) rt1;
6327 const_tree const field2 = * (const_tree const *) rt2;
6328 const int ret
6329 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6331 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6334 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6335 of GCC trees for fields that are in the record and have already been
6336 processed. When called from gnat_to_gnu_entity during the processing of a
6337 record type definition, the GCC nodes for the discriminants will be on
6338 the chain. The other calls to this function are recursive calls from
6339 itself for the Component_List of a variant and the chain is empty.
6341 PACKED is 1 if this is for a packed record, -1 if this is for a record
6342 with Component_Alignment of Storage_Unit, -2 if this is for a record
6343 with a specified alignment.
6345 DEFINITION is true if we are defining this record.
6347 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6348 with a rep clause is to be added. If it is nonzero, that is all that
6349 should be done with such fields.
6351 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6352 laying out the record. This means the alignment only serves to force fields
6353 to be bitfields, but not require the record to be that aligned. This is
6354 used for variants.
6356 ALL_REP, if true, means a rep clause was found for all the fields. This
6357 simplifies the logic since we know we're not in the mixed case.
6359 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6360 modified afterwards so it will not be sent to the back-end for finalization.
6362 UNCHECKED_UNION, if true, means that we are building a type for a record
6363 with a Pragma Unchecked_Union.
6365 The processing of the component list fills in the chain with all of the
6366 fields of the record and then the record type is finished. */
6368 static void
6369 components_to_record (tree gnu_record_type, Node_Id component_list,
6370 tree gnu_field_list, int packed, bool definition,
6371 tree *p_gnu_rep_list, bool cancel_alignment,
6372 bool all_rep, bool do_not_finalize, bool unchecked_union)
6374 Node_Id component_decl;
6375 Entity_Id gnat_field;
6376 Node_Id variant_part;
6377 tree gnu_our_rep_list = NULL_TREE;
6378 tree gnu_field, gnu_last;
6379 bool layout_with_rep = false;
6380 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6382 /* For each variable within each component declaration create a GCC field
6383 and add it to the list, skipping any pragmas in the list. */
6384 if (Present (Component_Items (component_list)))
6385 for (component_decl = First_Non_Pragma (Component_Items (component_list));
6386 Present (component_decl);
6387 component_decl = Next_Non_Pragma (component_decl))
6389 gnat_field = Defining_Entity (component_decl);
6391 if (Chars (gnat_field) == Name_uParent)
6392 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
6393 else
6395 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
6396 packed, definition);
6398 /* If this is the _Tag field, put it before any discriminants,
6399 instead of after them as is the case for all other fields.
6400 Ignore field of void type if only annotating. */
6401 if (Chars (gnat_field) == Name_uTag)
6402 gnu_field_list = chainon (gnu_field_list, gnu_field);
6403 else
6405 TREE_CHAIN (gnu_field) = gnu_field_list;
6406 gnu_field_list = gnu_field;
6410 save_gnu_tree (gnat_field, gnu_field, false);
6413 /* At the end of the component list there may be a variant part. */
6414 variant_part = Variant_Part (component_list);
6416 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6417 mutually exclusive and should go in the same memory. To do this we need
6418 to treat each variant as a record whose elements are created from the
6419 component list for the variant. So here we create the records from the
6420 lists for the variants and put them all into the QUAL_UNION_TYPE.
6421 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6422 use GNU_RECORD_TYPE if there are no fields so far. */
6423 if (Present (variant_part))
6425 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
6426 Node_Id variant;
6427 tree gnu_name = TYPE_NAME (gnu_record_type);
6428 tree gnu_var_name
6429 = concat_id_with_name (get_identifier (Get_Name_String
6430 (Chars (Name (variant_part)))),
6431 "XVN");
6432 tree gnu_union_type;
6433 tree gnu_union_name;
6434 tree gnu_union_field;
6435 tree gnu_variant_list = NULL_TREE;
6437 if (TREE_CODE (gnu_name) == TYPE_DECL)
6438 gnu_name = DECL_NAME (gnu_name);
6440 gnu_union_name = concat_id_with_name (gnu_name,
6441 IDENTIFIER_POINTER (gnu_var_name));
6443 /* Reuse an enclosing union if all fields are in the variant part
6444 and there is no representation clause on the record, to match
6445 the layout of C unions. There is an associated check below. */
6446 if (!gnu_field_list
6447 && TREE_CODE (gnu_record_type) == UNION_TYPE
6448 && !TYPE_PACKED (gnu_record_type))
6449 gnu_union_type = gnu_record_type;
6450 else
6452 gnu_union_type
6453 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6455 TYPE_NAME (gnu_union_type) = gnu_union_name;
6456 TYPE_ALIGN (gnu_union_type) = 0;
6457 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6460 for (variant = First_Non_Pragma (Variants (variant_part));
6461 Present (variant);
6462 variant = Next_Non_Pragma (variant))
6464 tree gnu_variant_type = make_node (RECORD_TYPE);
6465 tree gnu_inner_name;
6466 tree gnu_qual;
6468 Get_Variant_Encoding (variant);
6469 gnu_inner_name = get_identifier (Name_Buffer);
6470 TYPE_NAME (gnu_variant_type)
6471 = concat_id_with_name (gnu_union_name,
6472 IDENTIFIER_POINTER (gnu_inner_name));
6474 /* Set the alignment of the inner type in case we need to make
6475 inner objects into bitfields, but then clear it out
6476 so the record actually gets only the alignment required. */
6477 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6478 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6480 /* Similarly, if the outer record has a size specified and all fields
6481 have record rep clauses, we can propagate the size into the
6482 variant part. */
6483 if (all_rep_and_size)
6485 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6486 TYPE_SIZE_UNIT (gnu_variant_type)
6487 = TYPE_SIZE_UNIT (gnu_record_type);
6490 /* Create the record type for the variant. Note that we defer
6491 finalizing it until after we are sure to actually use it. */
6492 components_to_record (gnu_variant_type, Component_List (variant),
6493 NULL_TREE, packed, definition,
6494 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6495 true, unchecked_union);
6497 gnu_qual = choices_to_gnu (gnu_discriminant,
6498 Discrete_Choices (variant));
6500 Set_Present_Expr (variant, annotate_value (gnu_qual));
6502 /* If this is an Unchecked_Union and we have exactly one field,
6503 use this field directly to match the layout of C unions. */
6504 if (unchecked_union
6505 && TYPE_FIELDS (gnu_variant_type)
6506 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6507 gnu_field = TYPE_FIELDS (gnu_variant_type);
6508 else
6510 /* Deal with packedness like in gnat_to_gnu_field. */
6511 int field_packed
6512 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6514 /* Finalize the record type now. We used to throw away
6515 empty records but we no longer do that because we need
6516 them to generate complete debug info for the variant;
6517 otherwise, the union type definition will be lacking
6518 the fields associated with these empty variants. */
6519 rest_of_record_type_compilation (gnu_variant_type);
6521 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6522 gnu_union_type, field_packed,
6523 (all_rep_and_size
6524 ? TYPE_SIZE (gnu_variant_type)
6525 : 0),
6526 (all_rep_and_size
6527 ? bitsize_zero_node : 0),
6530 DECL_INTERNAL_P (gnu_field) = 1;
6532 if (!unchecked_union)
6533 DECL_QUALIFIER (gnu_field) = gnu_qual;
6536 TREE_CHAIN (gnu_field) = gnu_variant_list;
6537 gnu_variant_list = gnu_field;
6540 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6541 if (gnu_variant_list)
6543 int union_field_packed;
6545 if (all_rep_and_size)
6547 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6548 TYPE_SIZE_UNIT (gnu_union_type)
6549 = TYPE_SIZE_UNIT (gnu_record_type);
6552 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6553 all_rep_and_size ? 1 : 0, false);
6555 /* If GNU_UNION_TYPE is our record type, it means we must have an
6556 Unchecked_Union with no fields. Verify that and, if so, just
6557 return. */
6558 if (gnu_union_type == gnu_record_type)
6560 gcc_assert (unchecked_union
6561 && !gnu_field_list
6562 && !gnu_our_rep_list);
6563 return;
6566 /* Deal with packedness like in gnat_to_gnu_field. */
6567 union_field_packed
6568 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6570 gnu_union_field
6571 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6572 union_field_packed,
6573 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6574 all_rep ? bitsize_zero_node : 0, 0);
6576 DECL_INTERNAL_P (gnu_union_field) = 1;
6577 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6578 gnu_field_list = gnu_union_field;
6582 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6583 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6584 in a separate pass since we want to handle the discriminants but can't
6585 play with them until we've used them in debugging data above.
6587 ??? Note: if we then reorder them, debugging information will be wrong,
6588 but there's nothing that can be done about this at the moment. */
6589 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6591 if (DECL_FIELD_OFFSET (gnu_field))
6593 tree gnu_next = TREE_CHAIN (gnu_field);
6595 if (!gnu_last)
6596 gnu_field_list = gnu_next;
6597 else
6598 TREE_CHAIN (gnu_last) = gnu_next;
6600 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6601 gnu_our_rep_list = gnu_field;
6602 gnu_field = gnu_next;
6604 else
6606 gnu_last = gnu_field;
6607 gnu_field = TREE_CHAIN (gnu_field);
6611 /* If we have any items in our rep'ed field list, it is not the case that all
6612 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6613 set it and ignore the items. */
6614 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6615 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6616 else if (gnu_our_rep_list)
6618 /* Otherwise, sort the fields by bit position and put them into their
6619 own record if we have any fields without rep clauses. */
6620 tree gnu_rep_type
6621 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6622 int len = list_length (gnu_our_rep_list);
6623 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6624 int i;
6626 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6627 gnu_field = TREE_CHAIN (gnu_field), i++)
6628 gnu_arr[i] = gnu_field;
6630 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6632 /* Put the fields in the list in order of increasing position, which
6633 means we start from the end. */
6634 gnu_our_rep_list = NULL_TREE;
6635 for (i = len - 1; i >= 0; i--)
6637 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6638 gnu_our_rep_list = gnu_arr[i];
6639 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6642 if (gnu_field_list)
6644 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6645 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6646 gnu_record_type, 0, 0, 0, 1);
6647 DECL_INTERNAL_P (gnu_field) = 1;
6648 gnu_field_list = chainon (gnu_field_list, gnu_field);
6650 else
6652 layout_with_rep = true;
6653 gnu_field_list = nreverse (gnu_our_rep_list);
6657 if (cancel_alignment)
6658 TYPE_ALIGN (gnu_record_type) = 0;
6660 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6661 layout_with_rep ? 1 : 0, do_not_finalize);
6664 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6665 placed into an Esize, Component_Bit_Offset, or Component_Size value
6666 in the GNAT tree. */
6668 static Uint
6669 annotate_value (tree gnu_size)
6671 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6672 TCode tcode;
6673 Node_Ref_Or_Val ops[3], ret;
6674 int i;
6675 int size;
6676 struct tree_int_map **h = NULL;
6678 /* See if we've already saved the value for this node. */
6679 if (EXPR_P (gnu_size))
6681 struct tree_int_map in;
6682 if (!annotate_value_cache)
6683 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6684 tree_int_map_eq, 0);
6685 in.base.from = gnu_size;
6686 h = (struct tree_int_map **)
6687 htab_find_slot (annotate_value_cache, &in, INSERT);
6689 if (*h)
6690 return (Node_Ref_Or_Val) (*h)->to;
6693 /* If we do not return inside this switch, TCODE will be set to the
6694 code to use for a Create_Node operand and LEN (set above) will be
6695 the number of recursive calls for us to make. */
6697 switch (TREE_CODE (gnu_size))
6699 case INTEGER_CST:
6700 if (TREE_OVERFLOW (gnu_size))
6701 return No_Uint;
6703 /* This may have come from a conversion from some smaller type,
6704 so ensure this is in bitsizetype. */
6705 gnu_size = convert (bitsizetype, gnu_size);
6707 /* For negative values, use NEGATE_EXPR of the supplied value. */
6708 if (tree_int_cst_sgn (gnu_size) < 0)
6710 /* The ridiculous code below is to handle the case of the largest
6711 negative integer. */
6712 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6713 bool adjust = false;
6714 tree temp;
6716 if (TREE_OVERFLOW (negative_size))
6718 negative_size
6719 = size_binop (MINUS_EXPR, bitsize_zero_node,
6720 size_binop (PLUS_EXPR, gnu_size,
6721 bitsize_one_node));
6722 adjust = true;
6725 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6726 if (adjust)
6727 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6729 return annotate_value (temp);
6732 if (!host_integerp (gnu_size, 1))
6733 return No_Uint;
6735 size = tree_low_cst (gnu_size, 1);
6737 /* This peculiar test is to make sure that the size fits in an int
6738 on machines where HOST_WIDE_INT is not "int". */
6739 if (tree_low_cst (gnu_size, 1) == size)
6740 return UI_From_Int (size);
6741 else
6742 return No_Uint;
6744 case COMPONENT_REF:
6745 /* The only case we handle here is a simple discriminant reference. */
6746 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6747 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6748 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6749 return Create_Node (Discrim_Val,
6750 annotate_value (DECL_DISCRIMINANT_NUMBER
6751 (TREE_OPERAND (gnu_size, 1))),
6752 No_Uint, No_Uint);
6753 else
6754 return No_Uint;
6756 CASE_CONVERT: case NON_LVALUE_EXPR:
6757 return annotate_value (TREE_OPERAND (gnu_size, 0));
6759 /* Now just list the operations we handle. */
6760 case COND_EXPR: tcode = Cond_Expr; break;
6761 case PLUS_EXPR: tcode = Plus_Expr; break;
6762 case MINUS_EXPR: tcode = Minus_Expr; break;
6763 case MULT_EXPR: tcode = Mult_Expr; break;
6764 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
6765 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
6766 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
6767 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
6768 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
6769 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
6770 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
6771 case NEGATE_EXPR: tcode = Negate_Expr; break;
6772 case MIN_EXPR: tcode = Min_Expr; break;
6773 case MAX_EXPR: tcode = Max_Expr; break;
6774 case ABS_EXPR: tcode = Abs_Expr; break;
6775 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
6776 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
6777 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
6778 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
6779 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
6780 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
6781 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
6782 case LT_EXPR: tcode = Lt_Expr; break;
6783 case LE_EXPR: tcode = Le_Expr; break;
6784 case GT_EXPR: tcode = Gt_Expr; break;
6785 case GE_EXPR: tcode = Ge_Expr; break;
6786 case EQ_EXPR: tcode = Eq_Expr; break;
6787 case NE_EXPR: tcode = Ne_Expr; break;
6789 default:
6790 return No_Uint;
6793 /* Now get each of the operands that's relevant for this code. If any
6794 cannot be expressed as a repinfo node, say we can't. */
6795 for (i = 0; i < 3; i++)
6796 ops[i] = No_Uint;
6798 for (i = 0; i < len; i++)
6800 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6801 if (ops[i] == No_Uint)
6802 return No_Uint;
6805 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6807 /* Save the result in the cache. */
6808 if (h)
6810 *h = GGC_NEW (struct tree_int_map);
6811 (*h)->base.from = gnu_size;
6812 (*h)->to = ret;
6815 return ret;
6818 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6819 GCC type, set Component_Bit_Offset and Esize to the position and size
6820 used by Gigi. */
6822 static void
6823 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6825 tree gnu_list;
6826 tree gnu_entry;
6827 Entity_Id gnat_field;
6829 /* We operate by first making a list of all fields and their positions
6830 (we can get the sizes easily at any time) by a recursive call
6831 and then update all the sizes into the tree. */
6832 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6833 size_zero_node, bitsize_zero_node,
6834 BIGGEST_ALIGNMENT);
6836 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6837 gnat_field = Next_Entity (gnat_field))
6838 if ((Ekind (gnat_field) == E_Component
6839 || (Ekind (gnat_field) == E_Discriminant
6840 && !Is_Unchecked_Union (Scope (gnat_field)))))
6842 tree parent_offset = bitsize_zero_node;
6844 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6845 gnu_list);
6847 if (gnu_entry)
6849 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6851 /* In this mode the tag and parent components have not been
6852 generated, so we add the appropriate offset to each
6853 component. For a component appearing in the current
6854 extension, the offset is the size of the parent. */
6855 if (Is_Derived_Type (gnat_entity)
6856 && Original_Record_Component (gnat_field) == gnat_field)
6857 parent_offset
6858 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6859 bitsizetype);
6860 else
6861 parent_offset = bitsize_int (POINTER_SIZE);
6864 Set_Component_Bit_Offset
6865 (gnat_field,
6866 annotate_value
6867 (size_binop (PLUS_EXPR,
6868 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6869 TREE_VALUE (TREE_VALUE
6870 (TREE_VALUE (gnu_entry)))),
6871 parent_offset)));
6873 Set_Esize (gnat_field,
6874 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6876 else if (Is_Tagged_Type (gnat_entity)
6877 && Is_Derived_Type (gnat_entity))
6879 /* If there is no gnu_entry, this is an inherited component whose
6880 position is the same as in the parent type. */
6881 Set_Component_Bit_Offset
6882 (gnat_field,
6883 Component_Bit_Offset (Original_Record_Component (gnat_field)));
6884 Set_Esize (gnat_field,
6885 Esize (Original_Record_Component (gnat_field)));
6890 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6891 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6892 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6893 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6894 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6895 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6896 so far. */
6898 static tree
6899 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6900 tree gnu_bitpos, unsigned int offset_align)
6902 tree gnu_field;
6903 tree gnu_result = gnu_list;
6905 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6906 gnu_field = TREE_CHAIN (gnu_field))
6908 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6909 DECL_FIELD_BIT_OFFSET (gnu_field));
6910 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6911 DECL_FIELD_OFFSET (gnu_field));
6912 unsigned int our_offset_align
6913 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6915 gnu_result
6916 = tree_cons (gnu_field,
6917 tree_cons (gnu_our_offset,
6918 tree_cons (size_int (our_offset_align),
6919 gnu_our_bitpos, NULL_TREE),
6920 NULL_TREE),
6921 gnu_result);
6923 if (DECL_INTERNAL_P (gnu_field))
6924 gnu_result
6925 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6926 gnu_our_offset, gnu_our_bitpos,
6927 our_offset_align);
6930 return gnu_result;
6933 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6934 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6935 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6936 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6937 for the size of a field. COMPONENT_P is true if we are being called
6938 to process the Component_Size of GNAT_OBJECT. This is used for error
6939 message handling and to indicate to use the object size of GNU_TYPE.
6940 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6941 it means that a size of zero should be treated as an unspecified size. */
6943 static tree
6944 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6945 enum tree_code kind, bool component_p, bool zero_ok)
6947 Node_Id gnat_error_node;
6948 tree type_size, size;
6950 if (kind == VAR_DECL
6951 /* If a type needs strict alignment, a component of this type in
6952 a packed record cannot be packed and thus uses the type size. */
6953 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
6954 type_size = TYPE_SIZE (gnu_type);
6955 else
6956 type_size = rm_size (gnu_type);
6958 /* Find the node to use for errors. */
6959 if ((Ekind (gnat_object) == E_Component
6960 || Ekind (gnat_object) == E_Discriminant)
6961 && Present (Component_Clause (gnat_object)))
6962 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6963 else if (Present (Size_Clause (gnat_object)))
6964 gnat_error_node = Expression (Size_Clause (gnat_object));
6965 else
6966 gnat_error_node = gnat_object;
6968 /* Return 0 if no size was specified, either because Esize was not Present or
6969 the specified size was zero. */
6970 if (No (uint_size) || uint_size == No_Uint)
6971 return NULL_TREE;
6973 /* Get the size as a tree. Give an error if a size was specified, but cannot
6974 be represented as in sizetype. */
6975 size = UI_To_gnu (uint_size, bitsizetype);
6976 if (TREE_OVERFLOW (size))
6978 post_error_ne (component_p ? "component size of & is too large"
6979 : "size of & is too large",
6980 gnat_error_node, gnat_object);
6981 return NULL_TREE;
6984 /* Ignore a negative size since that corresponds to our back-annotation.
6985 Also ignore a zero size unless a size clause exists. */
6986 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6987 return NULL_TREE;
6989 /* The size of objects is always a multiple of a byte. */
6990 if (kind == VAR_DECL
6991 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6993 if (component_p)
6994 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6995 gnat_error_node, gnat_object);
6996 else
6997 post_error_ne ("size for& is not a multiple of Storage_Unit",
6998 gnat_error_node, gnat_object);
6999 return NULL_TREE;
7002 /* If this is an integral type or a packed array type, the front-end has
7003 verified the size, so we need not do it here (which would entail
7004 checking against the bounds). However, if this is an aliased object, it
7005 may not be smaller than the type of the object. */
7006 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7007 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7008 return size;
7010 /* If the object is a record that contains a template, add the size of
7011 the template to the specified size. */
7012 if (TREE_CODE (gnu_type) == RECORD_TYPE
7013 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7014 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7016 /* Modify the size of the type to be that of the maximum size if it has a
7017 discriminant. */
7018 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7019 type_size = max_size (type_size, true);
7021 /* If this is an access type or a fat pointer, the minimum size is that given
7022 by the smallest integral mode that's valid for pointers. */
7023 if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
7025 enum machine_mode p_mode;
7027 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7028 !targetm.valid_pointer_mode (p_mode);
7029 p_mode = GET_MODE_WIDER_MODE (p_mode))
7032 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7035 /* If the size of the object is a constant, the new size must not be
7036 smaller. */
7037 if (TREE_CODE (type_size) != INTEGER_CST
7038 || TREE_OVERFLOW (type_size)
7039 || tree_int_cst_lt (size, type_size))
7041 if (component_p)
7042 post_error_ne_tree
7043 ("component size for& too small{, minimum allowed is ^}",
7044 gnat_error_node, gnat_object, type_size);
7045 else
7046 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7047 gnat_error_node, gnat_object, type_size);
7049 if (kind == VAR_DECL && !component_p
7050 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7051 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7052 post_error_ne_tree_2
7053 ("\\size of ^ is not a multiple of alignment (^ bits)",
7054 gnat_error_node, gnat_object, rm_size (gnu_type),
7055 TYPE_ALIGN (gnu_type));
7057 else if (INTEGRAL_TYPE_P (gnu_type))
7058 post_error_ne ("\\size would be legal if & were not aliased!",
7059 gnat_error_node, gnat_object);
7061 return NULL_TREE;
7064 return size;
7067 /* Similarly, but both validate and process a value of RM_Size. This
7068 routine is only called for types. */
7070 static void
7071 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7073 /* Only give an error if a Value_Size clause was explicitly given.
7074 Otherwise, we'd be duplicating an error on the Size clause. */
7075 Node_Id gnat_attr_node
7076 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7077 tree old_size = rm_size (gnu_type);
7078 tree size;
7080 /* Get the size as a tree. Do nothing if none was specified, either
7081 because RM_Size was not Present or if the specified size was zero.
7082 Give an error if a size was specified, but cannot be represented as
7083 in sizetype. */
7084 if (No (uint_size) || uint_size == No_Uint)
7085 return;
7087 size = UI_To_gnu (uint_size, bitsizetype);
7088 if (TREE_OVERFLOW (size))
7090 if (Present (gnat_attr_node))
7091 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7092 gnat_entity);
7094 return;
7097 /* Ignore a negative size since that corresponds to our back-annotation.
7098 Also ignore a zero size unless a size clause exists, a Value_Size
7099 clause exists, or this is an integer type, in which case the
7100 front end will have always set it. */
7101 else if (tree_int_cst_sgn (size) < 0
7102 || (integer_zerop (size) && No (gnat_attr_node)
7103 && !Has_Size_Clause (gnat_entity)
7104 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7105 return;
7107 /* If the old size is self-referential, get the maximum size. */
7108 if (CONTAINS_PLACEHOLDER_P (old_size))
7109 old_size = max_size (old_size, true);
7111 /* If the size of the object is a constant, the new size must not be
7112 smaller (the front end checks this for scalar types). */
7113 if (TREE_CODE (old_size) != INTEGER_CST
7114 || TREE_OVERFLOW (old_size)
7115 || (AGGREGATE_TYPE_P (gnu_type)
7116 && tree_int_cst_lt (size, old_size)))
7118 if (Present (gnat_attr_node))
7119 post_error_ne_tree
7120 ("Value_Size for& too small{, minimum allowed is ^}",
7121 gnat_attr_node, gnat_entity, old_size);
7123 return;
7126 /* Otherwise, set the RM_Size. */
7127 if (TREE_CODE (gnu_type) == INTEGER_TYPE
7128 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7129 TYPE_RM_SIZE_NUM (gnu_type) = size;
7130 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7131 || TREE_CODE (gnu_type) == BOOLEAN_TYPE)
7132 TYPE_RM_SIZE_NUM (gnu_type) = size;
7133 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7134 || TREE_CODE (gnu_type) == UNION_TYPE
7135 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7136 && !TYPE_IS_FAT_POINTER_P (gnu_type))
7137 SET_TYPE_ADA_SIZE (gnu_type, size);
7140 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7141 If TYPE is the best type, return it. Otherwise, make a new type. We
7142 only support new integral and pointer types. FOR_BIASED is nonzero if
7143 we are making a biased type. */
7145 static tree
7146 make_type_from_size (tree type, tree size_tree, bool for_biased)
7148 unsigned HOST_WIDE_INT size;
7149 bool biased_p, boolean_p;
7150 tree new_type;
7152 /* If size indicates an error, just return TYPE to avoid propagating
7153 the error. Likewise if it's too large to represent. */
7154 if (!size_tree || !host_integerp (size_tree, 1))
7155 return type;
7157 size = tree_low_cst (size_tree, 1);
7159 switch (TREE_CODE (type))
7161 case INTEGER_TYPE:
7162 case ENUMERAL_TYPE:
7163 case BOOLEAN_TYPE:
7164 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7165 && TYPE_BIASED_REPRESENTATION_P (type));
7167 boolean_p = (TREE_CODE (type) == BOOLEAN_TYPE
7168 || (TREE_CODE (type) == INTEGER_TYPE
7169 && TREE_TYPE (type)
7170 && TREE_CODE (TREE_TYPE (type)) == BOOLEAN_TYPE));
7172 if (boolean_p)
7173 size = round_up_to_align (size, BITS_PER_UNIT);
7175 /* Only do something if the type is not a packed array type and
7176 doesn't already have the proper size. */
7177 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7178 || (biased_p == for_biased && TYPE_PRECISION (type) == size)
7179 || (boolean_p && compare_tree_int (TYPE_SIZE (type), size) == 0))
7180 break;
7182 biased_p |= for_biased;
7183 size = MIN (size, LONG_LONG_TYPE_SIZE);
7185 if (TYPE_UNSIGNED (type) || biased_p)
7186 new_type = make_unsigned_type (size);
7187 else
7188 new_type = make_signed_type (size);
7189 if (boolean_p)
7190 TYPE_PRECISION (new_type) = 1;
7191 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7192 TYPE_MIN_VALUE (new_type)
7193 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
7194 TYPE_MAX_VALUE (new_type)
7195 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
7196 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7197 if (boolean_p)
7198 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (1);
7199 else
7200 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
7201 return new_type;
7203 case RECORD_TYPE:
7204 /* Do something if this is a fat pointer, in which case we
7205 may need to return the thin pointer. */
7206 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7208 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7209 if (!targetm.valid_pointer_mode (p_mode))
7210 p_mode = ptr_mode;
7211 return
7212 build_pointer_type_for_mode
7213 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7214 p_mode, 0);
7216 break;
7218 case POINTER_TYPE:
7219 /* Only do something if this is a thin pointer, in which case we
7220 may need to return the fat pointer. */
7221 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7222 return
7223 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7224 break;
7226 default:
7227 break;
7230 return type;
7233 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7234 a type or object whose present alignment is ALIGN. If this alignment is
7235 valid, return it. Otherwise, give an error and return ALIGN. */
7237 static unsigned int
7238 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7240 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7241 unsigned int new_align;
7242 Node_Id gnat_error_node;
7244 /* Don't worry about checking alignment if alignment was not specified
7245 by the source program and we already posted an error for this entity. */
7246 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7247 return align;
7249 /* Post the error on the alignment clause if any. */
7250 if (Present (Alignment_Clause (gnat_entity)))
7251 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7252 else
7253 gnat_error_node = gnat_entity;
7255 /* Within GCC, an alignment is an integer, so we must make sure a value is
7256 specified that fits in that range. Also, there is an upper bound to
7257 alignments we can support/allow. */
7258 if (!UI_Is_In_Int_Range (alignment)
7259 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7260 post_error_ne_num ("largest supported alignment for& is ^",
7261 gnat_error_node, gnat_entity, max_allowed_alignment);
7262 else if (!(Present (Alignment_Clause (gnat_entity))
7263 && From_At_Mod (Alignment_Clause (gnat_entity)))
7264 && new_align * BITS_PER_UNIT < align)
7265 post_error_ne_num ("alignment for& must be at least ^",
7266 gnat_error_node, gnat_entity,
7267 align / BITS_PER_UNIT);
7268 else
7270 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7271 if (new_align > align)
7272 align = new_align;
7275 return align;
7278 /* Return the smallest alignment not less than SIZE. */
7280 static unsigned int
7281 ceil_alignment (unsigned HOST_WIDE_INT size)
7283 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7286 /* Verify that OBJECT, a type or decl, is something we can implement
7287 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7288 if we require atomic components. */
7290 static void
7291 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7293 Node_Id gnat_error_point = gnat_entity;
7294 Node_Id gnat_node;
7295 enum machine_mode mode;
7296 unsigned int align;
7297 tree size;
7299 /* There are three case of what OBJECT can be. It can be a type, in which
7300 case we take the size, alignment and mode from the type. It can be a
7301 declaration that was indirect, in which case the relevant values are
7302 that of the type being pointed to, or it can be a normal declaration,
7303 in which case the values are of the decl. The code below assumes that
7304 OBJECT is either a type or a decl. */
7305 if (TYPE_P (object))
7307 mode = TYPE_MODE (object);
7308 align = TYPE_ALIGN (object);
7309 size = TYPE_SIZE (object);
7311 else if (DECL_BY_REF_P (object))
7313 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7314 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7315 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7317 else
7319 mode = DECL_MODE (object);
7320 align = DECL_ALIGN (object);
7321 size = DECL_SIZE (object);
7324 /* Consider all floating-point types atomic and any types that that are
7325 represented by integers no wider than a machine word. */
7326 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7327 || ((GET_MODE_CLASS (mode) == MODE_INT
7328 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7329 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7330 return;
7332 /* For the moment, also allow anything that has an alignment equal
7333 to its size and which is smaller than a word. */
7334 if (size && TREE_CODE (size) == INTEGER_CST
7335 && compare_tree_int (size, align) == 0
7336 && align <= BITS_PER_WORD)
7337 return;
7339 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7340 gnat_node = Next_Rep_Item (gnat_node))
7342 if (!comp_p && Nkind (gnat_node) == N_Pragma
7343 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7344 == Pragma_Atomic))
7345 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7346 else if (comp_p && Nkind (gnat_node) == N_Pragma
7347 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7348 == Pragma_Atomic_Components))
7349 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7352 if (comp_p)
7353 post_error_ne ("atomic access to component of & cannot be guaranteed",
7354 gnat_error_point, gnat_entity);
7355 else
7356 post_error_ne ("atomic access to & cannot be guaranteed",
7357 gnat_error_point, gnat_entity);
7360 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7361 have compatible signatures so that a call using one type may be safely
7362 issued if the actual target function type is the other. Return 1 if it is
7363 the case, 0 otherwise, and post errors on the incompatibilities.
7365 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7366 that calls to the subprogram will have arguments suitable for the later
7367 underlying builtin expansion. */
7369 static int
7370 compatible_signatures_p (tree ftype1, tree ftype2)
7372 /* As of now, we only perform very trivial tests and consider it's the
7373 programmer's responsibility to ensure the type correctness in the Ada
7374 declaration, as in the regular Import cases.
7376 Mismatches typically result in either error messages from the builtin
7377 expander, internal compiler errors, or in a real call sequence. This
7378 should be refined to issue diagnostics helping error detection and
7379 correction. */
7381 /* Almost fake test, ensuring a use of each argument. */
7382 if (ftype1 == ftype2)
7383 return 1;
7385 return 1;
7388 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7389 type with all size expressions that contain F updated by replacing F
7390 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
7391 nothing has changed. */
7393 tree
7394 substitute_in_type (tree t, tree f, tree r)
7396 tree new = t;
7397 tree tem;
7399 switch (TREE_CODE (t))
7401 case INTEGER_TYPE:
7402 case ENUMERAL_TYPE:
7403 case BOOLEAN_TYPE:
7404 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7405 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7407 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7408 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7410 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7411 return t;
7413 new = build_range_type (TREE_TYPE (t), low, high);
7414 if (TYPE_INDEX_TYPE (t))
7415 SET_TYPE_INDEX_TYPE
7416 (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
7417 return new;
7420 return t;
7422 case REAL_TYPE:
7423 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7424 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7426 tree low = NULL_TREE, high = NULL_TREE;
7428 if (TYPE_MIN_VALUE (t))
7429 low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7430 if (TYPE_MAX_VALUE (t))
7431 high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7433 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7434 return t;
7436 t = copy_type (t);
7437 TYPE_MIN_VALUE (t) = low;
7438 TYPE_MAX_VALUE (t) = high;
7440 return t;
7442 case COMPLEX_TYPE:
7443 tem = substitute_in_type (TREE_TYPE (t), f, r);
7444 if (tem == TREE_TYPE (t))
7445 return t;
7447 return build_complex_type (tem);
7449 case OFFSET_TYPE:
7450 case METHOD_TYPE:
7451 case FUNCTION_TYPE:
7452 case LANG_TYPE:
7453 /* Don't know how to do these yet. */
7454 gcc_unreachable ();
7456 case ARRAY_TYPE:
7458 tree component = substitute_in_type (TREE_TYPE (t), f, r);
7459 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
7461 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
7462 return t;
7464 new = build_array_type (component, domain);
7465 TYPE_SIZE (new) = 0;
7466 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
7467 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
7468 layout_type (new);
7469 TYPE_ALIGN (new) = TYPE_ALIGN (t);
7470 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
7472 /* If we had bounded the sizes of T by a constant, bound the sizes of
7473 NEW by the same constant. */
7474 if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
7475 TYPE_SIZE (new)
7476 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
7477 TYPE_SIZE (new));
7478 if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
7479 TYPE_SIZE_UNIT (new)
7480 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
7481 TYPE_SIZE_UNIT (new));
7482 return new;
7485 case RECORD_TYPE:
7486 case UNION_TYPE:
7487 case QUAL_UNION_TYPE:
7489 tree field;
7490 bool changed_field
7491 = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
7492 bool field_has_rep = false;
7493 tree last_field = NULL_TREE;
7495 tree new = copy_type (t);
7497 /* Start out with no fields, make new fields, and chain them
7498 in. If we haven't actually changed the type of any field,
7499 discard everything we've done and return the old type. */
7501 TYPE_FIELDS (new) = NULL_TREE;
7502 TYPE_SIZE (new) = NULL_TREE;
7504 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
7506 tree new_field = copy_node (field);
7508 TREE_TYPE (new_field)
7509 = substitute_in_type (TREE_TYPE (new_field), f, r);
7511 if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
7512 field_has_rep = true;
7513 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
7514 changed_field = true;
7516 /* If this is an internal field and the type of this field is
7517 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7518 the type just has one element, treat that as the field.
7519 But don't do this if we are processing a QUAL_UNION_TYPE. */
7520 if (TREE_CODE (t) != QUAL_UNION_TYPE
7521 && DECL_INTERNAL_P (new_field)
7522 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
7523 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
7525 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
7526 continue;
7528 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
7530 tree next_new_field
7531 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
7533 /* Make sure omitting the union doesn't change
7534 the layout. */
7535 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
7536 new_field = next_new_field;
7540 DECL_CONTEXT (new_field) = new;
7541 SET_DECL_ORIGINAL_FIELD (new_field,
7542 (DECL_ORIGINAL_FIELD (field)
7543 ? DECL_ORIGINAL_FIELD (field) : field));
7545 /* If the size of the old field was set at a constant,
7546 propagate the size in case the type's size was variable.
7547 (This occurs in the case of a variant or discriminated
7548 record with a default size used as a field of another
7549 record.) */
7550 DECL_SIZE (new_field)
7551 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
7552 ? DECL_SIZE (field) : NULL_TREE;
7553 DECL_SIZE_UNIT (new_field)
7554 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
7555 ? DECL_SIZE_UNIT (field) : NULL_TREE;
7557 if (TREE_CODE (t) == QUAL_UNION_TYPE)
7559 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7561 if (new_q != DECL_QUALIFIER (new_field))
7562 changed_field = true;
7564 /* Do the substitution inside the qualifier and if we find
7565 that this field will not be present, omit it. */
7566 DECL_QUALIFIER (new_field) = new_q;
7568 if (integer_zerop (DECL_QUALIFIER (new_field)))
7569 continue;
7572 if (!last_field)
7573 TYPE_FIELDS (new) = new_field;
7574 else
7575 TREE_CHAIN (last_field) = new_field;
7577 last_field = new_field;
7579 /* If this is a qualified type and this field will always be
7580 present, we are done. */
7581 if (TREE_CODE (t) == QUAL_UNION_TYPE
7582 && integer_onep (DECL_QUALIFIER (new_field)))
7583 break;
7586 /* If this used to be a qualified union type, but we now know what
7587 field will be present, make this a normal union. */
7588 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
7589 && (!TYPE_FIELDS (new)
7590 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7591 TREE_SET_CODE (new, UNION_TYPE);
7592 else if (!changed_field)
7593 return t;
7595 gcc_assert (!field_has_rep);
7596 layout_type (new);
7598 /* If the size was originally a constant use it. */
7599 if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
7600 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
7602 TYPE_SIZE (new) = TYPE_SIZE (t);
7603 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
7604 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
7607 return new;
7610 default:
7611 return t;
7615 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7616 needed to represent the object. */
7618 tree
7619 rm_size (tree gnu_type)
7621 /* For integer types, this is the precision. For record types, we store
7622 the size explicitly. For other types, this is just the size. */
7624 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7625 return TYPE_RM_SIZE (gnu_type);
7626 else if (TREE_CODE (gnu_type) == RECORD_TYPE
7627 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7628 /* Return the rm_size of the actual data plus the size of the template. */
7629 return
7630 size_binop (PLUS_EXPR,
7631 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7632 DECL_SIZE (TYPE_FIELDS (gnu_type)));
7633 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7634 || TREE_CODE (gnu_type) == UNION_TYPE
7635 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7636 && !TYPE_IS_FAT_POINTER_P (gnu_type)
7637 && TYPE_ADA_SIZE (gnu_type))
7638 return TYPE_ADA_SIZE (gnu_type);
7639 else
7640 return TYPE_SIZE (gnu_type);
7643 /* Return an identifier representing the external name to be used for
7644 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7645 and the specified suffix. */
7647 tree
7648 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7650 Entity_Kind kind = Ekind (gnat_entity);
7652 const char *str = (!suffix ? "" : suffix);
7653 String_Template temp = {1, strlen (str)};
7654 Fat_Pointer fp = {str, &temp};
7656 Get_External_Name_With_Suffix (gnat_entity, fp);
7658 /* A variable using the Stdcall convention (meaning we are running
7659 on a Windows box) live in a DLL. Here we adjust its name to use
7660 the jump-table, the _imp__NAME contains the address for the NAME
7661 variable. */
7662 if ((kind == E_Variable || kind == E_Constant)
7663 && Has_Stdcall_Convention (gnat_entity))
7665 const char *prefix = "_imp__";
7666 int k, plen = strlen (prefix);
7668 for (k = 0; k <= Name_Len; k++)
7669 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
7670 strncpy (Name_Buffer, prefix, plen);
7673 return get_identifier (Name_Buffer);
7676 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7677 fully-qualified name, possibly with type information encoding.
7678 Otherwise, return the name. */
7680 tree
7681 get_entity_name (Entity_Id gnat_entity)
7683 Get_Encoded_Name (gnat_entity);
7684 return get_identifier (Name_Buffer);
7687 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7688 string, return a new IDENTIFIER_NODE that is the concatenation of
7689 the name in GNU_ID and SUFFIX. */
7691 tree
7692 concat_id_with_name (tree gnu_id, const char *suffix)
7694 int len = IDENTIFIER_LENGTH (gnu_id);
7696 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
7697 strncpy (Name_Buffer + len, "___", 3);
7698 len += 3;
7699 strcpy (Name_Buffer + len, suffix);
7700 return get_identifier (Name_Buffer);
7703 #include "gt-ada-decl.h"