1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
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/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
56 #ifndef MAX_FIXED_MODE_SIZE
57 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
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)
67 #define Has_Stdcall_Convention(E) (0)
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
89 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
90 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
95 struct incomplete *next;
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
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,
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,
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. */
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. */
164 gnat_to_gnu_type (Entity_Id gnat_entity)
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
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
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);
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. */
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);
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);
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)
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
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),
306 save_gnu_tree (gnat_entity, NULL_TREE, false);
307 save_gnu_tree (gnat_entity, gnu_decl, false);
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
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
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
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);
370 /* If this is a use of a deferred constant, get its full
372 if (!definition && Present (Full_View (gnat_entity)))
374 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
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 */
386 && Present (Expression (Declaration_Node (gnat_entity)))
387 && !No_Initialization (Declaration_Node (gnat_entity))
388 && (Nkind (Expression (Declaration_Node (gnat_entity)))
390 && (Nkind (Expression (Declaration_Node (gnat_entity)))
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;
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),
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
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)
448 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
449 gnu_expr, definition);
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
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));
469 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
470 gnu_expr, definition);
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);
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
491 else if (Present (Corresponding_Discriminant (gnat_entity))
492 && (First_Discriminant (gnat_record)
493 != First_Stored_Discriminant (gnat_record)))
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
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)))
513 = gnat_to_gnu_entity (Original_Record_Component
520 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
521 gnu_decl = get_gnu_tree (gnat_entity);
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. */
533 case E_Loop_Parameter:
534 case E_Out_Parameter:
537 /* Simple variables, loop variables, Out parameters, and exceptions. */
540 bool used_by_ref = false;
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),
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)))
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);
576 addr = stack_pointer_rtx;
577 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
578 gnat_pushdecl (gnu_decl, gnat_entity);
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);
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
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. */
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);
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)))
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));
669 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
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))))
681 = TYPE_SIZE (gnat_to_gnu_type
683 (Expression (Declaration_Node (gnat_entity)))));
686 gnu_size = max_size (TYPE_SIZE (gnu_type), 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
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))
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)
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)
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))
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;
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)
785 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
788 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
789 concat_id_with_name (gnu_entity_id,
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;
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)))
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. */
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;
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))))
894 = maybe_stabilize_reference (gnu_expr, true, &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);
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. */
935 gnu_type = build_reference_type (gnu_type);
936 inner_const_flag = TREE_READONLY (gnu_expr);
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. */
966 = maybe_stabilize_reference (gnu_expr, true, &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. */
976 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
978 gnu_size = NULL_TREE;
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. */
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)))
997 && TYPE_CONTAINS_TEMPLATE_P
998 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
1002 = TYPE_IS_PADDING_P (gnu_type)
1003 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1004 : TYPE_FIELDS (gnu_type);
1007 = gnat_build_constructor
1011 build_template (TREE_TYPE (template_field),
1012 TREE_TYPE (TREE_CHAIN (template_field)),
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. */
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
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)))
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
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). */
1060 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1061 gnu_address = convert (gnu_type, gnu_address);
1063 const_flag = !Is_Public (gnat_entity)
1064 || compile_time_known_address_p (Expression (Address_Clause
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. */
1072 gnu_expr = gnu_address;
1075 = build2 (COMPOUND_EXPR, gnu_type,
1077 (MODIFY_EXPR, NULL_TREE,
1078 build_unary_op (INDIRECT_REF, NULL_TREE,
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
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). */
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);
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
1134 && ! allocatable_size_p (gnu_size,
1135 global_bindings_p () || !definition
1138 gnu_type = build_reference_type (gnu_type);
1139 gnu_size = NULL_TREE;
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. */
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))
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)))
1172 = build_component_ref
1173 (gnu_expr, NULL_TREE,
1174 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
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!",
1184 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1185 0, 0, gnat_entity, mutable_p);
1189 gnu_expr = NULL_TREE;
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. */
1203 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1204 TYPE_SIZE_UNIT (gnu_type),
1205 BIGGEST_ALIGNMENT, 0);
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. */
1214 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1216 (gnu_new_var, NULL_TREE,
1217 TYPE_FIELDS (gnu_new_type), false),
1221 /* And setup this entity as a reference to the aligned field. */
1222 gnu_type = build_reference_type (gnu_type);
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;
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. */
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
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))))
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 ())),
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
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)))
1315 || Address_Taken (gnat_entity)
1316 || Is_Aliased (gnat_entity)
1317 || Is_Aliased (Etype (gnat_entity))))
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,
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))
1361 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
1363 Set_Esize (gnat_entity, annotate_value (gnu_object_size));
1369 /* Return a TYPE_DECL for "void" that we previously made. */
1370 gnu_decl = void_type_decl_node;
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;
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);
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),
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. */
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
1440 gnu_type = make_signed_type (esize);
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;
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
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;
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
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
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),
1538 gnu_type = make_node (INTEGER_TYPE);
1539 if (Is_Packed_Array_Type (gnat_entity)
1540 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1542 esize = UI_To_Int (RM_Size (gnat_entity));
1543 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1546 TYPE_PRECISION (gnu_type) = esize;
1547 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1549 TYPE_MIN_VALUE (gnu_type)
1550 = convert (TREE_TYPE (gnu_type),
1551 elaborate_expression (Type_Low_Bound (gnat_entity),
1553 get_identifier ("L"), definition, 1,
1554 Needs_Debug_Info (gnat_entity)));
1556 TYPE_MAX_VALUE (gnu_type)
1557 = convert (TREE_TYPE (gnu_type),
1558 elaborate_expression (Type_High_Bound (gnat_entity),
1560 get_identifier ("U"), definition, 1,
1561 Needs_Debug_Info (gnat_entity)));
1563 /* One of the above calls might have caused us to be elaborated,
1564 so don't blow up if so. */
1565 if (present_gnu_tree (gnat_entity))
1567 maybe_present = true;
1571 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1572 = Has_Biased_Representation (gnat_entity);
1574 /* This should be an unsigned type if the lower bound is constant
1575 and non-negative or if the base type is unsigned; a signed type
1577 TYPE_UNSIGNED (gnu_type)
1578 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1579 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1580 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1581 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1582 || Is_Unsigned_Type (gnat_entity));
1584 layout_type (gnu_type);
1586 /* Inherit our alias set from what we're a subtype of. Subtypes
1587 are not different types and a pointer can designate any instance
1588 within a subtype hierarchy. */
1589 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1591 /* If the type we are dealing with is to represent a packed array,
1592 we need to have the bits left justified on big-endian targets
1593 and right justified on little-endian targets. We also need to
1594 ensure that when the value is read (e.g. for comparison of two
1595 such values), we only get the good bits, since the unused bits
1596 are uninitialized. Both goals are accomplished by wrapping the
1597 modular value in an enclosing struct. */
1598 if (Is_Packed_Array_Type (gnat_entity)
1599 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1601 tree gnu_field_type = gnu_type;
1604 TYPE_RM_SIZE_NUM (gnu_field_type)
1605 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1606 gnu_type = make_node (RECORD_TYPE);
1607 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1609 /* Propagate the alignment of the modular type to the record.
1610 This means that bitpacked arrays have "ceil" alignment for
1611 their size, which may seem counter-intuitive but makes it
1612 possible to easily overlay them on modular types. */
1613 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1614 TYPE_PACKED (gnu_type) = 1;
1616 /* Create a stripped-down declaration of the original type, mainly
1618 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1619 NULL, true, debug_info_p, gnat_entity);
1621 /* Don't notify the field as "addressable", since we won't be taking
1622 it's address and it would prevent create_field_decl from making a
1624 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1625 gnu_field_type, gnu_type, 1, 0, 0, 0);
1627 finish_record_type (gnu_type, gnu_field, 0, false);
1628 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1629 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1631 copy_alias_set (gnu_type, gnu_field_type);
1634 /* If the type we are dealing with has got a smaller alignment than the
1635 natural one, we need to wrap it up in a record type and under-align
1636 the latter. We reuse the padding machinery for this purpose. */
1637 else if (Known_Alignment (gnat_entity)
1638 && UI_Is_In_Int_Range (Alignment (gnat_entity))
1639 && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
1640 && align < TYPE_ALIGN (gnu_type))
1642 tree gnu_field_type = gnu_type;
1645 gnu_type = make_node (RECORD_TYPE);
1646 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1648 TYPE_ALIGN (gnu_type) = align;
1649 TYPE_PACKED (gnu_type) = 1;
1651 /* Create a stripped-down declaration of the original type, mainly
1653 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1654 NULL, true, debug_info_p, gnat_entity);
1656 /* Don't notify the field as "addressable", since we won't be taking
1657 it's address and it would prevent create_field_decl from making a
1659 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1660 gnu_field_type, gnu_type, 1, 0, 0, 0);
1662 finish_record_type (gnu_type, gnu_field, 0, false);
1663 TYPE_IS_PADDING_P (gnu_type) = 1;
1664 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1666 copy_alias_set (gnu_type, gnu_field_type);
1669 /* Otherwise reset the alignment lest we computed it above. */
1675 case E_Floating_Point_Type:
1676 /* If this is a VAX floating-point type, use an integer of the proper
1677 size. All the operations will be handled with ASM statements. */
1678 if (Vax_Float (gnat_entity))
1680 gnu_type = make_signed_type (esize);
1681 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1682 SET_TYPE_DIGITS_VALUE (gnu_type,
1683 UI_To_gnu (Digits_Value (gnat_entity),
1688 /* The type of the Low and High bounds can be our type if this is
1689 a type from Standard, so set them at the end of the function. */
1690 gnu_type = make_node (REAL_TYPE);
1691 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1692 layout_type (gnu_type);
1695 case E_Floating_Point_Subtype:
1696 if (Vax_Float (gnat_entity))
1698 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1704 && Present (Ancestor_Subtype (gnat_entity))
1705 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1706 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1707 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1708 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1711 gnu_type = make_node (REAL_TYPE);
1712 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1713 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1715 TYPE_MIN_VALUE (gnu_type)
1716 = convert (TREE_TYPE (gnu_type),
1717 elaborate_expression (Type_Low_Bound (gnat_entity),
1718 gnat_entity, get_identifier ("L"),
1720 Needs_Debug_Info (gnat_entity)));
1722 TYPE_MAX_VALUE (gnu_type)
1723 = convert (TREE_TYPE (gnu_type),
1724 elaborate_expression (Type_High_Bound (gnat_entity),
1725 gnat_entity, get_identifier ("U"),
1727 Needs_Debug_Info (gnat_entity)));
1729 /* One of the above calls might have caused us to be elaborated,
1730 so don't blow up if so. */
1731 if (present_gnu_tree (gnat_entity))
1733 maybe_present = true;
1737 layout_type (gnu_type);
1739 /* Inherit our alias set from what we're a subtype of, as for
1740 integer subtypes. */
1741 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1745 /* Array and String Types and Subtypes
1747 Unconstrained array types are represented by E_Array_Type and
1748 constrained array types are represented by E_Array_Subtype. There
1749 are no actual objects of an unconstrained array type; all we have
1750 are pointers to that type.
1752 The following fields are defined on array types and subtypes:
1754 Component_Type Component type of the array.
1755 Number_Dimensions Number of dimensions (an int).
1756 First_Index Type of first index. */
1761 tree gnu_template_fields = NULL_TREE;
1762 tree gnu_template_type = make_node (RECORD_TYPE);
1763 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1764 tree gnu_fat_type = make_node (RECORD_TYPE);
1765 int ndim = Number_Dimensions (gnat_entity);
1767 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1769 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1771 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1772 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1773 tree gnu_comp_size = 0;
1774 tree gnu_max_size = size_one_node;
1775 tree gnu_max_size_unit;
1776 Entity_Id gnat_ind_subtype;
1777 Entity_Id gnat_ind_base_subtype;
1778 tree gnu_template_reference;
1781 TYPE_NAME (gnu_template_type)
1782 = create_concat_name (gnat_entity, "XUB");
1784 /* Make a node for the array. If we are not defining the array
1785 suppress expanding incomplete types. */
1786 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1789 defer_incomplete_level++, this_deferred = true;
1791 /* Build the fat pointer type. Use a "void *" object instead of
1792 a pointer to the array type since we don't have the array type
1793 yet (it will reference the fat pointer via the bounds). */
1794 tem = chainon (chainon (NULL_TREE,
1795 create_field_decl (get_identifier ("P_ARRAY"),
1797 gnu_fat_type, 0, 0, 0, 0)),
1798 create_field_decl (get_identifier ("P_BOUNDS"),
1800 gnu_fat_type, 0, 0, 0, 0));
1802 /* Make sure we can put this into a register. */
1803 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1805 /* Do not finalize this record type since the types of its fields
1806 are still incomplete at this point. */
1807 finish_record_type (gnu_fat_type, tem, 0, true);
1808 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1810 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1811 is the fat pointer. This will be used to access the individual
1812 fields once we build them. */
1813 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1814 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1815 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1816 gnu_template_reference
1817 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1818 TREE_READONLY (gnu_template_reference) = 1;
1820 /* Now create the GCC type for each index and add the fields for
1821 that index to the template. */
1822 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1823 gnat_ind_base_subtype
1824 = First_Index (Implementation_Base_Type (gnat_entity));
1825 index < ndim && index >= 0;
1827 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1828 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1830 char field_name[10];
1831 tree gnu_ind_subtype
1832 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1833 tree gnu_base_subtype
1834 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1836 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1838 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1839 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1841 /* Make the FIELD_DECLs for the minimum and maximum of this
1842 type and then make extractions of that field from the
1844 sprintf (field_name, "LB%d", index);
1845 gnu_min_field = create_field_decl (get_identifier (field_name),
1847 gnu_template_type, 0, 0, 0, 0);
1848 field_name[0] = 'U';
1849 gnu_max_field = create_field_decl (get_identifier (field_name),
1851 gnu_template_type, 0, 0, 0, 0);
1853 Sloc_to_locus (Sloc (gnat_entity),
1854 &DECL_SOURCE_LOCATION (gnu_min_field));
1855 Sloc_to_locus (Sloc (gnat_entity),
1856 &DECL_SOURCE_LOCATION (gnu_max_field));
1857 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1859 /* We can't use build_component_ref here since the template
1860 type isn't complete yet. */
1861 gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
1862 gnu_template_reference, gnu_min_field,
1864 gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
1865 gnu_template_reference, gnu_max_field,
1867 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1869 /* Make a range type with the new ranges, but using
1870 the Ada subtype. Then we convert to sizetype. */
1871 gnu_index_types[index]
1872 = create_index_type (convert (sizetype, gnu_min),
1873 convert (sizetype, gnu_max),
1874 build_range_type (gnu_ind_subtype,
1877 /* Update the maximum size of the array, in elements. */
1879 = size_binop (MULT_EXPR, gnu_max_size,
1880 size_binop (PLUS_EXPR, size_one_node,
1881 size_binop (MINUS_EXPR, gnu_base_max,
1884 TYPE_NAME (gnu_index_types[index])
1885 = create_concat_name (gnat_entity, field_name);
1888 for (index = 0; index < ndim; index++)
1890 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1892 /* Install all the fields into the template. */
1893 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1894 TYPE_READONLY (gnu_template_type) = 1;
1896 /* Now make the array of arrays and update the pointer to the array
1897 in the fat pointer. Note that it is the first field. */
1898 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1900 /* Try to get a smaller form of the component if needed. */
1901 if ((Is_Packed (gnat_entity)
1902 || Has_Component_Size_Clause (gnat_entity))
1903 && !Is_Bit_Packed_Array (gnat_entity)
1904 && !Has_Aliased_Components (gnat_entity)
1905 && !Strict_Alignment (Component_Type (gnat_entity))
1906 && TREE_CODE (tem) == RECORD_TYPE
1907 && host_integerp (TYPE_SIZE (tem), 1))
1908 tem = make_packable_type (tem, false);
1910 if (Has_Atomic_Components (gnat_entity))
1911 check_ok_for_atomic (tem, gnat_entity, true);
1913 /* Get and validate any specified Component_Size, but if Packed,
1914 ignore it since the front end will have taken care of it. */
1916 = validate_size (Component_Size (gnat_entity), tem,
1918 (Is_Bit_Packed_Array (gnat_entity)
1919 ? TYPE_DECL : VAR_DECL),
1920 true, Has_Component_Size_Clause (gnat_entity));
1922 /* If the component type is a RECORD_TYPE that has a self-referential
1923 size, use the maxium size. */
1924 if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
1925 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1926 gnu_comp_size = max_size (TYPE_SIZE (tem), true);
1928 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
1931 tem = make_type_from_size (tem, gnu_comp_size, false);
1933 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1934 "C_PAD", false, definition, true);
1935 /* If a padding record was made, declare it now since it will
1936 never be declared otherwise. This is necessary to ensure
1937 that its subtrees are properly marked. */
1938 if (tem != orig_tem)
1939 create_type_decl (TYPE_NAME (tem), tem, NULL, true, false,
1943 if (Has_Volatile_Components (gnat_entity))
1944 tem = build_qualified_type (tem,
1945 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1947 /* If Component_Size is not already specified, annotate it with the
1948 size of the component. */
1949 if (Unknown_Component_Size (gnat_entity))
1950 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1952 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1953 size_binop (MULT_EXPR, gnu_max_size,
1954 TYPE_SIZE_UNIT (tem)));
1955 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1956 size_binop (MULT_EXPR,
1957 convert (bitsizetype,
1961 for (index = ndim - 1; index >= 0; index--)
1963 tem = build_array_type (tem, gnu_index_types[index]);
1964 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1965 if (array_type_has_nonaliased_component (gnat_entity, tem))
1966 TYPE_NONALIASED_COMPONENT (tem) = 1;
1969 /* If an alignment is specified, use it if valid. But ignore it for
1970 types that represent the unpacked base type for packed arrays. If
1971 the alignment was requested with an explicit user alignment clause,
1973 if (No (Packed_Array_Type (gnat_entity))
1974 && Known_Alignment (gnat_entity))
1976 gcc_assert (Present (Alignment (gnat_entity)));
1978 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1980 if (Present (Alignment_Clause (gnat_entity)))
1981 TYPE_USER_ALIGN (tem) = 1;
1984 TYPE_CONVENTION_FORTRAN_P (tem)
1985 = (Convention (gnat_entity) == Convention_Fortran);
1986 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1988 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1989 corresponding fat pointer. */
1990 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1991 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1992 TYPE_MODE (gnu_type) = BLKmode;
1993 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1994 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1996 /* If the maximum size doesn't overflow, use it. */
1997 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1998 && !TREE_OVERFLOW (gnu_max_size))
2000 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
2001 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2002 && !TREE_OVERFLOW (gnu_max_size_unit))
2003 TYPE_SIZE_UNIT (tem)
2004 = size_binop (MIN_EXPR, gnu_max_size_unit,
2005 TYPE_SIZE_UNIT (tem));
2007 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2008 tem, NULL, !Comes_From_Source (gnat_entity),
2009 debug_info_p, gnat_entity);
2011 /* Give the fat pointer type a name. */
2012 create_type_decl (create_concat_name (gnat_entity, "XUP"),
2013 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
2014 debug_info_p, gnat_entity);
2016 /* Create the type to be used as what a thin pointer designates: an
2017 record type for the object and its template with the field offsets
2018 shifted to have the template at a negative offset. */
2019 tem = build_unc_object_type (gnu_template_type, tem,
2020 create_concat_name (gnat_entity, "XUT"));
2021 shift_unc_components_for_thin_pointers (tem);
2023 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2024 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2026 /* Give the thin pointer type a name. */
2027 create_type_decl (create_concat_name (gnat_entity, "XUX"),
2028 build_pointer_type (tem), NULL,
2029 !Comes_From_Source (gnat_entity), debug_info_p,
2034 case E_String_Subtype:
2035 case E_Array_Subtype:
2037 /* This is the actual data type for array variables. Multidimensional
2038 arrays are implemented in the gnu tree as arrays of arrays. Note
2039 that for the moment arrays which have sparse enumeration subtypes as
2040 index components create sparse arrays, which is obviously space
2041 inefficient but so much easier to code for now.
2043 Also note that the subtype never refers to the unconstrained
2044 array type, which is somewhat at variance with Ada semantics.
2046 First check to see if this is simply a renaming of the array
2047 type. If so, the result is the array type. */
2049 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2050 if (!Is_Constrained (gnat_entity))
2055 int array_dim = Number_Dimensions (gnat_entity);
2057 = ((Convention (gnat_entity) == Convention_Fortran)
2058 ? array_dim - 1 : 0);
2060 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
2061 Entity_Id gnat_ind_subtype;
2062 Entity_Id gnat_ind_base_subtype;
2063 tree gnu_base_type = gnu_type;
2064 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
2065 tree gnu_comp_size = NULL_TREE;
2066 tree gnu_max_size = size_one_node;
2067 tree gnu_max_size_unit;
2068 bool need_index_type_struct = false;
2069 bool max_overflow = false;
2071 /* First create the gnu types for each index. Create types for
2072 debugging information to point to the index types if the
2073 are not integer types, have variable bounds, or are
2074 wider than sizetype. */
2076 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
2077 gnat_ind_base_subtype
2078 = First_Index (Implementation_Base_Type (gnat_entity));
2079 index < array_dim && index >= 0;
2081 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
2082 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
2084 tree gnu_index_subtype
2085 = get_unpadded_type (Etype (gnat_ind_subtype));
2087 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
2089 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
2090 tree gnu_base_subtype
2091 = get_unpadded_type (Etype (gnat_ind_base_subtype));
2093 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
2095 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
2096 tree gnu_base_type = get_base_type (gnu_base_subtype);
2097 tree gnu_base_base_min
2098 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
2099 tree gnu_base_base_max
2100 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
2104 /* If the minimum and maximum values both overflow in
2105 SIZETYPE, but the difference in the original type
2106 does not overflow in SIZETYPE, ignore the overflow
2108 if ((TYPE_PRECISION (gnu_index_subtype)
2109 > TYPE_PRECISION (sizetype)
2110 || TYPE_UNSIGNED (gnu_index_subtype)
2111 != TYPE_UNSIGNED (sizetype))
2112 && TREE_CODE (gnu_min) == INTEGER_CST
2113 && TREE_CODE (gnu_max) == INTEGER_CST
2114 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2116 (fold_build2 (MINUS_EXPR, gnu_index_subtype,
2117 TYPE_MAX_VALUE (gnu_index_subtype),
2118 TYPE_MIN_VALUE (gnu_index_subtype)))))
2120 TREE_OVERFLOW (gnu_min) = 0;
2121 TREE_OVERFLOW (gnu_max) = 0;
2124 /* Similarly, if the range is null, use bounds of 1..0 for
2125 the sizetype bounds. */
2126 else if ((TYPE_PRECISION (gnu_index_subtype)
2127 > TYPE_PRECISION (sizetype)
2128 || TYPE_UNSIGNED (gnu_index_subtype)
2129 != TYPE_UNSIGNED (sizetype))
2130 && TREE_CODE (gnu_min) == INTEGER_CST
2131 && TREE_CODE (gnu_max) == INTEGER_CST
2132 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2133 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
2134 TYPE_MIN_VALUE (gnu_index_subtype)))
2135 gnu_min = size_one_node, gnu_max = size_zero_node;
2137 /* Now compute the size of this bound. We need to provide
2138 GCC with an upper bound to use but have to deal with the
2139 "superflat" case. There are three ways to do this. If we
2140 can prove that the array can never be superflat, we can
2141 just use the high bound of the index subtype. If we can
2142 prove that the low bound minus one can't overflow, we
2143 can do this as MAX (hb, lb - 1). Otherwise, we have to use
2144 the expression hb >= lb ? hb : lb - 1. */
2145 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2147 /* See if the base array type is already flat. If it is, we
2148 are probably compiling an ACVC test, but it will cause the
2149 code below to malfunction if we don't handle it specially. */
2150 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2151 && TREE_CODE (gnu_base_max) == INTEGER_CST
2152 && !TREE_OVERFLOW (gnu_base_min)
2153 && !TREE_OVERFLOW (gnu_base_max)
2154 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
2155 gnu_high = size_zero_node, gnu_min = size_one_node;
2157 /* If gnu_high is now an integer which overflowed, the array
2158 cannot be superflat. */
2159 else if (TREE_CODE (gnu_high) == INTEGER_CST
2160 && TREE_OVERFLOW (gnu_high))
2162 else if (TYPE_UNSIGNED (gnu_base_subtype)
2163 || TREE_CODE (gnu_high) == INTEGER_CST)
2164 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2168 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
2172 gnu_index_type[index]
2173 = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
2176 /* Also compute the maximum size of the array. Here we
2177 see if any constraint on the index type of the base type
2178 can be used in the case of self-referential bound on
2179 the index type of the subtype. We look for a non-"infinite"
2180 and non-self-referential bound from any type involved and
2181 handle each bound separately. */
2183 if ((TREE_CODE (gnu_min) == INTEGER_CST
2184 && !TREE_OVERFLOW (gnu_min)
2185 && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
2186 || !CONTAINS_PLACEHOLDER_P (gnu_min)
2187 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2188 && !TREE_OVERFLOW (gnu_base_min)))
2189 gnu_base_min = gnu_min;
2191 if ((TREE_CODE (gnu_max) == INTEGER_CST
2192 && !TREE_OVERFLOW (gnu_max)
2193 && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
2194 || !CONTAINS_PLACEHOLDER_P (gnu_max)
2195 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2196 && !TREE_OVERFLOW (gnu_base_max)))
2197 gnu_base_max = gnu_max;
2199 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2200 && TREE_OVERFLOW (gnu_base_min))
2201 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2202 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2203 && TREE_OVERFLOW (gnu_base_max))
2204 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2205 max_overflow = true;
2207 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
2208 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
2211 = size_binop (MAX_EXPR,
2212 size_binop (PLUS_EXPR, size_one_node,
2213 size_binop (MINUS_EXPR, gnu_base_max,
2217 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2218 && TREE_OVERFLOW (gnu_this_max))
2219 max_overflow = true;
2222 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2224 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
2225 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
2227 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
2228 || (TREE_TYPE (gnu_index_subtype)
2229 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
2231 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
2232 || (TYPE_PRECISION (gnu_index_subtype)
2233 > TYPE_PRECISION (sizetype)))
2234 need_index_type_struct = true;
2237 /* Then flatten: create the array of arrays. For an array type
2238 used to implement a packed array, get the component type from
2239 the original array type since the representation clauses that
2240 can affect it are on the latter. */
2241 if (Is_Packed_Array_Type (gnat_entity)
2242 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2244 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2245 for (index = array_dim - 1; index >= 0; index--)
2246 gnu_type = TREE_TYPE (gnu_type);
2248 /* One of the above calls might have caused us to be elaborated,
2249 so don't blow up if so. */
2250 if (present_gnu_tree (gnat_entity))
2252 maybe_present = true;
2258 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
2260 /* One of the above calls might have caused us to be elaborated,
2261 so don't blow up if so. */
2262 if (present_gnu_tree (gnat_entity))
2264 maybe_present = true;
2268 /* Try to get a smaller form of the component if needed. */
2269 if ((Is_Packed (gnat_entity)
2270 || Has_Component_Size_Clause (gnat_entity))
2271 && !Is_Bit_Packed_Array (gnat_entity)
2272 && !Has_Aliased_Components (gnat_entity)
2273 && !Strict_Alignment (Component_Type (gnat_entity))
2274 && TREE_CODE (gnu_type) == RECORD_TYPE
2275 && host_integerp (TYPE_SIZE (gnu_type), 1))
2276 gnu_type = make_packable_type (gnu_type, false);
2278 /* Get and validate any specified Component_Size, but if Packed,
2279 ignore it since the front end will have taken care of it. */
2281 = validate_size (Component_Size (gnat_entity), gnu_type,
2283 (Is_Bit_Packed_Array (gnat_entity)
2284 ? TYPE_DECL : VAR_DECL), true,
2285 Has_Component_Size_Clause (gnat_entity));
2287 /* If the component type is a RECORD_TYPE that has a
2288 self-referential size, use the maxium size. */
2290 && TREE_CODE (gnu_type) == RECORD_TYPE
2291 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2292 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
2294 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
2298 = make_type_from_size (gnu_type, gnu_comp_size, false);
2299 orig_gnu_type = gnu_type;
2300 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
2301 gnat_entity, "C_PAD", false,
2303 /* If a padding record was made, declare it now since it
2304 will never be declared otherwise. This is necessary
2305 to ensure that its subtrees are properly marked. */
2306 if (gnu_type != orig_gnu_type)
2307 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL,
2308 true, false, gnat_entity);
2311 if (Has_Volatile_Components (Base_Type (gnat_entity)))
2312 gnu_type = build_qualified_type (gnu_type,
2313 (TYPE_QUALS (gnu_type)
2314 | TYPE_QUAL_VOLATILE));
2317 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2318 TYPE_SIZE_UNIT (gnu_type));
2319 gnu_max_size = size_binop (MULT_EXPR,
2320 convert (bitsizetype, gnu_max_size),
2321 TYPE_SIZE (gnu_type));
2323 for (index = array_dim - 1; index >= 0; index --)
2325 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
2326 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2327 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2328 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2331 /* If we are at file level and this is a multi-dimensional array, we
2332 need to make a variable corresponding to the stride of the
2333 inner dimensions. */
2334 if (global_bindings_p () && array_dim > 1)
2336 tree gnu_str_name = get_identifier ("ST");
2339 for (gnu_arr_type = TREE_TYPE (gnu_type);
2340 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2341 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2342 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
2344 tree eltype = TREE_TYPE (gnu_arr_type);
2346 TYPE_SIZE (gnu_arr_type)
2347 = elaborate_expression_1 (gnat_entity, gnat_entity,
2348 TYPE_SIZE (gnu_arr_type),
2349 gnu_str_name, definition, 0);
2351 /* ??? For now, store the size as a multiple of the
2352 alignment of the element type in bytes so that we
2353 can see the alignment from the tree. */
2354 TYPE_SIZE_UNIT (gnu_arr_type)
2356 (MULT_EXPR, sizetype,
2357 elaborate_expression_1
2358 (gnat_entity, gnat_entity,
2359 build_binary_op (EXACT_DIV_EXPR, sizetype,
2360 TYPE_SIZE_UNIT (gnu_arr_type),
2361 size_int (TYPE_ALIGN (eltype)
2363 concat_id_with_name (gnu_str_name, "A_U"),
2365 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2367 /* ??? create_type_decl is not invoked on the inner types so
2368 the MULT_EXPR node built above will never be marked. */
2369 mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type));
2373 /* If we need to write out a record type giving the names of
2374 the bounds, do it now. */
2375 if (need_index_type_struct && debug_info_p)
2377 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
2378 tree gnu_field_list = NULL_TREE;
2381 TYPE_NAME (gnu_bound_rec_type)
2382 = create_concat_name (gnat_entity, "XA");
2384 for (index = array_dim - 1; index >= 0; index--)
2387 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2389 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2390 gnu_type_name = DECL_NAME (gnu_type_name);
2392 gnu_field = create_field_decl (gnu_type_name,
2395 0, NULL_TREE, NULL_TREE, 0);
2396 TREE_CHAIN (gnu_field) = gnu_field_list;
2397 gnu_field_list = gnu_field;
2400 finish_record_type (gnu_bound_rec_type, gnu_field_list,
2403 TYPE_STUB_DECL (gnu_type)
2404 = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
2407 (TYPE_STUB_DECL (gnu_type), gnu_bound_rec_type);
2410 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2411 = (Convention (gnat_entity) == Convention_Fortran);
2412 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2413 = (Is_Packed_Array_Type (gnat_entity)
2414 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2416 /* If our size depends on a placeholder and the maximum size doesn't
2417 overflow, use it. */
2418 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2419 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2420 && TREE_OVERFLOW (gnu_max_size))
2421 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2422 && TREE_OVERFLOW (gnu_max_size_unit))
2425 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2426 TYPE_SIZE (gnu_type));
2427 TYPE_SIZE_UNIT (gnu_type)
2428 = size_binop (MIN_EXPR, gnu_max_size_unit,
2429 TYPE_SIZE_UNIT (gnu_type));
2432 /* Set our alias set to that of our base type. This gives all
2433 array subtypes the same alias set. */
2434 copy_alias_set (gnu_type, gnu_base_type);
2437 /* If this is a packed type, make this type the same as the packed
2438 array type, but do some adjusting in the type first. */
2440 if (Present (Packed_Array_Type (gnat_entity)))
2442 Entity_Id gnat_index;
2443 tree gnu_inner_type;
2445 /* First finish the type we had been making so that we output
2446 debugging information for it */
2448 = build_qualified_type (gnu_type,
2449 (TYPE_QUALS (gnu_type)
2450 | (TYPE_QUAL_VOLATILE
2451 * Treat_As_Volatile (gnat_entity))));
2452 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2453 !Comes_From_Source (gnat_entity),
2454 debug_info_p, gnat_entity);
2455 if (!Comes_From_Source (gnat_entity))
2456 DECL_ARTIFICIAL (gnu_decl) = 1;
2458 /* Save it as our equivalent in case the call below elaborates
2460 save_gnu_tree (gnat_entity, gnu_decl, false);
2462 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2464 this_made_decl = true;
2465 gnu_type = TREE_TYPE (gnu_decl);
2466 save_gnu_tree (gnat_entity, NULL_TREE, false);
2468 gnu_inner_type = gnu_type;
2469 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2470 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
2471 || TYPE_IS_PADDING_P (gnu_inner_type)))
2472 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2474 /* We need to point the type we just made to our index type so
2475 the actual bounds can be put into a template. */
2477 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2478 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
2479 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2480 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2482 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2484 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2485 If it is, we need to make another type. */
2486 if (TYPE_MODULAR_P (gnu_inner_type))
2490 gnu_subtype = make_node (INTEGER_TYPE);
2492 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2493 TYPE_MIN_VALUE (gnu_subtype)
2494 = TYPE_MIN_VALUE (gnu_inner_type);
2495 TYPE_MAX_VALUE (gnu_subtype)
2496 = TYPE_MAX_VALUE (gnu_inner_type);
2497 TYPE_PRECISION (gnu_subtype)
2498 = TYPE_PRECISION (gnu_inner_type);
2499 TYPE_UNSIGNED (gnu_subtype)
2500 = TYPE_UNSIGNED (gnu_inner_type);
2501 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2502 layout_type (gnu_subtype);
2504 gnu_inner_type = gnu_subtype;
2507 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2510 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2512 for (gnat_index = First_Index (gnat_entity);
2513 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2514 SET_TYPE_ACTUAL_BOUNDS
2516 tree_cons (NULL_TREE,
2517 get_unpadded_type (Etype (gnat_index)),
2518 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2520 if (Convention (gnat_entity) != Convention_Fortran)
2521 SET_TYPE_ACTUAL_BOUNDS
2523 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2525 if (TREE_CODE (gnu_type) == RECORD_TYPE
2526 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2527 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2531 /* Abort if packed array with no packed array type field set. */
2533 gcc_assert (!Is_Packed (gnat_entity));
2537 case E_String_Literal_Subtype:
2538 /* Create the type for a string literal. */
2540 Entity_Id gnat_full_type
2541 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2542 && Present (Full_View (Etype (gnat_entity)))
2543 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2544 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2545 tree gnu_string_array_type
2546 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2547 tree gnu_string_index_type
2548 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2549 (TYPE_DOMAIN (gnu_string_array_type))));
2550 tree gnu_lower_bound
2551 = convert (gnu_string_index_type,
2552 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2553 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2554 tree gnu_length = ssize_int (length - 1);
2555 tree gnu_upper_bound
2556 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2558 convert (gnu_string_index_type, gnu_length));
2560 = build_range_type (gnu_string_index_type,
2561 gnu_lower_bound, gnu_upper_bound);
2563 = create_index_type (convert (sizetype,
2564 TYPE_MIN_VALUE (gnu_range_type)),
2566 TYPE_MAX_VALUE (gnu_range_type)),
2567 gnu_range_type, gnat_entity);
2570 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2572 copy_alias_set (gnu_type, gnu_string_type);
2576 /* Record Types and Subtypes
2578 The following fields are defined on record types:
2580 Has_Discriminants True if the record has discriminants
2581 First_Discriminant Points to head of list of discriminants
2582 First_Entity Points to head of list of fields
2583 Is_Tagged_Type True if the record is tagged
2585 Implementation of Ada records and discriminated records:
2587 A record type definition is transformed into the equivalent of a C
2588 struct definition. The fields that are the discriminants which are
2589 found in the Full_Type_Declaration node and the elements of the
2590 Component_List found in the Record_Type_Definition node. The
2591 Component_List can be a recursive structure since each Variant of
2592 the Variant_Part of the Component_List has a Component_List.
2594 Processing of a record type definition comprises starting the list of
2595 field declarations here from the discriminants and the calling the
2596 function components_to_record to add the rest of the fields from the
2597 component list and return the gnu type node. The function
2598 components_to_record will call itself recursively as it traverses
2602 if (Has_Complex_Representation (gnat_entity))
2605 = build_complex_type
2607 (Etype (Defining_Entity
2608 (First (Component_Items
2611 (Declaration_Node (gnat_entity)))))))));
2617 Node_Id full_definition = Declaration_Node (gnat_entity);
2618 Node_Id record_definition = Type_Definition (full_definition);
2619 Entity_Id gnat_field;
2621 tree gnu_field_list = NULL_TREE;
2622 tree gnu_get_parent;
2623 /* Set PACKED in keeping with gnat_to_gnu_field. */
2625 = Is_Packed (gnat_entity)
2627 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2629 : (Known_Alignment (gnat_entity)
2630 || (Strict_Alignment (gnat_entity)
2631 && Known_Static_Esize (gnat_entity)))
2634 bool has_rep = Has_Specified_Layout (gnat_entity);
2635 bool all_rep = has_rep;
2637 = (Is_Tagged_Type (gnat_entity)
2638 && Nkind (record_definition) == N_Derived_Type_Definition);
2640 /* See if all fields have a rep clause. Stop when we find one
2642 for (gnat_field = First_Entity (gnat_entity);
2643 Present (gnat_field) && all_rep;
2644 gnat_field = Next_Entity (gnat_field))
2645 if ((Ekind (gnat_field) == E_Component
2646 || Ekind (gnat_field) == E_Discriminant)
2647 && No (Component_Clause (gnat_field)))
2650 /* If this is a record extension, go a level further to find the
2651 record definition. Also, verify we have a Parent_Subtype. */
2654 if (!type_annotate_only
2655 || Present (Record_Extension_Part (record_definition)))
2656 record_definition = Record_Extension_Part (record_definition);
2658 gcc_assert (type_annotate_only
2659 || Present (Parent_Subtype (gnat_entity)));
2662 /* Make a node for the record. If we are not defining the record,
2663 suppress expanding incomplete types. */
2664 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2665 TYPE_NAME (gnu_type) = gnu_entity_id;
2666 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2669 defer_incomplete_level++, this_deferred = true;
2671 /* If both a size and rep clause was specified, put the size in
2672 the record type now so that it can get the proper mode. */
2673 if (has_rep && Known_Esize (gnat_entity))
2674 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2676 /* Always set the alignment here so that it can be used to
2677 set the mode, if it is making the alignment stricter. If
2678 it is invalid, it will be checked again below. If this is to
2679 be Atomic, choose a default alignment of a word unless we know
2680 the size and it's smaller. */
2681 if (Known_Alignment (gnat_entity))
2682 TYPE_ALIGN (gnu_type)
2683 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2684 else if (Is_Atomic (gnat_entity))
2685 TYPE_ALIGN (gnu_type)
2686 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2687 /* If a type needs strict alignment, the minimum size will be the
2688 type size instead of the RM size (see validate_size). Cap the
2689 alignment, lest it causes this type size to become too large. */
2690 else if (Strict_Alignment (gnat_entity)
2691 && Known_Static_Esize (gnat_entity))
2693 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2694 unsigned int raw_align = raw_size & -raw_size;
2695 if (raw_align < BIGGEST_ALIGNMENT)
2696 TYPE_ALIGN (gnu_type) = raw_align;
2699 TYPE_ALIGN (gnu_type) = 0;
2701 /* If we have a Parent_Subtype, make a field for the parent. If
2702 this record has rep clauses, force the position to zero. */
2703 if (Present (Parent_Subtype (gnat_entity)))
2705 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2708 /* A major complexity here is that the parent subtype will
2709 reference our discriminants in its Discriminant_Constraint
2710 list. But those must reference the parent component of this
2711 record which is of the parent subtype we have not built yet!
2712 To break the circle we first build a dummy COMPONENT_REF which
2713 represents the "get to the parent" operation and initialize
2714 each of those discriminants to a COMPONENT_REF of the above
2715 dummy parent referencing the corresponding discriminant of the
2716 base type of the parent subtype. */
2717 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2718 build0 (PLACEHOLDER_EXPR, gnu_type),
2719 build_decl (FIELD_DECL, NULL_TREE,
2723 if (Has_Discriminants (gnat_entity))
2724 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2725 Present (gnat_field);
2726 gnat_field = Next_Stored_Discriminant (gnat_field))
2727 if (Present (Corresponding_Discriminant (gnat_field)))
2730 build3 (COMPONENT_REF,
2731 get_unpadded_type (Etype (gnat_field)),
2733 gnat_to_gnu_field_decl (Corresponding_Discriminant
2738 /* Then we build the parent subtype. */
2739 gnu_parent = gnat_to_gnu_type (gnat_parent);
2741 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2742 initially built. The discriminants must reference the fields
2743 of the parent subtype and not those of its base type for the
2744 placeholder machinery to properly work. */
2745 if (Has_Discriminants (gnat_entity))
2746 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2747 Present (gnat_field);
2748 gnat_field = Next_Stored_Discriminant (gnat_field))
2749 if (Present (Corresponding_Discriminant (gnat_field)))
2751 Entity_Id field = Empty;
2752 for (field = First_Stored_Discriminant (gnat_parent);
2754 field = Next_Stored_Discriminant (field))
2755 if (same_discriminant_p (gnat_field, field))
2757 gcc_assert (Present (field));
2758 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2759 = gnat_to_gnu_field_decl (field);
2762 /* The "get to the parent" COMPONENT_REF must be given its
2764 TREE_TYPE (gnu_get_parent) = gnu_parent;
2766 /* ...and reference the _parent field of this record. */
2768 = create_field_decl (get_identifier
2769 (Get_Name_String (Name_uParent)),
2770 gnu_parent, gnu_type, 0,
2771 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2772 has_rep ? bitsize_zero_node : 0, 1);
2773 DECL_INTERNAL_P (gnu_field_list) = 1;
2774 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2777 /* Make the fields for the discriminants and put them into the record
2778 unless it's an Unchecked_Union. */
2779 if (Has_Discriminants (gnat_entity))
2780 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2781 Present (gnat_field);
2782 gnat_field = Next_Stored_Discriminant (gnat_field))
2784 /* If this is a record extension and this discriminant
2785 is the renaming of another discriminant, we've already
2786 handled the discriminant above. */
2787 if (Present (Parent_Subtype (gnat_entity))
2788 && Present (Corresponding_Discriminant (gnat_field)))
2792 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2794 /* Make an expression using a PLACEHOLDER_EXPR from the
2795 FIELD_DECL node just created and link that with the
2796 corresponding GNAT defining identifier. Then add to the
2798 save_gnu_tree (gnat_field,
2799 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2800 build0 (PLACEHOLDER_EXPR,
2801 DECL_CONTEXT (gnu_field)),
2802 gnu_field, NULL_TREE),
2805 if (!Is_Unchecked_Union (gnat_entity))
2807 TREE_CHAIN (gnu_field) = gnu_field_list;
2808 gnu_field_list = gnu_field;
2812 /* Put the discriminants into the record (backwards), so we can
2813 know the appropriate discriminant to use for the names of the
2815 TYPE_FIELDS (gnu_type) = gnu_field_list;
2817 /* Add the listed fields into the record and finish it up. */
2818 components_to_record (gnu_type, Component_List (record_definition),
2819 gnu_field_list, packed, definition, NULL,
2820 false, all_rep, false,
2821 Is_Unchecked_Union (gnat_entity));
2823 /* We used to remove the associations of the discriminants and
2824 _Parent for validity checking, but we may need them if there's
2825 Freeze_Node for a subtype used in this record. */
2826 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2827 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2829 /* If it is a tagged record force the type to BLKmode to insure
2830 that these objects will always be placed in memory. Do the
2831 same thing for limited record types. */
2832 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2833 TYPE_MODE (gnu_type) = BLKmode;
2835 /* If this is a derived type, we must make the alias set of this type
2836 the same as that of the type we are derived from. We assume here
2837 that the other type is already frozen. */
2838 if (Etype (gnat_entity) != gnat_entity
2839 && !(Is_Private_Type (Etype (gnat_entity))
2840 && Full_View (Etype (gnat_entity)) == gnat_entity))
2841 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2843 /* Fill in locations of fields. */
2844 annotate_rep (gnat_entity, gnu_type);
2846 /* If there are any entities in the chain corresponding to
2847 components that we did not elaborate, ensure we elaborate their
2848 types if they are Itypes. */
2849 for (gnat_temp = First_Entity (gnat_entity);
2850 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2851 if ((Ekind (gnat_temp) == E_Component
2852 || Ekind (gnat_temp) == E_Discriminant)
2853 && Is_Itype (Etype (gnat_temp))
2854 && !present_gnu_tree (gnat_temp))
2855 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2859 case E_Class_Wide_Subtype:
2860 /* If an equivalent type is present, that is what we should use.
2861 Otherwise, fall through to handle this like a record subtype
2862 since it may have constraints. */
2863 if (gnat_equiv_type != gnat_entity)
2865 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2866 maybe_present = true;
2870 /* ... fall through ... */
2872 case E_Record_Subtype:
2874 /* If Cloned_Subtype is Present it means this record subtype has
2875 identical layout to that type or subtype and we should use
2876 that GCC type for this one. The front end guarantees that
2877 the component list is shared. */
2878 if (Present (Cloned_Subtype (gnat_entity)))
2880 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2882 maybe_present = true;
2885 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2886 changing the type, make a new type with each field having the
2887 type of the field in the new subtype but having the position
2888 computed by transforming every discriminant reference according
2889 to the constraints. We don't see any difference between
2890 private and nonprivate type here since derivations from types should
2891 have been deferred until the completion of the private type. */
2894 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2899 defer_incomplete_level++, this_deferred = true;
2901 /* Get the base type initially for its alignment and sizes. But
2902 if it is a padded type, we do all the other work with the
2904 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2906 if (TREE_CODE (gnu_base_type) == RECORD_TYPE
2907 && TYPE_IS_PADDING_P (gnu_base_type))
2908 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2910 gnu_type = gnu_orig_type = gnu_base_type;
2912 if (present_gnu_tree (gnat_entity))
2914 maybe_present = true;
2918 /* When the type has discriminants, and these discriminants
2919 affect the shape of what it built, factor them in.
2921 If we are making a subtype of an Unchecked_Union (must be an
2922 Itype), just return the type.
2924 We can't just use Is_Constrained because private subtypes without
2925 discriminants of full types with discriminants with default
2926 expressions are Is_Constrained but aren't constrained! */
2928 if (IN (Ekind (gnat_base_type), Record_Kind)
2929 && !Is_For_Access_Subtype (gnat_entity)
2930 && !Is_Unchecked_Union (gnat_base_type)
2931 && Is_Constrained (gnat_entity)
2932 && Stored_Constraint (gnat_entity) != No_Elist
2933 && Present (Discriminant_Constraint (gnat_entity)))
2935 Entity_Id gnat_field;
2936 tree gnu_field_list = 0;
2938 = compute_field_positions (gnu_orig_type, NULL_TREE,
2939 size_zero_node, bitsize_zero_node,
2942 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2946 gnu_type = make_node (RECORD_TYPE);
2947 TYPE_NAME (gnu_type) = gnu_entity_id;
2948 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2950 /* Set the size, alignment and alias set of the new type to
2951 match that of the old one, doing required substitutions.
2952 We do it this early because we need the size of the new
2953 type below to discard old fields if necessary. */
2954 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2955 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2956 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2957 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2958 copy_alias_set (gnu_type, gnu_base_type);
2960 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2961 for (gnu_temp = gnu_subst_list;
2962 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2963 TYPE_SIZE (gnu_type)
2964 = substitute_in_expr (TYPE_SIZE (gnu_type),
2965 TREE_PURPOSE (gnu_temp),
2966 TREE_VALUE (gnu_temp));
2968 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2969 for (gnu_temp = gnu_subst_list;
2970 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2971 TYPE_SIZE_UNIT (gnu_type)
2972 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2973 TREE_PURPOSE (gnu_temp),
2974 TREE_VALUE (gnu_temp));
2976 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2977 for (gnu_temp = gnu_subst_list;
2978 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2980 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2981 TREE_PURPOSE (gnu_temp),
2982 TREE_VALUE (gnu_temp)));
2984 for (gnat_field = First_Entity (gnat_entity);
2985 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2986 if ((Ekind (gnat_field) == E_Component
2987 || Ekind (gnat_field) == E_Discriminant)
2988 && (Underlying_Type (Scope (Original_Record_Component
2991 && (No (Corresponding_Discriminant (gnat_field))
2992 || !Is_Tagged_Type (gnat_base_type)))
2995 = gnat_to_gnu_field_decl (Original_Record_Component
2998 = TREE_VALUE (purpose_member (gnu_old_field,
3000 tree gnu_pos = TREE_PURPOSE (gnu_offset);
3001 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
3003 = gnat_to_gnu_type (Etype (gnat_field));
3004 tree gnu_size = TYPE_SIZE (gnu_field_type);
3005 tree gnu_new_pos = NULL_TREE;
3006 unsigned int offset_align
3007 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
3011 /* If there was a component clause, the field types must be
3012 the same for the type and subtype, so copy the data from
3013 the old field to avoid recomputation here. Also if the
3014 field is justified modular and the optimization in
3015 gnat_to_gnu_field was applied. */
3016 if (Present (Component_Clause
3017 (Original_Record_Component (gnat_field)))
3018 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3019 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3020 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3021 == TREE_TYPE (gnu_old_field)))
3023 gnu_size = DECL_SIZE (gnu_old_field);
3024 gnu_field_type = TREE_TYPE (gnu_old_field);
3027 /* If the old field was packed and of constant size, we
3028 have to get the old size here, as it might differ from
3029 what the Etype conveys and the latter might overlap
3030 onto the following field. Try to arrange the type for
3031 possible better packing along the way. */
3032 else if (DECL_PACKED (gnu_old_field)
3033 && TREE_CODE (DECL_SIZE (gnu_old_field))
3036 gnu_size = DECL_SIZE (gnu_old_field);
3037 if (TYPE_MODE (gnu_field_type) == BLKmode
3038 && TREE_CODE (gnu_field_type) == RECORD_TYPE
3039 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3041 = make_packable_type (gnu_field_type, true);
3044 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
3045 for (gnu_temp = gnu_subst_list;
3046 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3047 gnu_pos = substitute_in_expr (gnu_pos,
3048 TREE_PURPOSE (gnu_temp),
3049 TREE_VALUE (gnu_temp));
3051 /* If the position is now a constant, we can set it as the
3052 position of the field when we make it. Otherwise, we need
3053 to deal with it specially below. */
3054 if (TREE_CONSTANT (gnu_pos))
3056 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
3058 /* Discard old fields that are outside the new type.
3059 This avoids confusing code scanning it to decide
3060 how to pass it to functions on some platforms. */
3061 if (TREE_CODE (gnu_new_pos) == INTEGER_CST
3062 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
3063 && !integer_zerop (gnu_size)
3064 && !tree_int_cst_lt (gnu_new_pos,
3065 TYPE_SIZE (gnu_type)))
3071 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
3072 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
3073 !DECL_NONADDRESSABLE_P (gnu_old_field));
3075 if (!TREE_CONSTANT (gnu_pos))
3077 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
3078 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
3079 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
3080 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
3081 DECL_SIZE (gnu_field) = gnu_size;
3082 DECL_SIZE_UNIT (gnu_field)
3083 = convert (sizetype,
3084 size_binop (CEIL_DIV_EXPR, gnu_size,
3085 bitsize_unit_node));
3086 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
3089 DECL_INTERNAL_P (gnu_field)
3090 = DECL_INTERNAL_P (gnu_old_field);
3091 SET_DECL_ORIGINAL_FIELD
3092 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
3093 ? DECL_ORIGINAL_FIELD (gnu_old_field)
3095 DECL_DISCRIMINANT_NUMBER (gnu_field)
3096 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
3097 TREE_THIS_VOLATILE (gnu_field)
3098 = TREE_THIS_VOLATILE (gnu_old_field);
3099 TREE_CHAIN (gnu_field) = gnu_field_list;
3100 gnu_field_list = gnu_field;
3101 save_gnu_tree (gnat_field, gnu_field, false);
3104 /* Now go through the entities again looking for Itypes that
3105 we have not elaborated but should (e.g., Etypes of fields
3106 that have Original_Components). */
3107 for (gnat_field = First_Entity (gnat_entity);
3108 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3109 if ((Ekind (gnat_field) == E_Discriminant
3110 || Ekind (gnat_field) == E_Component)
3111 && !present_gnu_tree (Etype (gnat_field)))
3112 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3114 /* Do not finalize it since we're going to modify it below. */
3115 gnu_field_list = nreverse (gnu_field_list);
3116 finish_record_type (gnu_type, gnu_field_list, 2, true);
3118 /* Finalize size and mode. */
3119 TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
3120 TYPE_SIZE_UNIT (gnu_type)
3121 = variable_size (TYPE_SIZE_UNIT (gnu_type));
3123 compute_record_mode (gnu_type);
3125 /* Fill in locations of fields. */
3126 annotate_rep (gnat_entity, gnu_type);
3128 /* We've built a new type, make an XVS type to show what this
3129 is a subtype of. Some debuggers require the XVS type to be
3130 output first, so do it in that order. */
3133 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3134 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
3136 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
3137 gnu_orig_name = DECL_NAME (gnu_orig_name);
3139 TYPE_NAME (gnu_subtype_marker)
3140 = create_concat_name (gnat_entity, "XVS");
3141 finish_record_type (gnu_subtype_marker,
3142 create_field_decl (gnu_orig_name,
3149 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3150 gnu_subtype_marker);
3153 /* Now we can finalize it. */
3154 rest_of_record_type_compilation (gnu_type);
3157 /* Otherwise, go down all the components in the new type and
3158 make them equivalent to those in the base type. */
3160 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3161 gnat_temp = Next_Entity (gnat_temp))
3162 if ((Ekind (gnat_temp) == E_Discriminant
3163 && !Is_Unchecked_Union (gnat_base_type))
3164 || Ekind (gnat_temp) == E_Component)
3165 save_gnu_tree (gnat_temp,
3166 gnat_to_gnu_field_decl
3167 (Original_Record_Component (gnat_temp)), false);
3171 case E_Access_Subprogram_Type:
3172 /* Use the special descriptor type for dispatch tables if needed,
3173 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3174 Note that we are only required to do so for static tables in
3175 order to be compatible with the C++ ABI, but Ada 2005 allows
3176 to extend library level tagged types at the local level so
3177 we do it in the non-static case as well. */
3178 if (TARGET_VTABLE_USES_DESCRIPTORS
3179 && Is_Dispatch_Table_Entity (gnat_entity))
3181 gnu_type = fdesc_type_node;
3182 gnu_size = TYPE_SIZE (gnu_type);
3186 /* ... fall through ... */
3188 case E_Anonymous_Access_Subprogram_Type:
3189 /* If we are not defining this entity, and we have incomplete
3190 entities being processed above us, make a dummy type and
3191 fill it in later. */
3192 if (!definition && defer_incomplete_level != 0)
3194 struct incomplete *p
3195 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3198 = build_pointer_type
3199 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3200 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3201 !Comes_From_Source (gnat_entity),
3202 debug_info_p, gnat_entity);
3203 this_made_decl = true;
3204 gnu_type = TREE_TYPE (gnu_decl);
3205 save_gnu_tree (gnat_entity, gnu_decl, false);
3208 p->old_type = TREE_TYPE (gnu_type);
3209 p->full_type = Directly_Designated_Type (gnat_entity);
3210 p->next = defer_incomplete_list;
3211 defer_incomplete_list = p;
3215 /* ... fall through ... */
3217 case E_Allocator_Type:
3219 case E_Access_Attribute_Type:
3220 case E_Anonymous_Access_Type:
3221 case E_General_Access_Type:
3223 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3224 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3225 bool is_from_limited_with
3226 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3227 && From_With_Type (gnat_desig_equiv));
3229 /* Get the "full view" of this entity. If this is an incomplete
3230 entity from a limited with, treat its non-limited view as the full
3231 view. Otherwise, if this is an incomplete or private type, use the
3232 full view. In the former case, we might point to a private type,
3233 in which case, we need its full view. Also, we want to look at the
3234 actual type used for the representation, so this takes a total of
3236 Entity_Id gnat_desig_full_direct_first
3237 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3238 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3239 ? Full_View (gnat_desig_equiv) : Empty));
3240 Entity_Id gnat_desig_full_direct
3241 = ((is_from_limited_with
3242 && Present (gnat_desig_full_direct_first)
3243 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3244 ? Full_View (gnat_desig_full_direct_first)
3245 : gnat_desig_full_direct_first);
3246 Entity_Id gnat_desig_full
3247 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3249 /* This the type actually used to represent the designated type,
3250 either gnat_desig_full or gnat_desig_equiv. */
3251 Entity_Id gnat_desig_rep;
3253 /* Nonzero if this is a pointer to an unconstrained array. */
3254 bool is_unconstrained_array;
3256 /* We want to know if we'll be seeing the freeze node for any
3257 incomplete type we may be pointing to. */
3259 = (Present (gnat_desig_full)
3260 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3261 : In_Extended_Main_Code_Unit (gnat_desig_type));
3263 /* Nonzero if we make a dummy type here. */
3264 bool got_fat_p = false;
3265 /* Nonzero if the dummy is a fat pointer. */
3266 bool made_dummy = false;
3267 tree gnu_desig_type = NULL_TREE;
3268 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3270 if (!targetm.valid_pointer_mode (p_mode))
3273 /* If either the designated type or its full view is an unconstrained
3274 array subtype, replace it with the type it's a subtype of. This
3275 avoids problems with multiple copies of unconstrained array types.
3276 Likewise, if the designated type is a subtype of an incomplete
3277 record type, use the parent type to avoid order of elaboration
3278 issues. This can lose some code efficiency, but there is no
3280 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3281 && ! Is_Constrained (gnat_desig_equiv))
3282 gnat_desig_equiv = Etype (gnat_desig_equiv);
3283 if (Present (gnat_desig_full)
3284 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3285 && ! Is_Constrained (gnat_desig_full))
3286 || (Ekind (gnat_desig_full) == E_Record_Subtype
3287 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3288 gnat_desig_full = Etype (gnat_desig_full);
3290 /* Now set the type that actually marks the representation of
3291 the designated type and also flag whether we have a unconstrained
3293 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3294 is_unconstrained_array
3295 = (Is_Array_Type (gnat_desig_rep)
3296 && ! Is_Constrained (gnat_desig_rep));
3298 /* If we are pointing to an incomplete type whose completion is an
3299 unconstrained array, make a fat pointer type. The two types in our
3300 fields will be pointers to dummy nodes and will be replaced in
3301 update_pointer_to. Similarly, if the type itself is a dummy type or
3302 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3303 in case we have any thin pointers to it. */
3304 if (is_unconstrained_array
3305 && (Present (gnat_desig_full)
3306 || (present_gnu_tree (gnat_desig_equiv)
3307 && TYPE_IS_DUMMY_P (TREE_TYPE
3308 (get_gnu_tree (gnat_desig_equiv))))
3309 || (No (gnat_desig_full) && ! in_main_unit
3310 && defer_incomplete_level != 0
3311 && ! present_gnu_tree (gnat_desig_equiv))
3312 || (in_main_unit && is_from_limited_with
3313 && Present (Freeze_Node (gnat_desig_rep)))))
3316 = (present_gnu_tree (gnat_desig_rep)
3317 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
3318 : make_dummy_type (gnat_desig_rep));
3321 /* Show the dummy we get will be a fat pointer. */
3322 got_fat_p = made_dummy = true;
3324 /* If the call above got something that has a pointer, that
3325 pointer is our type. This could have happened either
3326 because the type was elaborated or because somebody
3327 else executed the code below. */
3328 gnu_type = TYPE_POINTER_TO (gnu_old);
3331 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3332 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3333 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3334 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3336 TYPE_NAME (gnu_template_type)
3337 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3339 TYPE_DUMMY_P (gnu_template_type) = 1;
3341 TYPE_NAME (gnu_array_type)
3342 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3344 TYPE_DUMMY_P (gnu_array_type) = 1;
3346 gnu_type = make_node (RECORD_TYPE);
3347 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3348 TYPE_POINTER_TO (gnu_old) = gnu_type;
3350 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3352 = chainon (chainon (NULL_TREE,
3354 (get_identifier ("P_ARRAY"),
3356 gnu_type, 0, 0, 0, 0)),
3357 create_field_decl (get_identifier ("P_BOUNDS"),
3359 gnu_type, 0, 0, 0, 0));
3361 /* Make sure we can place this into a register. */
3362 TYPE_ALIGN (gnu_type)
3363 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3364 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
3366 /* Do not finalize this record type since the types of
3367 its fields are incomplete. */
3368 finish_record_type (gnu_type, fields, 0, true);
3370 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3371 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3372 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3374 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3378 /* If we already know what the full type is, use it. */
3379 else if (Present (gnat_desig_full)
3380 && present_gnu_tree (gnat_desig_full))
3381 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3383 /* Get the type of the thing we are to point to and build a pointer
3384 to it. If it is a reference to an incomplete or private type with a
3385 full view that is a record, make a dummy type node and get the
3386 actual type later when we have verified it is safe. */
3387 else if ((! in_main_unit
3388 && ! present_gnu_tree (gnat_desig_equiv)
3389 && Present (gnat_desig_full)
3390 && ! present_gnu_tree (gnat_desig_full)
3391 && Is_Record_Type (gnat_desig_full))
3392 /* Likewise if we are pointing to a record or array and we
3393 are to defer elaborating incomplete types. We do this
3394 since this access type may be the full view of some
3395 private type. Note that the unconstrained array case is
3397 || ((! in_main_unit || imported_p)
3398 && defer_incomplete_level != 0
3399 && ! present_gnu_tree (gnat_desig_equiv)
3400 && ((Is_Record_Type (gnat_desig_rep)
3401 || Is_Array_Type (gnat_desig_rep))))
3402 /* If this is a reference from a limited_with type back to our
3403 main unit and there's a Freeze_Node for it, either we have
3404 already processed the declaration and made the dummy type,
3405 in which case we just reuse the latter, or we have not yet,
3406 in which case we make the dummy type and it will be reused
3407 when the declaration is processed. In both cases, the
3408 pointer eventually created below will be automatically
3409 adjusted when the Freeze_Node is processed. Note that the
3410 unconstrained array case is handled above. */
3411 || (in_main_unit && is_from_limited_with
3412 && Present (Freeze_Node (gnat_desig_rep))))
3414 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3418 /* Otherwise handle the case of a pointer to itself. */
3419 else if (gnat_desig_equiv == gnat_entity)
3422 = build_pointer_type_for_mode (void_type_node, p_mode,
3423 No_Strict_Aliasing (gnat_entity));
3424 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3427 /* If expansion is disabled, the equivalent type of a concurrent
3428 type is absent, so build a dummy pointer type. */
3429 else if (type_annotate_only && No (gnat_desig_equiv))
3430 gnu_type = ptr_void_type_node;
3432 /* Finally, handle the straightforward case where we can just
3433 elaborate our designated type and point to it. */
3435 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3437 /* It is possible that a call to gnat_to_gnu_type above resolved our
3438 type. If so, just return it. */
3439 if (present_gnu_tree (gnat_entity))
3441 maybe_present = true;
3445 /* If we have a GCC type for the designated type, possibly modify it
3446 if we are pointing only to constant objects and then make a pointer
3447 to it. Don't do this for unconstrained arrays. */
3448 if (!gnu_type && gnu_desig_type)
3450 if (Is_Access_Constant (gnat_entity)
3451 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3454 = build_qualified_type
3456 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3458 /* Some extra processing is required if we are building a
3459 pointer to an incomplete type (in the GCC sense). We might
3460 have such a type if we just made a dummy, or directly out
3461 of the call to gnat_to_gnu_type above if we are processing
3462 an access type for a record component designating the
3463 record type itself. */
3464 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3466 /* We must ensure that the pointer to variant we make will
3467 be processed by update_pointer_to when the initial type
3468 is completed. Pretend we made a dummy and let further
3469 processing act as usual. */
3472 /* We must ensure that update_pointer_to will not retrieve
3473 the dummy variant when building a properly qualified
3474 version of the complete type. We take advantage of the
3475 fact that get_qualified_type is requiring TYPE_NAMEs to
3476 match to influence build_qualified_type and then also
3477 update_pointer_to here. */
3478 TYPE_NAME (gnu_desig_type)
3479 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3484 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3485 No_Strict_Aliasing (gnat_entity));
3488 /* If we are not defining this object and we made a dummy pointer,
3489 save our current definition, evaluate the actual type, and replace
3490 the tentative type we made with the actual one. If we are to defer
3491 actually looking up the actual type, make an entry in the
3492 deferred list. If this is from a limited with, we have to defer
3493 to the end of the current spec in two cases: first if the
3494 designated type is in the current unit and second if the access
3496 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3499 = TYPE_FAT_POINTER_P (gnu_type)
3500 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3502 if (esize == POINTER_SIZE
3503 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3505 = build_pointer_type
3506 (TYPE_OBJECT_RECORD_TYPE
3507 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3509 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3510 !Comes_From_Source (gnat_entity),
3511 debug_info_p, gnat_entity);
3512 this_made_decl = true;
3513 gnu_type = TREE_TYPE (gnu_decl);
3514 save_gnu_tree (gnat_entity, gnu_decl, false);
3517 if (defer_incomplete_level == 0
3518 && ! (is_from_limited_with
3520 || In_Extended_Main_Code_Unit (gnat_entity))))
3521 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3522 gnat_to_gnu_type (gnat_desig_equiv));
3524 /* Note that the call to gnat_to_gnu_type here might have
3525 updated gnu_old_type directly, in which case it is not a
3526 dummy type any more when we get into update_pointer_to.
3528 This may happen for instance when the designated type is a
3529 record type, because their elaboration starts with an
3530 initial node from make_dummy_type, which may yield the same
3531 node as the one we got.
3533 Besides, variants of this non-dummy type might have been
3534 created along the way. update_pointer_to is expected to
3535 properly take care of those situations. */
3538 struct incomplete *p
3539 = (struct incomplete *) xmalloc (sizeof
3540 (struct incomplete));
3541 struct incomplete **head
3542 = (is_from_limited_with
3544 || In_Extended_Main_Code_Unit (gnat_entity))
3545 ? &defer_limited_with : &defer_incomplete_list);
3547 p->old_type = gnu_old_type;
3548 p->full_type = gnat_desig_equiv;
3556 case E_Access_Protected_Subprogram_Type:
3557 case E_Anonymous_Access_Protected_Subprogram_Type:
3558 if (type_annotate_only && No (gnat_equiv_type))
3559 gnu_type = ptr_void_type_node;
3562 /* The runtime representation is the equivalent type. */
3563 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3567 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3568 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3569 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3570 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3571 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3576 case E_Access_Subtype:
3578 /* We treat this as identical to its base type; any constraint is
3579 meaningful only to the front end.
3581 The designated type must be elaborated as well, if it does
3582 not have its own freeze node. Designated (sub)types created
3583 for constrained components of records with discriminants are
3584 not frozen by the front end and thus not elaborated by gigi,
3585 because their use may appear before the base type is frozen,
3586 and because it is not clear that they are needed anywhere in
3587 Gigi. With the current model, there is no correct place where
3588 they could be elaborated. */
3590 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3591 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3592 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3593 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3594 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3596 /* If we are not defining this entity, and we have incomplete
3597 entities being processed above us, make a dummy type and
3598 elaborate it later. */
3599 if (!definition && defer_incomplete_level != 0)
3601 struct incomplete *p
3602 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3604 = build_pointer_type
3605 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3607 p->old_type = TREE_TYPE (gnu_ptr_type);
3608 p->full_type = Directly_Designated_Type (gnat_entity);
3609 p->next = defer_incomplete_list;
3610 defer_incomplete_list = p;
3612 else if (!IN (Ekind (Base_Type
3613 (Directly_Designated_Type (gnat_entity))),
3614 Incomplete_Or_Private_Kind))
3615 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3619 maybe_present = true;
3622 /* Subprogram Entities
3624 The following access functions are defined for subprograms (functions
3627 First_Formal The first formal parameter.
3628 Is_Imported Indicates that the subprogram has appeared in
3629 an INTERFACE or IMPORT pragma. For now we
3630 assume that the external language is C.
3631 Is_Exported Likewise but for an EXPORT pragma.
3632 Is_Inlined True if the subprogram is to be inlined.
3634 In addition for function subprograms we have:
3636 Etype Return type of the function.
3638 Each parameter is first checked by calling must_pass_by_ref on its
3639 type to determine if it is passed by reference. For parameters which
3640 are copied in, if they are Ada In Out or Out parameters, their return
3641 value becomes part of a record which becomes the return type of the
3642 function (C function - note that this applies only to Ada procedures
3643 so there is no Ada return type). Additional code to store back the
3644 parameters will be generated on the caller side. This transformation
3645 is done here, not in the front-end.
3647 The intended result of the transformation can be seen from the
3648 equivalent source rewritings that follow:
3650 struct temp {int a,b};
3651 procedure P (A,B: In Out ...) is temp P (int A,B)
3654 end P; return {A,B};
3661 For subprogram types we need to perform mainly the same conversions to
3662 GCC form that are needed for procedures and function declarations. The
3663 only difference is that at the end, we make a type declaration instead
3664 of a function declaration. */
3666 case E_Subprogram_Type:
3670 /* The first GCC parameter declaration (a PARM_DECL node). The
3671 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3672 actually is the head of this parameter list. */
3673 tree gnu_param_list = NULL_TREE;
3674 /* Likewise for the stub associated with an exported procedure. */
3675 tree gnu_stub_param_list = NULL_TREE;
3676 /* The type returned by a function. If the subprogram is a procedure
3677 this type should be void_type_node. */
3678 tree gnu_return_type = void_type_node;
3679 /* List of fields in return type of procedure with copy-in copy-out
3681 tree gnu_field_list = NULL_TREE;
3682 /* Non-null for subprograms containing parameters passed by copy-in
3683 copy-out (Ada In Out or Out parameters not passed by reference),
3684 in which case it is the list of nodes used to specify the values of
3685 the in out/out parameters that are returned as a record upon
3686 procedure return. The TREE_PURPOSE of an element of this list is
3687 a field of the record and the TREE_VALUE is the PARM_DECL
3688 corresponding to that field. This list will be saved in the
3689 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3690 tree gnu_return_list = NULL_TREE;
3691 /* If an import pragma asks to map this subprogram to a GCC builtin,
3692 this is the builtin DECL node. */
3693 tree gnu_builtin_decl = NULL_TREE;
3694 /* For the stub associated with an exported procedure. */
3695 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3696 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3697 Entity_Id gnat_param;
3698 bool inline_flag = Is_Inlined (gnat_entity);
3699 bool public_flag = Is_Public (gnat_entity) || imported_p;
3701 = (Is_Public (gnat_entity) && !definition) || imported_p;
3702 bool pure_flag = Is_Pure (gnat_entity);
3703 bool volatile_flag = No_Return (gnat_entity);
3704 bool returns_by_ref = false;
3705 bool returns_unconstrained = false;
3706 bool returns_by_target_ptr = false;
3707 bool has_copy_in_out = false;
3708 bool has_stub = false;
3711 if (kind == E_Subprogram_Type && !definition)
3712 /* A parameter may refer to this type, so defer completion
3713 of any incomplete types. */
3714 defer_incomplete_level++, this_deferred = true;
3716 /* If the subprogram has an alias, it is probably inherited, so
3717 we can use the original one. If the original "subprogram"
3718 is actually an enumeration literal, it may be the first use
3719 of its type, so we must elaborate that type now. */
3720 if (Present (Alias (gnat_entity)))
3722 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3723 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3725 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3728 /* Elaborate any Itypes in the parameters of this entity. */
3729 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3730 Present (gnat_temp);
3731 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3732 if (Is_Itype (Etype (gnat_temp)))
3733 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3738 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3739 corresponding DECL node.
3741 We still want the parameter associations to take place because the
3742 proper generation of calls depends on it (a GNAT parameter without
3743 a corresponding GCC tree has a very specific meaning), so we don't
3745 if (Convention (gnat_entity) == Convention_Intrinsic)
3746 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3748 /* ??? What if we don't find the builtin node above ? warn ? err ?
3749 In the current state we neither warn nor err, and calls will just
3750 be handled as for regular subprograms. */
3752 if (kind == E_Function || kind == E_Subprogram_Type)
3753 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3755 /* If this function returns by reference, make the actual
3756 return type of this function the pointer and mark the decl. */
3757 if (Returns_By_Ref (gnat_entity))
3759 returns_by_ref = true;
3760 gnu_return_type = build_pointer_type (gnu_return_type);
3763 /* If the Mechanism is By_Reference, ensure the return type uses
3764 the machine's by-reference mechanism, which may not the same
3765 as above (e.g., it might be by passing a fake parameter). */
3766 else if (kind == E_Function
3767 && Mechanism (gnat_entity) == By_Reference)
3769 TREE_ADDRESSABLE (gnu_return_type) = 1;
3771 /* We expect this bit to be reset by gigi shortly, so can avoid a
3772 type node copy here. This actually also prevents troubles with
3773 the generation of debug information for the function, because
3774 we might have issued such info for this type already, and would
3775 be attaching a distinct type node to the function if we made a
3779 /* If we are supposed to return an unconstrained array,
3780 actually return a fat pointer and make a note of that. Return
3781 a pointer to an unconstrained record of variable size. */
3782 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3784 gnu_return_type = TREE_TYPE (gnu_return_type);
3785 returns_unconstrained = true;
3788 /* If the type requires a transient scope, the result is allocated
3789 on the secondary stack, so the result type of the function is
3791 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3793 gnu_return_type = build_pointer_type (gnu_return_type);
3794 returns_unconstrained = true;
3797 /* If the type is a padded type and the underlying type would not
3798 be passed by reference or this function has a foreign convention,
3799 return the underlying type. */
3800 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3801 && TYPE_IS_PADDING_P (gnu_return_type)
3802 && (!default_pass_by_ref (TREE_TYPE
3803 (TYPE_FIELDS (gnu_return_type)))
3804 || Has_Foreign_Convention (gnat_entity)))
3805 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3807 /* If the return type has a non-constant size, we convert the function
3808 into a procedure and its caller will pass a pointer to an object as
3809 the first parameter when we call the function. This can happen for
3810 an unconstrained type with a maximum size or a constrained type with
3811 a size not known at compile time. */
3812 if (TYPE_SIZE_UNIT (gnu_return_type)
3813 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3815 returns_by_target_ptr = true;
3817 = create_param_decl (get_identifier ("TARGET"),
3818 build_reference_type (gnu_return_type),
3820 gnu_return_type = void_type_node;
3823 /* If the return type has a size that overflows, we cannot have
3824 a function that returns that type. This usage doesn't make
3825 sense anyway, so give an error here. */
3826 if (TYPE_SIZE_UNIT (gnu_return_type)
3827 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3828 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3830 post_error ("cannot return type whose size overflows",
3832 gnu_return_type = copy_node (gnu_return_type);
3833 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3834 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3835 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3836 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3839 /* Look at all our parameters and get the type of
3840 each. While doing this, build a copy-out structure if
3843 /* Loop over the parameters and get their associated GCC tree.
3844 While doing this, build a copy-out structure if we need one. */
3845 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3846 Present (gnat_param);
3847 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3849 tree gnu_param_name = get_entity_name (gnat_param);
3850 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3851 tree gnu_param, gnu_field;
3852 bool copy_in_copy_out = false;
3853 Mechanism_Type mech = Mechanism (gnat_param);
3855 /* Builtins are expanded inline and there is no real call sequence
3856 involved. So the type expected by the underlying expander is
3857 always the type of each argument "as is". */
3858 if (gnu_builtin_decl)
3860 /* Handle the first parameter of a valued procedure specially. */
3861 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3862 mech = By_Copy_Return;
3863 /* Otherwise, see if a Mechanism was supplied that forced this
3864 parameter to be passed one way or another. */
3865 else if (mech == Default
3866 || mech == By_Copy || mech == By_Reference)
3868 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3869 mech = By_Descriptor;
3872 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3873 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3874 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3876 mech = By_Reference;
3882 post_error ("unsupported mechanism for&", gnat_param);
3887 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
3888 Has_Foreign_Convention (gnat_entity),
3891 /* We are returned either a PARM_DECL or a type if no parameter
3892 needs to be passed; in either case, adjust the type. */
3893 if (DECL_P (gnu_param))
3894 gnu_param_type = TREE_TYPE (gnu_param);
3897 gnu_param_type = gnu_param;
3898 gnu_param = NULL_TREE;
3903 /* If it's an exported subprogram, we build a parameter list
3904 in parallel, in case we need to emit a stub for it. */
3905 if (Is_Exported (gnat_entity))
3908 = chainon (gnu_param, gnu_stub_param_list);
3909 /* Change By_Descriptor parameter to By_Reference for
3910 the internal version of an exported subprogram. */
3911 if (mech == By_Descriptor)
3914 = gnat_to_gnu_param (gnat_param, By_Reference,
3920 gnu_param = copy_node (gnu_param);
3923 gnu_param_list = chainon (gnu_param, gnu_param_list);
3924 Sloc_to_locus (Sloc (gnat_param),
3925 &DECL_SOURCE_LOCATION (gnu_param));
3926 save_gnu_tree (gnat_param, gnu_param, false);
3928 /* If a parameter is a pointer, this function may modify
3929 memory through it and thus shouldn't be considered
3930 a pure function. Also, the memory may be modified
3931 between two calls, so they can't be CSE'ed. The latter
3932 case also handles by-ref parameters. */
3933 if (POINTER_TYPE_P (gnu_param_type)
3934 || TYPE_FAT_POINTER_P (gnu_param_type))
3938 if (copy_in_copy_out)
3940 if (!has_copy_in_out)
3942 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
3943 gnu_return_type = make_node (RECORD_TYPE);
3944 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3945 has_copy_in_out = true;
3948 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3949 gnu_return_type, 0, 0, 0, 0);
3950 Sloc_to_locus (Sloc (gnat_param),
3951 &DECL_SOURCE_LOCATION (gnu_field));
3952 TREE_CHAIN (gnu_field) = gnu_field_list;
3953 gnu_field_list = gnu_field;
3954 gnu_return_list = tree_cons (gnu_field, gnu_param,
3959 /* Do not compute record for out parameters if subprogram is
3960 stubbed since structures are incomplete for the back-end. */
3961 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
3962 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3965 /* If we have a CICO list but it has only one entry, we convert
3966 this function into a function that simply returns that one
3968 if (list_length (gnu_return_list) == 1)
3969 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3971 if (Has_Stdcall_Convention (gnat_entity))
3972 prepend_one_attribute_to
3973 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3974 get_identifier ("stdcall"), NULL_TREE,
3977 /* If we are on a target where stack realignment is needed for 'main'
3978 to honor GCC's implicit expectations (stack alignment greater than
3979 what the base ABI guarantees), ensure we do the same for foreign
3980 convention subprograms as they might be used as callbacks from code
3981 breaking such expectations. Note that this applies to task entry
3982 points in particular. */
3983 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
3984 && Has_Foreign_Convention (gnat_entity))
3985 prepend_one_attribute_to
3986 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3987 get_identifier ("force_align_arg_pointer"), NULL_TREE,
3990 /* The lists have been built in reverse. */
3991 gnu_param_list = nreverse (gnu_param_list);
3993 gnu_stub_param_list = nreverse (gnu_stub_param_list);
3994 gnu_return_list = nreverse (gnu_return_list);
3996 if (Ekind (gnat_entity) == E_Function)
3997 Set_Mechanism (gnat_entity,
3998 (returns_by_ref || returns_unconstrained
3999 ? By_Reference : By_Copy));
4001 = create_subprog_type (gnu_return_type, gnu_param_list,
4002 gnu_return_list, returns_unconstrained,
4003 returns_by_ref, returns_by_target_ptr);
4007 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4008 gnu_return_list, returns_unconstrained,
4009 returns_by_ref, returns_by_target_ptr);
4011 /* A subprogram (something that doesn't return anything) shouldn't
4012 be considered Pure since there would be no reason for such a
4013 subprogram. Note that procedures with Out (or In Out) parameters
4014 have already been converted into a function with a return type. */
4015 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4018 /* The semantics of "pure" in Ada essentially matches that of "const"
4019 in the back-end. In particular, both properties are orthogonal to
4020 the "nothrow" property. But this is true only if the EH circuitry
4021 is explicit in the internal representation of the back-end. If we
4022 are to completely hide the EH circuitry from it, we need to declare
4023 that calls to pure Ada subprograms that can throw have side effects
4024 since they can trigger an "abnormal" transfer of control flow; thus
4025 they can be neither "const" nor "pure" in the back-end sense. */
4027 = build_qualified_type (gnu_type,
4028 TYPE_QUALS (gnu_type)
4029 | (Exception_Mechanism == Back_End_Exceptions
4030 ? TYPE_QUAL_CONST * pure_flag : 0)
4031 | (TYPE_QUAL_VOLATILE * volatile_flag));
4033 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4037 = build_qualified_type (gnu_stub_type,
4038 TYPE_QUALS (gnu_stub_type)
4039 | (Exception_Mechanism == Back_End_Exceptions
4040 ? TYPE_QUAL_CONST * pure_flag : 0)
4041 | (TYPE_QUAL_VOLATILE * volatile_flag));
4043 /* If we have a builtin decl for that function, check the signatures
4044 compatibilities. If the signatures are compatible, use the builtin
4045 decl. If they are not, we expect the checker predicate to have
4046 posted the appropriate errors, and just continue with what we have
4048 if (gnu_builtin_decl)
4050 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4052 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4054 gnu_decl = gnu_builtin_decl;
4055 gnu_type = gnu_builtin_type;
4060 /* If there was no specified Interface_Name and the external and
4061 internal names of the subprogram are the same, only use the
4062 internal name to allow disambiguation of nested subprograms. */
4063 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
4064 gnu_ext_name = NULL_TREE;
4066 /* If we are defining the subprogram and it has an Address clause
4067 we must get the address expression from the saved GCC tree for the
4068 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4069 the address expression here since the front-end has guaranteed
4070 in that case that the elaboration has no effects. If there is
4071 an Address clause and we are not defining the object, just
4072 make it a constant. */
4073 if (Present (Address_Clause (gnat_entity)))
4075 tree gnu_address = NULL_TREE;
4079 = (present_gnu_tree (gnat_entity)
4080 ? get_gnu_tree (gnat_entity)
4081 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4083 save_gnu_tree (gnat_entity, NULL_TREE, false);
4085 /* Convert the type of the object to a reference type that can
4086 alias everything as per 13.3(19). */
4088 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4090 gnu_address = convert (gnu_type, gnu_address);
4093 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
4094 gnu_address, false, Is_Public (gnat_entity),
4095 extern_flag, false, NULL, gnat_entity);
4096 DECL_BY_REF_P (gnu_decl) = 1;
4099 else if (kind == E_Subprogram_Type)
4100 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4101 !Comes_From_Source (gnat_entity),
4102 debug_info_p, gnat_entity);
4107 gnu_stub_name = gnu_ext_name;
4108 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4109 public_flag = false;
4112 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
4113 gnu_type, gnu_param_list,
4114 inline_flag, public_flag,
4115 extern_flag, attr_list,
4120 = create_subprog_decl (gnu_entity_id, gnu_stub_name,
4121 gnu_stub_type, gnu_stub_param_list,
4123 extern_flag, attr_list,
4125 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4128 /* This is unrelated to the stub built right above. */
4129 DECL_STUBBED_P (gnu_decl)
4130 = Convention (gnat_entity) == Convention_Stubbed;
4135 case E_Incomplete_Type:
4136 case E_Incomplete_Subtype:
4137 case E_Private_Type:
4138 case E_Private_Subtype:
4139 case E_Limited_Private_Type:
4140 case E_Limited_Private_Subtype:
4141 case E_Record_Type_With_Private:
4142 case E_Record_Subtype_With_Private:
4144 /* Get the "full view" of this entity. If this is an incomplete
4145 entity from a limited with, treat its non-limited view as the
4146 full view. Otherwise, use either the full view or the underlying
4147 full view, whichever is present. This is used in all the tests
4150 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4151 && From_With_Type (gnat_entity))
4152 ? Non_Limited_View (gnat_entity)
4153 : Present (Full_View (gnat_entity))
4154 ? Full_View (gnat_entity)
4155 : Underlying_Full_View (gnat_entity);
4157 /* If this is an incomplete type with no full view, it must be a Taft
4158 Amendment type, in which case we return a dummy type. Otherwise,
4159 just get the type from its Etype. */
4162 if (kind == E_Incomplete_Type)
4163 gnu_type = make_dummy_type (gnat_entity);
4166 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4168 maybe_present = true;
4173 /* If we already made a type for the full view, reuse it. */
4174 else if (present_gnu_tree (full_view))
4176 gnu_decl = get_gnu_tree (full_view);
4180 /* Otherwise, if we are not defining the type now, get the type
4181 from the full view. But always get the type from the full view
4182 for define on use types, since otherwise we won't see them! */
4183 else if (!definition
4184 || (Is_Itype (full_view)
4185 && No (Freeze_Node (gnat_entity)))
4186 || (Is_Itype (gnat_entity)
4187 && No (Freeze_Node (full_view))))
4189 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4190 maybe_present = true;
4194 /* For incomplete types, make a dummy type entry which will be
4196 gnu_type = make_dummy_type (gnat_entity);
4198 /* Save this type as the full declaration's type so we can do any
4199 needed updates when we see it. */
4200 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4201 !Comes_From_Source (gnat_entity),
4202 debug_info_p, gnat_entity);
4203 save_gnu_tree (full_view, gnu_decl, 0);
4207 /* Simple class_wide types are always viewed as their root_type
4208 by Gigi unless an Equivalent_Type is specified. */
4209 case E_Class_Wide_Type:
4210 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4211 maybe_present = true;
4215 case E_Task_Subtype:
4216 case E_Protected_Type:
4217 case E_Protected_Subtype:
4218 if (type_annotate_only && No (gnat_equiv_type))
4219 gnu_type = void_type_node;
4221 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4223 maybe_present = true;
4227 gnu_decl = create_label_decl (gnu_entity_id);
4232 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4233 we've already saved it, so we don't try to. */
4234 gnu_decl = error_mark_node;
4242 /* If we had a case where we evaluated another type and it might have
4243 defined this one, handle it here. */
4244 if (maybe_present && present_gnu_tree (gnat_entity))
4246 gnu_decl = get_gnu_tree (gnat_entity);
4250 /* If we are processing a type and there is either no decl for it or
4251 we just made one, do some common processing for the type, such as
4252 handling alignment and possible padding. */
4254 if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
4256 if (Is_Tagged_Type (gnat_entity)
4257 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4258 TYPE_ALIGN_OK (gnu_type) = 1;
4260 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4261 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4263 /* ??? Don't set the size for a String_Literal since it is either
4264 confirming or we don't handle it properly (if the low bound is
4266 if (!gnu_size && kind != E_String_Literal_Subtype)
4267 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4269 Has_Size_Clause (gnat_entity));
4271 /* If a size was specified, see if we can make a new type of that size
4272 by rearranging the type, for example from a fat to a thin pointer. */
4276 = make_type_from_size (gnu_type, gnu_size,
4277 Has_Biased_Representation (gnat_entity));
4279 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4280 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4284 /* If the alignment hasn't already been processed and this is
4285 not an unconstrained array, see if an alignment is specified.
4286 If not, we pick a default alignment for atomic objects. */
4287 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4289 else if (Known_Alignment (gnat_entity))
4291 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4292 TYPE_ALIGN (gnu_type));
4294 /* Warn on suspiciously large alignments. This should catch
4295 errors about the (alignment,byte)/(size,bit) discrepancy. */
4296 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4300 /* If a size was specified, take it into account. Otherwise
4301 use the RM size for records as the type size has already
4302 been adjusted to the alignment. */
4305 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4306 || TREE_CODE (gnu_type) == UNION_TYPE
4307 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4308 && !TYPE_IS_FAT_POINTER_P (gnu_type))
4309 size = rm_size (gnu_type);
4311 size = TYPE_SIZE (gnu_type);
4313 /* Consider an alignment as suspicious if the alignment/size
4314 ratio is greater or equal to the byte/bit ratio. */
4315 if (host_integerp (size, 1)
4316 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4317 post_error_ne ("?suspiciously large alignment specified for&",
4318 Expression (Alignment_Clause (gnat_entity)),
4322 else if (Is_Atomic (gnat_entity) && !gnu_size
4323 && host_integerp (TYPE_SIZE (gnu_type), 1)
4324 && integer_pow2p (TYPE_SIZE (gnu_type)))
4325 align = MIN (BIGGEST_ALIGNMENT,
4326 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4327 else if (Is_Atomic (gnat_entity) && gnu_size
4328 && host_integerp (gnu_size, 1)
4329 && integer_pow2p (gnu_size))
4330 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4332 /* See if we need to pad the type. If we did, and made a record,
4333 the name of the new type may be changed. So get it back for
4334 us when we make the new TYPE_DECL below. */
4335 if (gnu_size || align > 0)
4336 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4337 "PAD", true, definition, false);
4339 if (TREE_CODE (gnu_type) == RECORD_TYPE
4340 && TYPE_IS_PADDING_P (gnu_type))
4342 gnu_entity_id = TYPE_NAME (gnu_type);
4343 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
4344 gnu_entity_id = DECL_NAME (gnu_entity_id);
4347 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4349 /* If we are at global level, GCC will have applied variable_size to
4350 the type, but that won't have done anything. So, if it's not
4351 a constant or self-referential, call elaborate_expression_1 to
4352 make a variable for the size rather than calculating it each time.
4353 Handle both the RM size and the actual size. */
4354 if (global_bindings_p ()
4355 && TYPE_SIZE (gnu_type)
4356 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4357 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4359 if (TREE_CODE (gnu_type) == RECORD_TYPE
4360 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4361 TYPE_SIZE (gnu_type), 0))
4363 TYPE_SIZE (gnu_type)
4364 = elaborate_expression_1 (gnat_entity, gnat_entity,
4365 TYPE_SIZE (gnu_type),
4366 get_identifier ("SIZE"),
4368 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4372 TYPE_SIZE (gnu_type)
4373 = elaborate_expression_1 (gnat_entity, gnat_entity,
4374 TYPE_SIZE (gnu_type),
4375 get_identifier ("SIZE"),
4378 /* ??? For now, store the size as a multiple of the alignment
4379 in bytes so that we can see the alignment from the tree. */
4380 TYPE_SIZE_UNIT (gnu_type)
4382 (MULT_EXPR, sizetype,
4383 elaborate_expression_1
4384 (gnat_entity, gnat_entity,
4385 build_binary_op (EXACT_DIV_EXPR, sizetype,
4386 TYPE_SIZE_UNIT (gnu_type),
4387 size_int (TYPE_ALIGN (gnu_type)
4389 get_identifier ("SIZE_A_UNIT"),
4391 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4393 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4396 elaborate_expression_1 (gnat_entity,
4398 TYPE_ADA_SIZE (gnu_type),
4399 get_identifier ("RM_SIZE"),
4404 /* If this is a record type or subtype, call elaborate_expression_1 on
4405 any field position. Do this for both global and local types.
4406 Skip any fields that we haven't made trees for to avoid problems with
4407 class wide types. */
4408 if (IN (kind, Record_Kind))
4409 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4410 gnat_temp = Next_Entity (gnat_temp))
4411 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4413 tree gnu_field = get_gnu_tree (gnat_temp);
4415 /* ??? Unfortunately, GCC needs to be able to prove the
4416 alignment of this offset and if it's a variable, it can't.
4417 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4418 right now, we have to put in an explicit multiply and
4419 divide by that value. */
4420 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4422 DECL_FIELD_OFFSET (gnu_field)
4424 (MULT_EXPR, sizetype,
4425 elaborate_expression_1
4426 (gnat_temp, gnat_temp,
4427 build_binary_op (EXACT_DIV_EXPR, sizetype,
4428 DECL_FIELD_OFFSET (gnu_field),
4429 size_int (DECL_OFFSET_ALIGN (gnu_field)
4431 get_identifier ("OFFSET"),
4433 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4435 /* ??? The context of gnu_field is not necessarily gnu_type so
4436 the MULT_EXPR node built above may not be marked by the call
4437 to create_type_decl below. */
4438 if (global_bindings_p ())
4439 mark_visited (&DECL_FIELD_OFFSET (gnu_field));
4443 gnu_type = build_qualified_type (gnu_type,
4444 (TYPE_QUALS (gnu_type)
4445 | (TYPE_QUAL_VOLATILE
4446 * Treat_As_Volatile (gnat_entity))));
4448 if (Is_Atomic (gnat_entity))
4449 check_ok_for_atomic (gnu_type, gnat_entity, false);
4451 if (Present (Alignment_Clause (gnat_entity)))
4452 TYPE_USER_ALIGN (gnu_type) = 1;
4454 if (Universal_Aliasing (gnat_entity))
4455 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4458 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4459 !Comes_From_Source (gnat_entity),
4460 debug_info_p, gnat_entity);
4462 TREE_TYPE (gnu_decl) = gnu_type;
4465 if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4467 gnu_type = TREE_TYPE (gnu_decl);
4469 /* Back-annotate the Alignment of the type if not already in the
4470 tree. Likewise for sizes. */
4471 if (Unknown_Alignment (gnat_entity))
4472 Set_Alignment (gnat_entity,
4473 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4475 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4477 /* If the size is self-referential, we annotate the maximum
4478 value of that size. */
4479 tree gnu_size = TYPE_SIZE (gnu_type);
4481 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4482 gnu_size = max_size (gnu_size, true);
4484 Set_Esize (gnat_entity, annotate_value (gnu_size));
4486 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4488 /* In this mode the tag and the parent components are not
4489 generated by the front-end, so the sizes must be adjusted
4491 int size_offset, new_size;
4493 if (Is_Derived_Type (gnat_entity))
4496 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4497 Set_Alignment (gnat_entity,
4498 Alignment (Etype (Base_Type (gnat_entity))));
4501 size_offset = POINTER_SIZE;
4503 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4504 Set_Esize (gnat_entity,
4505 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4506 / POINTER_SIZE) * POINTER_SIZE));
4507 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4511 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4512 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4515 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4516 DECL_ARTIFICIAL (gnu_decl) = 1;
4518 if (!debug_info_p && DECL_P (gnu_decl)
4519 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4520 && No (Renamed_Object (gnat_entity)))
4521 DECL_IGNORED_P (gnu_decl) = 1;
4523 /* If we haven't already, associate the ..._DECL node that we just made with
4524 the input GNAT entity node. */
4526 save_gnu_tree (gnat_entity, gnu_decl, false);
4528 /* If this is an enumeral or floating-point type, we were not able to set
4529 the bounds since they refer to the type. These bounds are always static.
4531 For enumeration types, also write debugging information and declare the
4532 enumeration literal table, if needed. */
4534 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4535 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4537 tree gnu_scalar_type = gnu_type;
4539 /* If this is a padded type, we need to use the underlying type. */
4540 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
4541 && TYPE_IS_PADDING_P (gnu_scalar_type))
4542 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4544 /* If this is a floating point type and we haven't set a floating
4545 point type yet, use this in the evaluation of the bounds. */
4546 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4547 longest_float_type_node = gnu_type;
4549 TYPE_MIN_VALUE (gnu_scalar_type)
4550 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4551 TYPE_MAX_VALUE (gnu_scalar_type)
4552 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4554 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4556 /* Since this has both a typedef and a tag, avoid outputting
4558 DECL_ARTIFICIAL (gnu_decl) = 1;
4559 rest_of_type_decl_compilation (gnu_decl);
4563 /* If we deferred processing of incomplete types, re-enable it. If there
4564 were no other disables and we have some to process, do so. */
4565 if (this_deferred && --defer_incomplete_level == 0)
4567 if (defer_incomplete_list)
4569 struct incomplete *incp, *next;
4571 /* We are back to level 0 for the deferring of incomplete types.
4572 But processing these incomplete types below may itself require
4573 deferring, so preserve what we have and restart from scratch. */
4574 incp = defer_incomplete_list;
4575 defer_incomplete_list = NULL;
4577 /* For finalization, however, all types must be complete so we
4578 cannot do the same because deferred incomplete types may end up
4579 referencing each other. Process them all recursively first. */
4580 defer_finalize_level++;
4582 for (; incp; incp = next)
4587 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4588 gnat_to_gnu_type (incp->full_type));
4592 defer_finalize_level--;
4595 /* All the deferred incomplete types have been processed so we can
4596 now proceed with the finalization of the deferred types. */
4597 if (defer_finalize_level == 0 && defer_finalize_list)
4602 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4603 rest_of_type_decl_compilation_no_defer (t);
4605 VEC_free (tree, heap, defer_finalize_list);
4609 /* If we are not defining this type, see if it's in the incomplete list.
4610 If so, handle that list entry now. */
4611 else if (!definition)
4613 struct incomplete *incp;
4615 for (incp = defer_incomplete_list; incp; incp = incp->next)
4616 if (incp->old_type && incp->full_type == gnat_entity)
4618 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4619 TREE_TYPE (gnu_decl));
4620 incp->old_type = NULL_TREE;
4627 if (Is_Packed_Array_Type (gnat_entity)
4628 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4629 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4630 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4631 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4636 /* Similar, but if the returned value is a COMPONENT_REF, return the
4640 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4642 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4644 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4645 gnu_field = TREE_OPERAND (gnu_field, 1);
4650 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4651 Every TYPE_DECL generated for a type definition must be passed
4652 to this function once everything else has been done for it. */
4655 rest_of_type_decl_compilation (tree decl)
4657 /* We need to defer finalizing the type if incomplete types
4658 are being deferred or if they are being processed. */
4659 if (defer_incomplete_level || defer_finalize_level)
4660 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4662 rest_of_type_decl_compilation_no_defer (decl);
4665 /* Same as above but without deferring the compilation. This
4666 function should not be invoked directly on a TYPE_DECL. */
4669 rest_of_type_decl_compilation_no_defer (tree decl)
4671 const int toplev = global_bindings_p ();
4672 tree t = TREE_TYPE (decl);
4674 rest_of_decl_compilation (decl, toplev, 0);
4676 /* Now process all the variants. This is needed for STABS. */
4677 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4679 if (t == TREE_TYPE (decl))
4682 if (!TYPE_STUB_DECL (t))
4684 TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t);
4685 DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1;
4688 rest_of_type_compilation (t, toplev);
4692 /* Finalize any From_With_Type incomplete types. We do this after processing
4693 our compilation unit and after processing its spec, if this is a body. */
4696 finalize_from_with_types (void)
4698 struct incomplete *incp = defer_limited_with;
4699 struct incomplete *next;
4701 defer_limited_with = 0;
4702 for (; incp; incp = next)
4706 if (incp->old_type != 0)
4707 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4708 gnat_to_gnu_type (incp->full_type));
4713 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4714 kind of type (such E_Task_Type) that has a different type which Gigi
4715 uses for its representation. If the type does not have a special type
4716 for its representation, return GNAT_ENTITY. If a type is supposed to
4717 exist, but does not, abort unless annotating types, in which case
4718 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4721 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4723 Entity_Id gnat_equiv = gnat_entity;
4725 if (No (gnat_entity))
4728 switch (Ekind (gnat_entity))
4730 case E_Class_Wide_Subtype:
4731 if (Present (Equivalent_Type (gnat_entity)))
4732 gnat_equiv = Equivalent_Type (gnat_entity);
4735 case E_Access_Protected_Subprogram_Type:
4736 case E_Anonymous_Access_Protected_Subprogram_Type:
4737 gnat_equiv = Equivalent_Type (gnat_entity);
4740 case E_Class_Wide_Type:
4741 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4742 ? Equivalent_Type (gnat_entity)
4743 : Root_Type (gnat_entity));
4747 case E_Task_Subtype:
4748 case E_Protected_Type:
4749 case E_Protected_Subtype:
4750 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4757 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4761 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4762 using MECH as its passing mechanism, to be placed in the parameter
4763 list built for GNAT_SUBPROG. Assume a foreign convention for the
4764 latter if FOREIGN is true. Also set CICO to true if the parameter
4765 must use the copy-in copy-out implementation mechanism.
4767 The returned tree is a PARM_DECL, except for those cases where no
4768 parameter needs to be actually passed to the subprogram; the type
4769 of this "shadow" parameter is then returned instead. */
4772 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
4773 Entity_Id gnat_subprog, bool foreign, bool *cico)
4775 tree gnu_param_name = get_entity_name (gnat_param);
4776 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4777 tree gnu_param_type_alt = NULL_TREE;
4778 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4779 /* The parameter can be indirectly modified if its address is taken. */
4780 bool ro_param = in_param && !Address_Taken (gnat_param);
4781 bool by_return = false, by_component_ptr = false, by_ref = false;
4784 /* Copy-return is used only for the first parameter of a valued procedure.
4785 It's a copy mechanism for which a parameter is never allocated. */
4786 if (mech == By_Copy_Return)
4788 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4793 /* If this is either a foreign function or if the underlying type won't
4794 be passed by reference, strip off possible padding type. */
4795 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4796 && TYPE_IS_PADDING_P (gnu_param_type))
4798 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4800 if (mech == By_Reference
4802 || (!must_pass_by_ref (unpadded_type)
4803 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4804 gnu_param_type = unpadded_type;
4807 /* If this is a read-only parameter, make a variant of the type that is
4808 read-only. ??? However, if this is an unconstrained array, that type
4809 can be very complex, so skip it for now. Likewise for any other
4810 self-referential type. */
4812 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4813 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4814 gnu_param_type = build_qualified_type (gnu_param_type,
4815 (TYPE_QUALS (gnu_param_type)
4816 | TYPE_QUAL_CONST));
4818 /* For foreign conventions, pass arrays as pointers to the element type.
4819 First check for unconstrained array and get the underlying array. */
4820 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4822 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4824 /* VMS descriptors are themselves passed by reference.
4825 Build both a 32bit and 64bit descriptor, one of which will be chosen
4826 in fill_vms_descriptor based on the allocator size */
4827 if (mech == By_Descriptor)
4830 = build_pointer_type (build_vms_descriptor64 (gnu_param_type,
4831 Mechanism (gnat_param),
4834 = build_pointer_type (build_vms_descriptor (gnu_param_type,
4835 Mechanism (gnat_param),
4839 /* Arrays are passed as pointers to element type for foreign conventions. */
4842 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4844 /* Strip off any multi-dimensional entries, then strip
4845 off the last array to get the component type. */
4846 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4847 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4848 gnu_param_type = TREE_TYPE (gnu_param_type);
4850 by_component_ptr = true;
4851 gnu_param_type = TREE_TYPE (gnu_param_type);
4854 gnu_param_type = build_qualified_type (gnu_param_type,
4855 (TYPE_QUALS (gnu_param_type)
4856 | TYPE_QUAL_CONST));
4858 gnu_param_type = build_pointer_type (gnu_param_type);
4861 /* Fat pointers are passed as thin pointers for foreign conventions. */
4862 else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
4864 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
4866 /* If we must pass or were requested to pass by reference, do so.
4867 If we were requested to pass by copy, do so.
4868 Otherwise, for foreign conventions, pass In Out or Out parameters
4869 or aggregates by reference. For COBOL and Fortran, pass all
4870 integer and FP types that way too. For Convention Ada, use
4871 the standard Ada default. */
4872 else if (must_pass_by_ref (gnu_param_type)
4873 || mech == By_Reference
4876 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
4878 && (Convention (gnat_subprog) == Convention_Fortran
4879 || Convention (gnat_subprog) == Convention_COBOL)
4880 && (INTEGRAL_TYPE_P (gnu_param_type)
4881 || FLOAT_TYPE_P (gnu_param_type)))
4883 && default_pass_by_ref (gnu_param_type)))))
4885 gnu_param_type = build_reference_type (gnu_param_type);
4889 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
4893 if (mech == By_Copy && (by_ref || by_component_ptr))
4894 post_error ("?cannot pass & by copy", gnat_param);
4896 /* If this is an Out parameter that isn't passed by reference and isn't
4897 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4898 it will be a VAR_DECL created when we process the procedure, so just
4899 return its type. For the special parameter of a valued procedure,
4902 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4903 Out parameters with discriminants or implicit initial values to be
4904 handled like In Out parameters. These type are normally built as
4905 aggregates, hence passed by reference, except for some packed arrays
4906 which end up encoded in special integer types.
4908 The exception we need to make is then for packed arrays of records
4909 with discriminants or implicit initial values. We have no light/easy
4910 way to check for the latter case, so we merely check for packed arrays
4911 of records. This may lead to useless copy-in operations, but in very
4912 rare cases only, as these would be exceptions in a set of already
4913 exceptional situations. */
4914 if (Ekind (gnat_param) == E_Out_Parameter
4917 || (mech != By_Descriptor
4918 && !POINTER_TYPE_P (gnu_param_type)
4919 && !AGGREGATE_TYPE_P (gnu_param_type)))
4920 && !(Is_Array_Type (Etype (gnat_param))
4921 && Is_Packed (Etype (gnat_param))
4922 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
4923 return gnu_param_type;
4925 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
4926 ro_param || by_ref || by_component_ptr);
4927 DECL_BY_REF_P (gnu_param) = by_ref;
4928 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
4929 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
4930 DECL_POINTS_TO_READONLY_P (gnu_param)
4931 = (ro_param && (by_ref || by_component_ptr));
4933 /* Save the 64bit descriptor for later. */
4934 SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
4936 /* If no Mechanism was specified, indicate what we're using, then
4937 back-annotate it. */
4938 if (mech == Default)
4939 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
4941 Set_Mechanism (gnat_param, mech);
4945 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4948 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4950 while (Present (Corresponding_Discriminant (discr1)))
4951 discr1 = Corresponding_Discriminant (discr1);
4953 while (Present (Corresponding_Discriminant (discr2)))
4954 discr2 = Corresponding_Discriminant (discr2);
4957 Original_Record_Component (discr1) == Original_Record_Component (discr2);
4960 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4961 a non-aliased component in the back-end sense. */
4964 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
4966 /* If the type below this is a multi-array type, then
4967 this does not have aliased components. */
4968 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4969 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
4972 if (Has_Aliased_Components (gnat_type))
4975 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
4978 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4979 be elaborated at the point of its definition, but do nothing else. */
4982 elaborate_entity (Entity_Id gnat_entity)
4984 switch (Ekind (gnat_entity))
4986 case E_Signed_Integer_Subtype:
4987 case E_Modular_Integer_Subtype:
4988 case E_Enumeration_Subtype:
4989 case E_Ordinary_Fixed_Point_Subtype:
4990 case E_Decimal_Fixed_Point_Subtype:
4991 case E_Floating_Point_Subtype:
4993 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4994 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4996 /* ??? Tests for avoiding static constraint error expression
4997 is needed until the front stops generating bogus conversions
4998 on bounds of real types. */
5000 if (!Raises_Constraint_Error (gnat_lb))
5001 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5002 1, 0, Needs_Debug_Info (gnat_entity));
5003 if (!Raises_Constraint_Error (gnat_hb))
5004 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5005 1, 0, Needs_Debug_Info (gnat_entity));
5011 Node_Id full_definition = Declaration_Node (gnat_entity);
5012 Node_Id record_definition = Type_Definition (full_definition);
5014 /* If this is a record extension, go a level further to find the
5015 record definition. */
5016 if (Nkind (record_definition) == N_Derived_Type_Definition)
5017 record_definition = Record_Extension_Part (record_definition);
5021 case E_Record_Subtype:
5022 case E_Private_Subtype:
5023 case E_Limited_Private_Subtype:
5024 case E_Record_Subtype_With_Private:
5025 if (Is_Constrained (gnat_entity)
5026 && Has_Discriminants (Base_Type (gnat_entity))
5027 && Present (Discriminant_Constraint (gnat_entity)))
5029 Node_Id gnat_discriminant_expr;
5030 Entity_Id gnat_field;
5032 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
5033 gnat_discriminant_expr
5034 = First_Elmt (Discriminant_Constraint (gnat_entity));
5035 Present (gnat_field);
5036 gnat_field = Next_Discriminant (gnat_field),
5037 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5038 /* ??? For now, ignore access discriminants. */
5039 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5040 elaborate_expression (Node (gnat_discriminant_expr),
5042 get_entity_name (gnat_field), 1, 0, 0);
5049 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5050 any entities on its entity chain similarly. */
5053 mark_out_of_scope (Entity_Id gnat_entity)
5055 Entity_Id gnat_sub_entity;
5056 unsigned int kind = Ekind (gnat_entity);
5058 /* If this has an entity list, process all in the list. */
5059 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5060 || IN (kind, Private_Kind)
5061 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5062 || kind == E_Function || kind == E_Generic_Function
5063 || kind == E_Generic_Package || kind == E_Generic_Procedure
5064 || kind == E_Loop || kind == E_Operator || kind == E_Package
5065 || kind == E_Package_Body || kind == E_Procedure
5066 || kind == E_Record_Type || kind == E_Record_Subtype
5067 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5068 for (gnat_sub_entity = First_Entity (gnat_entity);
5069 Present (gnat_sub_entity);
5070 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5071 if (Scope (gnat_sub_entity) == gnat_entity
5072 && gnat_sub_entity != gnat_entity)
5073 mark_out_of_scope (gnat_sub_entity);
5075 /* Now clear this if it has been defined, but only do so if it isn't
5076 a subprogram or parameter. We could refine this, but it isn't
5077 worth it. If this is statically allocated, it is supposed to
5078 hang around out of cope. */
5079 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5080 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5082 save_gnu_tree (gnat_entity, NULL_TREE, true);
5083 save_gnu_tree (gnat_entity, error_mark_node, true);
5087 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
5088 is a multi-dimensional array type, do this recursively. */
5091 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
5093 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5094 of a one-dimensional array, since the padding has the same alias set
5095 as the field type, but if it's a multi-dimensional array, we need to
5096 see the inner types. */
5097 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5098 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5099 || TYPE_IS_PADDING_P (gnu_old_type)))
5100 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5102 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
5103 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
5104 so we need to go down to what does. */
5105 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5107 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5109 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5110 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5111 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5112 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
5114 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5115 record_component_aliases (gnu_new_type);
5118 /* Return a TREE_LIST describing the substitutions needed to reflect
5119 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5120 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
5121 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
5122 gives the tree for the discriminant and TREE_VALUES is the replacement
5123 value. They are in the form of operands to substitute_in_expr.
5124 DEFINITION is as in gnat_to_gnu_entity. */
5127 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
5128 tree gnu_list, bool definition)
5130 Entity_Id gnat_discrim;
5134 gnat_type = Implementation_Base_Type (gnat_subtype);
5136 if (Has_Discriminants (gnat_type))
5137 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
5138 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
5139 Present (gnat_discrim);
5140 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
5141 gnat_value = Next_Elmt (gnat_value))
5142 /* Ignore access discriminants. */
5143 if (!Is_Access_Type (Etype (Node (gnat_value))))
5144 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
5145 elaborate_expression
5146 (Node (gnat_value), gnat_subtype,
5147 get_entity_name (gnat_discrim), definition,
5154 /* Return true if the size represented by GNU_SIZE can be handled by an
5155 allocation. If STATIC_P is true, consider only what can be done with a
5156 static allocation. */
5159 allocatable_size_p (tree gnu_size, bool static_p)
5161 HOST_WIDE_INT our_size;
5163 /* If this is not a static allocation, the only case we want to forbid
5164 is an overflowing size. That will be converted into a raise a
5167 return !(TREE_CODE (gnu_size) == INTEGER_CST
5168 && TREE_OVERFLOW (gnu_size));
5170 /* Otherwise, we need to deal with both variable sizes and constant
5171 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5172 since assemblers may not like very large sizes. */
5173 if (!host_integerp (gnu_size, 1))
5176 our_size = tree_low_cst (gnu_size, 1);
5177 return (int) our_size == our_size;
5180 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5181 NAME, ARGS and ERROR_POINT. */
5184 prepend_one_attribute_to (struct attrib ** attr_list,
5185 enum attr_type attr_type,
5188 Node_Id attr_error_point)
5190 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5192 attr->type = attr_type;
5193 attr->name = attr_name;
5194 attr->args = attr_args;
5195 attr->error_point = attr_error_point;
5197 attr->next = *attr_list;
5201 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5204 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5208 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5209 gnat_temp = Next_Rep_Item (gnat_temp))
5210 if (Nkind (gnat_temp) == N_Pragma)
5212 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5213 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5214 enum attr_type etype;
5216 if (Present (gnat_assoc) && Present (First (gnat_assoc))
5217 && Present (Next (First (gnat_assoc)))
5218 && (Nkind (Expression (Next (First (gnat_assoc))))
5219 == N_String_Literal))
5221 gnu_arg0 = get_identifier (TREE_STRING_POINTER
5224 (First (gnat_assoc))))));
5225 if (Present (Next (Next (First (gnat_assoc))))
5226 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
5227 == N_String_Literal))
5228 gnu_arg1 = get_identifier (TREE_STRING_POINTER
5232 (First (gnat_assoc)))))));
5235 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5237 case Pragma_Machine_Attribute:
5238 etype = ATTR_MACHINE_ATTRIBUTE;
5241 case Pragma_Linker_Alias:
5242 etype = ATTR_LINK_ALIAS;
5245 case Pragma_Linker_Section:
5246 etype = ATTR_LINK_SECTION;
5249 case Pragma_Linker_Constructor:
5250 etype = ATTR_LINK_CONSTRUCTOR;
5253 case Pragma_Linker_Destructor:
5254 etype = ATTR_LINK_DESTRUCTOR;
5257 case Pragma_Weak_External:
5258 etype = ATTR_WEAK_EXTERNAL;
5266 /* Prepend to the list now. Make a list of the argument we might
5267 have, as GCC expects it. */
5268 prepend_one_attribute_to
5271 (gnu_arg1 != NULL_TREE)
5272 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5273 Present (Next (First (gnat_assoc)))
5274 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5278 /* Get the unpadded version of a GNAT type. */
5281 get_unpadded_type (Entity_Id gnat_entity)
5283 tree type = gnat_to_gnu_type (gnat_entity);
5285 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5286 type = TREE_TYPE (TYPE_FIELDS (type));
5291 /* Called when we need to protect a variable object using a save_expr. */
5294 maybe_variable (tree gnu_operand)
5296 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
5297 || TREE_CODE (gnu_operand) == SAVE_EXPR
5298 || TREE_CODE (gnu_operand) == NULL_EXPR)
5301 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5303 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
5304 TREE_TYPE (gnu_operand),
5305 variable_size (TREE_OPERAND (gnu_operand, 0)));
5307 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5308 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5312 return variable_size (gnu_operand);
5315 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5316 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5317 return the GCC tree to use for that expression. GNU_NAME is the
5318 qualification to use if an external name is appropriate and DEFINITION is
5319 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
5320 we need a result. Otherwise, we are just elaborating this for
5321 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
5322 purposes even if it isn't needed for code generation. */
5325 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
5326 tree gnu_name, bool definition, bool need_value,
5331 /* If we already elaborated this expression (e.g., it was involved
5332 in the definition of a private type), use the old value. */
5333 if (present_gnu_tree (gnat_expr))
5334 return get_gnu_tree (gnat_expr);
5336 /* If we don't need a value and this is static or a discriminant, we
5337 don't need to do anything. */
5338 else if (!need_value
5339 && (Is_OK_Static_Expression (gnat_expr)
5340 || (Nkind (gnat_expr) == N_Identifier
5341 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5344 /* Otherwise, convert this tree to its GCC equivalent. */
5346 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5347 gnu_name, definition, need_debug);
5349 /* Save the expression in case we try to elaborate this entity again. Since
5350 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5351 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5352 save_gnu_tree (gnat_expr, gnu_expr, true);
5354 return need_value ? gnu_expr : error_mark_node;
5357 /* Similar, but take a GNU expression. */
5360 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5361 tree gnu_expr, tree gnu_name, bool definition,
5364 tree gnu_decl = NULL_TREE;
5365 /* Skip any conversions and simple arithmetics to see if the expression
5366 is a read-only variable.
5367 ??? This really should remain read-only, but we have to think about
5368 the typing of the tree here. */
5370 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5371 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5374 /* In most cases, we won't see a naked FIELD_DECL here because a
5375 discriminant reference will have been replaced with a COMPONENT_REF
5376 when the type is being elaborated. However, there are some cases
5377 involving child types where we will. So convert it to a COMPONENT_REF
5378 here. We have to hope it will be at the highest level of the
5379 expression in these cases. */
5380 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5381 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5382 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5383 gnu_expr, NULL_TREE);
5385 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5386 that is read-only, make a variable that is initialized to contain the
5387 bound when the package containing the definition is elaborated. If
5388 this entity is defined at top level and a bound or discriminant value
5389 isn't a constant or a reference to a discriminant, replace the bound
5390 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5391 rely here on the fact that an expression cannot contain both the
5392 discriminant and some other variable. */
5394 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5395 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5396 && (TREE_READONLY (gnu_inner_expr)
5397 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5398 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5400 /* If this is a static expression or contains a discriminant, we don't
5401 need the variable for debugging (and can't elaborate anyway if a
5404 && (Is_OK_Static_Expression (gnat_expr)
5405 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5408 /* Now create the variable if we need it. */
5409 if (need_debug || (expr_variable && expr_global))
5411 = create_var_decl (create_concat_name (gnat_entity,
5412 IDENTIFIER_POINTER (gnu_name)),
5413 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5414 !need_debug, Is_Public (gnat_entity),
5415 !definition, false, NULL, gnat_entity);
5417 /* We only need to use this variable if we are in global context since GCC
5418 can do the right thing in the local case. */
5419 if (expr_global && expr_variable)
5421 else if (!expr_variable)
5424 return maybe_variable (gnu_expr);
5427 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5428 starting bit position so that it is aligned to ALIGN bits, and leaving at
5429 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5430 record is guaranteed to get. */
5433 make_aligning_type (tree type, unsigned int align, tree size,
5434 unsigned int base_align, int room)
5436 /* We will be crafting a record type with one field at a position set to be
5437 the next multiple of ALIGN past record'address + room bytes. We use a
5438 record placeholder to express record'address. */
5440 tree record_type = make_node (RECORD_TYPE);
5441 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5444 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5446 /* The diagram below summarizes the shape of what we manipulate:
5448 <--------- pos ---------->
5449 { +------------+-------------+-----------------+
5450 record =>{ |############| ... | field (type) |
5451 { +------------+-------------+-----------------+
5452 |<-- room -->|<- voffset ->|<---- size ----->|
5455 record_addr vblock_addr
5457 Every length is in sizetype bytes there, except "pos" which has to be
5458 set as a bit position in the GCC tree for the record. */
5460 tree room_st = size_int (room);
5461 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5462 tree voffset_st, pos, field;
5464 tree name = TYPE_NAME (type);
5466 if (TREE_CODE (name) == TYPE_DECL)
5467 name = DECL_NAME (name);
5469 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
5471 /* Compute VOFFSET and then POS. The next byte position multiple of some
5472 alignment after some address is obtained by "and"ing the alignment minus
5473 1 with the two's complement of the address. */
5475 voffset_st = size_binop (BIT_AND_EXPR,
5476 size_diffop (size_zero_node, vblock_addr_st),
5477 ssize_int ((align / BITS_PER_UNIT) - 1));
5479 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5481 pos = size_binop (MULT_EXPR,
5482 convert (bitsizetype,
5483 size_binop (PLUS_EXPR, room_st, voffset_st)),
5486 /* Craft the GCC record representation. We exceptionally do everything
5487 manually here because 1) our generic circuitry is not quite ready to
5488 handle the complex position/size expressions we are setting up, 2) we
5489 have a strong simplifying factor at hand: we know the maximum possible
5490 value of voffset, and 3) we have to set/reset at least the sizes in
5491 accordance with this maximum value anyway, as we need them to convey
5492 what should be "alloc"ated for this type.
5494 Use -1 as the 'addressable' indication for the field to prevent the
5495 creation of a bitfield. We don't need one, it would have damaging
5496 consequences on the alignment computation, and create_field_decl would
5497 make one without this special argument, for instance because of the
5498 complex position expression. */
5500 field = create_field_decl (get_identifier ("F"), type, record_type,
5502 TYPE_FIELDS (record_type) = field;
5504 TYPE_ALIGN (record_type) = base_align;
5505 TYPE_USER_ALIGN (record_type) = 1;
5507 TYPE_SIZE (record_type)
5508 = size_binop (PLUS_EXPR,
5509 size_binop (MULT_EXPR, convert (bitsizetype, size),
5511 bitsize_int (align + room * BITS_PER_UNIT));
5512 TYPE_SIZE_UNIT (record_type)
5513 = size_binop (PLUS_EXPR, size,
5514 size_int (room + align / BITS_PER_UNIT));
5516 TYPE_MODE (record_type) = BLKmode;
5518 copy_alias_set (record_type, type);
5522 /* Return the result of rounding T up to ALIGN. */
5524 static inline unsigned HOST_WIDE_INT
5525 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5533 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5534 as the field type of a packed record if IN_RECORD is true, or as the
5535 component type of a packed array if IN_RECORD is false. See if we can
5536 rewrite it either as a type that has a non-BLKmode, which we can pack
5537 tighter in the packed record case, or as a smaller type with BLKmode.
5538 If so, return the new type. If not, return the original type. */
5541 make_packable_type (tree type, bool in_record)
5543 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5544 unsigned HOST_WIDE_INT new_size;
5545 tree new_type, old_field, field_list = NULL_TREE;
5547 /* No point in doing anything if the size is zero. */
5551 new_type = make_node (TREE_CODE (type));
5553 /* Copy the name and flags from the old type to that of the new.
5554 Note that we rely on the pointer equality created here for
5555 TYPE_NAME to look through conversions in various places. */
5556 TYPE_NAME (new_type) = TYPE_NAME (type);
5557 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5558 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5559 if (TREE_CODE (type) == RECORD_TYPE)
5560 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5562 /* If we are in a record and have a small size, set the alignment to
5563 try for an integral mode. Otherwise set it to try for a smaller
5564 type with BLKmode. */
5565 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5567 TYPE_ALIGN (new_type) = ceil_alignment (size);
5568 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5572 unsigned HOST_WIDE_INT align;
5574 /* Do not try to shrink the size if the RM size is not constant. */
5575 if (TYPE_CONTAINS_TEMPLATE_P (type)
5576 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5579 /* Round the RM size up to a unit boundary to get the minimal size
5580 for a BLKmode record. Give up if it's already the size. */
5581 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5582 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5583 if (new_size == size)
5586 align = new_size & -new_size;
5587 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5590 TYPE_USER_ALIGN (new_type) = 1;
5592 /* Now copy the fields, keeping the position and size as we don't want
5593 to change the layout by propagating the packedness downwards. */
5594 for (old_field = TYPE_FIELDS (type); old_field;
5595 old_field = TREE_CHAIN (old_field))
5597 tree new_field_type = TREE_TYPE (old_field);
5598 tree new_field, new_size;
5600 if (TYPE_MODE (new_field_type) == BLKmode
5601 && (TREE_CODE (new_field_type) == RECORD_TYPE
5602 || TREE_CODE (new_field_type) == UNION_TYPE
5603 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5604 && host_integerp (TYPE_SIZE (new_field_type), 1))
5605 new_field_type = make_packable_type (new_field_type, true);
5607 /* However, for the last field in a not already packed record type
5608 that is of an aggregate type, we need to use the RM_Size in the
5609 packable version of the record type, see finish_record_type. */
5610 if (!TREE_CHAIN (old_field)
5611 && !TYPE_PACKED (type)
5612 && (TREE_CODE (new_field_type) == RECORD_TYPE
5613 || TREE_CODE (new_field_type) == UNION_TYPE
5614 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5615 && !TYPE_IS_FAT_POINTER_P (new_field_type)
5616 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5617 && TYPE_ADA_SIZE (new_field_type))
5618 new_size = TYPE_ADA_SIZE (new_field_type);
5620 new_size = DECL_SIZE (old_field);
5622 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5623 new_type, TYPE_PACKED (type), new_size,
5624 bit_position (old_field),
5625 !DECL_NONADDRESSABLE_P (old_field));
5627 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5628 SET_DECL_ORIGINAL_FIELD
5629 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5630 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5632 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5633 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5635 TREE_CHAIN (new_field) = field_list;
5636 field_list = new_field;
5639 finish_record_type (new_type, nreverse (field_list), 2, true);
5640 copy_alias_set (new_type, type);
5642 /* If this is a padding record, we never want to make the size smaller
5643 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5644 if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5645 || TREE_CODE (type) == QUAL_UNION_TYPE)
5647 TYPE_SIZE (new_type) = TYPE_SIZE (type);
5648 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5652 TYPE_SIZE (new_type) = bitsize_int (new_size);
5653 TYPE_SIZE_UNIT (new_type)
5654 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
5657 if (!TYPE_CONTAINS_TEMPLATE_P (type))
5658 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
5660 compute_record_mode (new_type);
5662 /* Try harder to get a packable type if necessary, for example
5663 in case the record itself contains a BLKmode field. */
5664 if (in_record && TYPE_MODE (new_type) == BLKmode)
5665 TYPE_MODE (new_type)
5666 = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
5668 /* If neither the mode nor the size has shrunk, return the old type. */
5669 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
5675 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5676 if needed. We have already verified that SIZE and TYPE are large enough.
5678 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5681 IS_USER_TYPE is true if we must complete the original type.
5683 DEFINITION is true if this type is being defined.
5685 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
5686 to SIZE too; otherwise, it's set to the RM_Size of the original type. */
5689 maybe_pad_type (tree type, tree size, unsigned int align,
5690 Entity_Id gnat_entity, const char *name_trailer,
5691 bool is_user_type, bool definition, bool same_rm_size)
5693 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
5694 tree orig_size = TYPE_SIZE (type);
5695 unsigned int orig_align = align;
5698 /* If TYPE is a padded type, see if it agrees with any size and alignment
5699 we were given. If so, return the original type. Otherwise, strip
5700 off the padding, since we will either be returning the inner type
5701 or repadding it. If no size or alignment is specified, use that of
5702 the original padded type. */
5703 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5706 || operand_equal_p (round_up (size,
5707 MAX (align, TYPE_ALIGN (type))),
5708 round_up (TYPE_SIZE (type),
5709 MAX (align, TYPE_ALIGN (type))),
5711 && (align == 0 || align == TYPE_ALIGN (type)))
5715 size = TYPE_SIZE (type);
5717 align = TYPE_ALIGN (type);
5719 type = TREE_TYPE (TYPE_FIELDS (type));
5720 orig_size = TYPE_SIZE (type);
5723 /* If the size is either not being changed or is being made smaller (which
5724 is not done here (and is only valid for bitfields anyway), show the size
5725 isn't changing. Likewise, clear the alignment if it isn't being
5726 changed. Then return if we aren't doing anything. */
5728 && (operand_equal_p (size, orig_size, 0)
5729 || (TREE_CODE (orig_size) == INTEGER_CST
5730 && tree_int_cst_lt (size, orig_size))))
5733 if (align == TYPE_ALIGN (type))
5736 if (align == 0 && !size)
5739 /* If requested, complete the original type and give it a name. */
5741 create_type_decl (get_entity_name (gnat_entity), type,
5742 NULL, !Comes_From_Source (gnat_entity),
5744 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5745 && DECL_IGNORED_P (TYPE_NAME (type))),
5748 /* We used to modify the record in place in some cases, but that could
5749 generate incorrect debugging information. So make a new record
5751 record = make_node (RECORD_TYPE);
5752 TYPE_IS_PADDING_P (record) = 1;
5754 if (Present (gnat_entity))
5755 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5757 TYPE_VOLATILE (record)
5758 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5760 TYPE_ALIGN (record) = align;
5762 TYPE_USER_ALIGN (record) = align;
5764 TYPE_SIZE (record) = size ? size : orig_size;
5765 TYPE_SIZE_UNIT (record)
5766 = convert (sizetype,
5767 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
5768 bitsize_unit_node));
5770 /* If we are changing the alignment and the input type is a record with
5771 BLKmode and a small constant size, try to make a form that has an
5772 integral mode. This might allow the padding record to also have an
5773 integral mode, which will be much more efficient. There is no point
5774 in doing so if a size is specified unless it is also a small constant
5775 size and it is incorrect to do so if we cannot guarantee that the mode
5776 will be naturally aligned since the field must always be addressable.
5778 ??? This might not always be a win when done for a stand-alone object:
5779 since the nominal and the effective type of the object will now have
5780 different modes, a VIEW_CONVERT_EXPR will be required for converting
5781 between them and it might be hard to overcome afterwards, including
5782 at the RTL level when the stand-alone object is accessed as a whole. */
5784 && TREE_CODE (type) == RECORD_TYPE
5785 && TYPE_MODE (type) == BLKmode
5786 && TREE_CODE (orig_size) == INTEGER_CST
5787 && !TREE_CONSTANT_OVERFLOW (orig_size)
5788 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
5790 || (TREE_CODE (size) == INTEGER_CST
5791 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
5793 tree packable_type = make_packable_type (type, true);
5794 if (TYPE_MODE (packable_type) != BLKmode
5795 && align >= TYPE_ALIGN (packable_type))
5796 type = packable_type;
5799 /* Now create the field with the original size. */
5800 field = create_field_decl (get_identifier ("F"), type, record, 0,
5801 orig_size, bitsize_zero_node, 1);
5802 DECL_INTERNAL_P (field) = 1;
5804 /* Do not finalize it until after the auxiliary record is built. */
5805 finish_record_type (record, field, 1, true);
5807 /* Set the same size for its RM_size if requested; otherwise reuse
5808 the RM_size of the original type. */
5809 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
5811 /* Unless debugging information isn't being written for the input type,
5812 write a record that shows what we are a subtype of and also make a
5813 variable that indicates our size, if still variable. */
5814 if (TYPE_NAME (record)
5815 && AGGREGATE_TYPE_P (type)
5816 && TREE_CODE (orig_size) != INTEGER_CST
5817 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5818 && DECL_IGNORED_P (TYPE_NAME (type))))
5820 tree marker = make_node (RECORD_TYPE);
5821 tree name = TYPE_NAME (record);
5822 tree orig_name = TYPE_NAME (type);
5824 if (TREE_CODE (name) == TYPE_DECL)
5825 name = DECL_NAME (name);
5827 if (TREE_CODE (orig_name) == TYPE_DECL)
5828 orig_name = DECL_NAME (orig_name);
5830 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5831 finish_record_type (marker,
5832 create_field_decl (orig_name, integer_type_node,
5833 marker, 0, NULL_TREE, NULL_TREE,
5837 add_parallel_type (TYPE_STUB_DECL (record), marker);
5839 if (size && TREE_CODE (size) != INTEGER_CST && definition)
5840 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5841 bitsizetype, TYPE_SIZE (record), false, false, false,
5842 false, NULL, gnat_entity);
5845 rest_of_record_type_compilation (record);
5847 /* If the size was widened explicitly, maybe give a warning. Take the
5848 original size as the maximum size of the input if there was an
5849 unconstrained record involved and round it up to the specified alignment,
5850 if one was specified. */
5851 if (CONTAINS_PLACEHOLDER_P (orig_size))
5852 orig_size = max_size (orig_size, true);
5855 orig_size = round_up (orig_size, align);
5857 if (size && Present (gnat_entity)
5858 && !operand_equal_p (size, orig_size, 0)
5859 && !(TREE_CODE (size) == INTEGER_CST
5860 && TREE_CODE (orig_size) == INTEGER_CST
5861 && tree_int_cst_lt (size, orig_size)))
5863 Node_Id gnat_error_node = Empty;
5865 if (Is_Packed_Array_Type (gnat_entity))
5866 gnat_entity = Original_Array_Type (gnat_entity);
5868 if ((Ekind (gnat_entity) == E_Component
5869 || Ekind (gnat_entity) == E_Discriminant)
5870 && Present (Component_Clause (gnat_entity)))
5871 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5872 else if (Present (Size_Clause (gnat_entity)))
5873 gnat_error_node = Expression (Size_Clause (gnat_entity));
5875 /* Generate message only for entities that come from source, since
5876 if we have an entity created by expansion, the message will be
5877 generated for some other corresponding source entity. */
5878 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5879 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5881 size_diffop (size, orig_size));
5883 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5884 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5885 gnat_entity, gnat_entity,
5886 size_diffop (size, orig_size));
5892 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5893 the value passed against the list of choices. */
5896 choices_to_gnu (tree operand, Node_Id choices)
5900 tree result = integer_zero_node;
5901 tree this_test, low = 0, high = 0, single = 0;
5903 for (choice = First (choices); Present (choice); choice = Next (choice))
5905 switch (Nkind (choice))
5908 low = gnat_to_gnu (Low_Bound (choice));
5909 high = gnat_to_gnu (High_Bound (choice));
5911 /* There's no good type to use here, so we might as well use
5912 integer_type_node. */
5914 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5915 build_binary_op (GE_EXPR, integer_type_node,
5917 build_binary_op (LE_EXPR, integer_type_node,
5922 case N_Subtype_Indication:
5923 gnat_temp = Range_Expression (Constraint (choice));
5924 low = gnat_to_gnu (Low_Bound (gnat_temp));
5925 high = gnat_to_gnu (High_Bound (gnat_temp));
5928 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5929 build_binary_op (GE_EXPR, integer_type_node,
5931 build_binary_op (LE_EXPR, integer_type_node,
5936 case N_Expanded_Name:
5937 /* This represents either a subtype range, an enumeration
5938 literal, or a constant Ekind says which. If an enumeration
5939 literal or constant, fall through to the next case. */
5940 if (Ekind (Entity (choice)) != E_Enumeration_Literal
5941 && Ekind (Entity (choice)) != E_Constant)
5943 tree type = gnat_to_gnu_type (Entity (choice));
5945 low = TYPE_MIN_VALUE (type);
5946 high = TYPE_MAX_VALUE (type);
5949 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5950 build_binary_op (GE_EXPR, integer_type_node,
5952 build_binary_op (LE_EXPR, integer_type_node,
5956 /* ... fall through ... */
5957 case N_Character_Literal:
5958 case N_Integer_Literal:
5959 single = gnat_to_gnu (choice);
5960 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5964 case N_Others_Choice:
5965 this_test = integer_one_node;
5972 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5979 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5980 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
5983 adjust_packed (tree field_type, tree record_type, int packed)
5985 /* If the field contains an item of variable size, we cannot pack it
5986 because we cannot create temporaries of non-fixed size in case
5987 we need to take the address of the field. See addressable_p and
5988 the notes on the addressability issues for further details. */
5989 if (is_variable_size (field_type))
5992 /* If the alignment of the record is specified and the field type
5993 is over-aligned, request Storage_Unit alignment for the field. */
5996 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6005 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6006 placed in GNU_RECORD_TYPE.
6008 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6009 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6010 record has a specified alignment.
6012 DEFINITION is true if this field is for a record being defined. */
6015 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6018 tree gnu_field_id = get_entity_name (gnat_field);
6019 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6020 tree gnu_field, gnu_size, gnu_pos;
6021 bool needs_strict_alignment
6022 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6023 || Treat_As_Volatile (gnat_field));
6025 /* If this field requires strict alignment, we cannot pack it because
6026 it would very likely be under-aligned in the record. */
6027 if (needs_strict_alignment)
6030 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6032 /* If a size is specified, use it. Otherwise, if the record type is packed,
6033 use the official RM size. See "Handling of Type'Size Values" in Einfo
6034 for further details. */
6035 if (Known_Static_Esize (gnat_field))
6036 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6037 gnat_field, FIELD_DECL, false, true);
6038 else if (packed == 1)
6039 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6040 gnat_field, FIELD_DECL, false, true);
6042 gnu_size = NULL_TREE;
6044 /* If we have a specified size that's smaller than that of the field type,
6045 or a position is specified, and the field type is also a record that's
6046 BLKmode, see if we can get either an integral mode form of the type or
6047 a smaller BLKmode form. If we can, show a size was specified for the
6048 field if there wasn't one already, so we know to make this a bitfield
6049 and avoid making things wider.
6051 Doing this is first useful if the record is packed because we may then
6052 place the field at a non-byte-aligned position and so achieve tighter
6055 This is in addition *required* if the field shares a byte with another
6056 field and the front-end lets the back-end handle the references, because
6057 GCC does not handle BLKmode bitfields properly.
6059 We avoid the transformation if it is not required or potentially useful,
6060 as it might entail an increase of the field's alignment and have ripple
6061 effects on the outer record type. A typical case is a field known to be
6062 byte aligned and not to share a byte with another field.
6064 Besides, we don't even look the possibility of a transformation in cases
6065 known to be in error already, for instance when an invalid size results
6066 from a component clause. */
6068 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6069 && TYPE_MODE (gnu_field_type) == BLKmode
6070 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6073 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6074 || Present (Component_Clause (gnat_field))))))
6076 /* See what the alternate type and size would be. */
6077 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6079 bool has_byte_aligned_clause
6080 = Present (Component_Clause (gnat_field))
6081 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6082 % BITS_PER_UNIT == 0);
6084 /* Compute whether we should avoid the substitution. */
6086 /* There is no point substituting if there is no change... */
6087 = (gnu_packable_type == gnu_field_type)
6088 /* ... nor when the field is known to be byte aligned and not to
6089 share a byte with another field. */
6090 || (has_byte_aligned_clause
6091 && value_factor_p (gnu_size, BITS_PER_UNIT))
6092 /* The size of an aliased field must be an exact multiple of the
6093 type's alignment, which the substitution might increase. Reject
6094 substitutions that would so invalidate a component clause when the
6095 specified position is byte aligned, as the change would have no
6096 real benefit from the packing standpoint anyway. */
6097 || (Is_Aliased (gnat_field)
6098 && has_byte_aligned_clause
6099 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6101 /* Substitute unless told otherwise. */
6104 gnu_field_type = gnu_packable_type;
6107 gnu_size = rm_size (gnu_field_type);
6111 /* If we are packing the record and the field is BLKmode, round the
6112 size up to a byte boundary. */
6113 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6114 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6116 if (Present (Component_Clause (gnat_field)))
6118 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6119 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6120 gnat_field, FIELD_DECL, false, true);
6122 /* Ensure the position does not overlap with the parent subtype,
6124 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
6127 = gnat_to_gnu_type (Parent_Subtype
6128 (Underlying_Type (Scope (gnat_field))));
6130 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6131 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6134 ("offset of& must be beyond parent{, minimum allowed is ^}",
6135 First_Bit (Component_Clause (gnat_field)), gnat_field,
6136 TYPE_SIZE_UNIT (gnu_parent));
6140 /* If this field needs strict alignment, ensure the record is
6141 sufficiently aligned and that that position and size are
6142 consistent with the alignment. */
6143 if (needs_strict_alignment)
6145 TYPE_ALIGN (gnu_record_type)
6146 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6149 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6151 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6153 ("atomic field& must be natural size of type{ (^)}",
6154 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6155 TYPE_SIZE (gnu_field_type));
6157 else if (Is_Aliased (gnat_field))
6159 ("size of aliased field& must be ^ bits",
6160 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6161 TYPE_SIZE (gnu_field_type));
6163 else if (Strict_Alignment (Etype (gnat_field)))
6165 ("size of & with aliased or tagged components not ^ bits",
6166 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6167 TYPE_SIZE (gnu_field_type));
6169 gnu_size = NULL_TREE;
6172 if (!integer_zerop (size_binop
6173 (TRUNC_MOD_EXPR, gnu_pos,
6174 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6176 if (Is_Aliased (gnat_field))
6178 ("position of aliased field& must be multiple of ^ bits",
6179 First_Bit (Component_Clause (gnat_field)), gnat_field,
6180 TYPE_ALIGN (gnu_field_type));
6182 else if (Treat_As_Volatile (gnat_field))
6184 ("position of volatile field& must be multiple of ^ bits",
6185 First_Bit (Component_Clause (gnat_field)), gnat_field,
6186 TYPE_ALIGN (gnu_field_type));
6188 else if (Strict_Alignment (Etype (gnat_field)))
6190 ("position of & with aliased or tagged components not multiple of ^ bits",
6191 First_Bit (Component_Clause (gnat_field)), gnat_field,
6192 TYPE_ALIGN (gnu_field_type));
6197 gnu_pos = NULL_TREE;
6201 if (Is_Atomic (gnat_field))
6202 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6205 /* If the record has rep clauses and this is the tag field, make a rep
6206 clause for it as well. */
6207 else if (Has_Specified_Layout (Scope (gnat_field))
6208 && Chars (gnat_field) == Name_uTag)
6210 gnu_pos = bitsize_zero_node;
6211 gnu_size = TYPE_SIZE (gnu_field_type);
6215 gnu_pos = NULL_TREE;
6217 /* We need to make the size the maximum for the type if it is
6218 self-referential and an unconstrained type. In that case, we can't
6219 pack the field since we can't make a copy to align it. */
6220 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6222 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6223 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6225 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6229 /* If a size is specified, adjust the field's type to it. */
6232 /* If the field's type is justified modular, we would need to remove
6233 the wrapper to (better) meet the layout requirements. However we
6234 can do so only if the field is not aliased to preserve the unique
6235 layout and if the prescribed size is not greater than that of the
6236 packed array to preserve the justification. */
6237 if (!needs_strict_alignment
6238 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6239 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6240 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6242 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6245 = make_type_from_size (gnu_field_type, gnu_size,
6246 Has_Biased_Representation (gnat_field));
6247 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6248 "PAD", false, definition, true);
6251 /* Otherwise (or if there was an error), don't specify a position. */
6253 gnu_pos = NULL_TREE;
6255 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6256 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6258 /* Now create the decl for the field. */
6259 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6260 packed, gnu_size, gnu_pos,
6261 Is_Aliased (gnat_field));
6262 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6263 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6265 if (Ekind (gnat_field) == E_Discriminant)
6266 DECL_DISCRIMINANT_NUMBER (gnu_field)
6267 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6272 /* Return true if TYPE is a type with variable size, a padding type with a
6273 field of variable size or is a record that has a field such a field. */
6276 is_variable_size (tree type)
6280 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6283 if (TREE_CODE (type) == RECORD_TYPE
6284 && TYPE_IS_PADDING_P (type)
6285 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6288 if (TREE_CODE (type) != RECORD_TYPE
6289 && TREE_CODE (type) != UNION_TYPE
6290 && TREE_CODE (type) != QUAL_UNION_TYPE)
6293 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6294 if (is_variable_size (TREE_TYPE (field)))
6300 /* qsort comparer for the bit positions of two record components. */
6303 compare_field_bitpos (const PTR rt1, const PTR rt2)
6305 const_tree const field1 = * (const_tree const *) rt1;
6306 const_tree const field2 = * (const_tree const *) rt2;
6308 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6310 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6313 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6314 of GCC trees for fields that are in the record and have already been
6315 processed. When called from gnat_to_gnu_entity during the processing of a
6316 record type definition, the GCC nodes for the discriminants will be on
6317 the chain. The other calls to this function are recursive calls from
6318 itself for the Component_List of a variant and the chain is empty.
6320 PACKED is 1 if this is for a packed record, -1 if this is for a record
6321 with Component_Alignment of Storage_Unit, -2 if this is for a record
6322 with a specified alignment.
6324 DEFINITION is true if we are defining this record.
6326 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6327 with a rep clause is to be added. If it is nonzero, that is all that
6328 should be done with such fields.
6330 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6331 laying out the record. This means the alignment only serves to force fields
6332 to be bitfields, but not require the record to be that aligned. This is
6335 ALL_REP, if true, means a rep clause was found for all the fields. This
6336 simplifies the logic since we know we're not in the mixed case.
6338 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6339 modified afterwards so it will not be sent to the back-end for finalization.
6341 UNCHECKED_UNION, if true, means that we are building a type for a record
6342 with a Pragma Unchecked_Union.
6344 The processing of the component list fills in the chain with all of the
6345 fields of the record and then the record type is finished. */
6348 components_to_record (tree gnu_record_type, Node_Id component_list,
6349 tree gnu_field_list, int packed, bool definition,
6350 tree *p_gnu_rep_list, bool cancel_alignment,
6351 bool all_rep, bool do_not_finalize, bool unchecked_union)
6353 Node_Id component_decl;
6354 Entity_Id gnat_field;
6355 Node_Id variant_part;
6356 tree gnu_our_rep_list = NULL_TREE;
6357 tree gnu_field, gnu_last;
6358 bool layout_with_rep = false;
6359 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6361 /* For each variable within each component declaration create a GCC field
6362 and add it to the list, skipping any pragmas in the list. */
6363 if (Present (Component_Items (component_list)))
6364 for (component_decl = First_Non_Pragma (Component_Items (component_list));
6365 Present (component_decl);
6366 component_decl = Next_Non_Pragma (component_decl))
6368 gnat_field = Defining_Entity (component_decl);
6370 if (Chars (gnat_field) == Name_uParent)
6371 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
6374 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
6375 packed, definition);
6377 /* If this is the _Tag field, put it before any discriminants,
6378 instead of after them as is the case for all other fields.
6379 Ignore field of void type if only annotating. */
6380 if (Chars (gnat_field) == Name_uTag)
6381 gnu_field_list = chainon (gnu_field_list, gnu_field);
6384 TREE_CHAIN (gnu_field) = gnu_field_list;
6385 gnu_field_list = gnu_field;
6389 save_gnu_tree (gnat_field, gnu_field, false);
6392 /* At the end of the component list there may be a variant part. */
6393 variant_part = Variant_Part (component_list);
6395 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6396 mutually exclusive and should go in the same memory. To do this we need
6397 to treat each variant as a record whose elements are created from the
6398 component list for the variant. So here we create the records from the
6399 lists for the variants and put them all into the QUAL_UNION_TYPE.
6400 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6401 use GNU_RECORD_TYPE if there are no fields so far. */
6402 if (Present (variant_part))
6404 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
6406 tree gnu_name = TYPE_NAME (gnu_record_type);
6408 = concat_id_with_name (get_identifier (Get_Name_String
6409 (Chars (Name (variant_part)))),
6411 tree gnu_union_type;
6412 tree gnu_union_name;
6413 tree gnu_union_field;
6414 tree gnu_variant_list = NULL_TREE;
6416 if (TREE_CODE (gnu_name) == TYPE_DECL)
6417 gnu_name = DECL_NAME (gnu_name);
6419 gnu_union_name = concat_id_with_name (gnu_name,
6420 IDENTIFIER_POINTER (gnu_var_name));
6422 /* Reuse an enclosing union if all fields are in the variant part
6423 and there is no representation clause on the record, to match
6424 the layout of C unions. There is an associated check below. */
6426 && TREE_CODE (gnu_record_type) == UNION_TYPE
6427 && !TYPE_PACKED (gnu_record_type))
6428 gnu_union_type = gnu_record_type;
6432 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6434 TYPE_NAME (gnu_union_type) = gnu_union_name;
6435 TYPE_ALIGN (gnu_union_type) = 0;
6436 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6439 for (variant = First_Non_Pragma (Variants (variant_part));
6441 variant = Next_Non_Pragma (variant))
6443 tree gnu_variant_type = make_node (RECORD_TYPE);
6444 tree gnu_inner_name;
6447 Get_Variant_Encoding (variant);
6448 gnu_inner_name = get_identifier (Name_Buffer);
6449 TYPE_NAME (gnu_variant_type)
6450 = concat_id_with_name (gnu_union_name,
6451 IDENTIFIER_POINTER (gnu_inner_name));
6453 /* Set the alignment of the inner type in case we need to make
6454 inner objects into bitfields, but then clear it out
6455 so the record actually gets only the alignment required. */
6456 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6457 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6459 /* Similarly, if the outer record has a size specified and all fields
6460 have record rep clauses, we can propagate the size into the
6462 if (all_rep_and_size)
6464 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6465 TYPE_SIZE_UNIT (gnu_variant_type)
6466 = TYPE_SIZE_UNIT (gnu_record_type);
6469 /* Create the record type for the variant. Note that we defer
6470 finalizing it until after we are sure to actually use it. */
6471 components_to_record (gnu_variant_type, Component_List (variant),
6472 NULL_TREE, packed, definition,
6473 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6474 true, unchecked_union);
6476 gnu_qual = choices_to_gnu (gnu_discriminant,
6477 Discrete_Choices (variant));
6479 Set_Present_Expr (variant, annotate_value (gnu_qual));
6481 /* If this is an Unchecked_Union and we have exactly one field,
6482 use this field directly to match the layout of C unions. */
6484 && TYPE_FIELDS (gnu_variant_type)
6485 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6486 gnu_field = TYPE_FIELDS (gnu_variant_type);
6489 /* Deal with packedness like in gnat_to_gnu_field. */
6491 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6493 /* Finalize the record type now. We used to throw away
6494 empty records but we no longer do that because we need
6495 them to generate complete debug info for the variant;
6496 otherwise, the union type definition will be lacking
6497 the fields associated with these empty variants. */
6498 rest_of_record_type_compilation (gnu_variant_type);
6500 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6501 gnu_union_type, field_packed,
6503 ? TYPE_SIZE (gnu_variant_type)
6506 ? bitsize_zero_node : 0),
6509 DECL_INTERNAL_P (gnu_field) = 1;
6511 if (!unchecked_union)
6512 DECL_QUALIFIER (gnu_field) = gnu_qual;
6515 TREE_CHAIN (gnu_field) = gnu_variant_list;
6516 gnu_variant_list = gnu_field;
6519 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6520 if (gnu_variant_list)
6522 int union_field_packed;
6524 if (all_rep_and_size)
6526 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6527 TYPE_SIZE_UNIT (gnu_union_type)
6528 = TYPE_SIZE_UNIT (gnu_record_type);
6531 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6532 all_rep_and_size ? 1 : 0, false);
6534 /* If GNU_UNION_TYPE is our record type, it means we must have an
6535 Unchecked_Union with no fields. Verify that and, if so, just
6537 if (gnu_union_type == gnu_record_type)
6539 gcc_assert (unchecked_union
6541 && !gnu_our_rep_list);
6545 /* Deal with packedness like in gnat_to_gnu_field. */
6547 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6550 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6552 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6553 all_rep ? bitsize_zero_node : 0, 0);
6555 DECL_INTERNAL_P (gnu_union_field) = 1;
6556 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6557 gnu_field_list = gnu_union_field;
6561 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6562 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6563 in a separate pass since we want to handle the discriminants but can't
6564 play with them until we've used them in debugging data above.
6566 ??? Note: if we then reorder them, debugging information will be wrong,
6567 but there's nothing that can be done about this at the moment. */
6568 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6570 if (DECL_FIELD_OFFSET (gnu_field))
6572 tree gnu_next = TREE_CHAIN (gnu_field);
6575 gnu_field_list = gnu_next;
6577 TREE_CHAIN (gnu_last) = gnu_next;
6579 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6580 gnu_our_rep_list = gnu_field;
6581 gnu_field = gnu_next;
6585 gnu_last = gnu_field;
6586 gnu_field = TREE_CHAIN (gnu_field);
6590 /* If we have any items in our rep'ed field list, it is not the case that all
6591 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6592 set it and ignore the items. */
6593 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6594 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6595 else if (gnu_our_rep_list)
6597 /* Otherwise, sort the fields by bit position and put them into their
6598 own record if we have any fields without rep clauses. */
6600 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6601 int len = list_length (gnu_our_rep_list);
6602 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6605 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6606 gnu_field = TREE_CHAIN (gnu_field), i++)
6607 gnu_arr[i] = gnu_field;
6609 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6611 /* Put the fields in the list in order of increasing position, which
6612 means we start from the end. */
6613 gnu_our_rep_list = NULL_TREE;
6614 for (i = len - 1; i >= 0; i--)
6616 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6617 gnu_our_rep_list = gnu_arr[i];
6618 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6623 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6624 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6625 gnu_record_type, 0, 0, 0, 1);
6626 DECL_INTERNAL_P (gnu_field) = 1;
6627 gnu_field_list = chainon (gnu_field_list, gnu_field);
6631 layout_with_rep = true;
6632 gnu_field_list = nreverse (gnu_our_rep_list);
6636 if (cancel_alignment)
6637 TYPE_ALIGN (gnu_record_type) = 0;
6639 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6640 layout_with_rep ? 1 : 0, do_not_finalize);
6643 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6644 placed into an Esize, Component_Bit_Offset, or Component_Size value
6645 in the GNAT tree. */
6648 annotate_value (tree gnu_size)
6650 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6652 Node_Ref_Or_Val ops[3], ret;
6655 struct tree_int_map **h = NULL;
6657 /* See if we've already saved the value for this node. */
6658 if (EXPR_P (gnu_size))
6660 struct tree_int_map in;
6661 if (!annotate_value_cache)
6662 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6663 tree_int_map_eq, 0);
6664 in.base.from = gnu_size;
6665 h = (struct tree_int_map **)
6666 htab_find_slot (annotate_value_cache, &in, INSERT);
6669 return (Node_Ref_Or_Val) (*h)->to;
6672 /* If we do not return inside this switch, TCODE will be set to the
6673 code to use for a Create_Node operand and LEN (set above) will be
6674 the number of recursive calls for us to make. */
6676 switch (TREE_CODE (gnu_size))
6679 if (TREE_OVERFLOW (gnu_size))
6682 /* This may have come from a conversion from some smaller type,
6683 so ensure this is in bitsizetype. */
6684 gnu_size = convert (bitsizetype, gnu_size);
6686 /* For negative values, use NEGATE_EXPR of the supplied value. */
6687 if (tree_int_cst_sgn (gnu_size) < 0)
6689 /* The ridiculous code below is to handle the case of the largest
6690 negative integer. */
6691 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6692 bool adjust = false;
6695 if (TREE_OVERFLOW (negative_size))
6698 = size_binop (MINUS_EXPR, bitsize_zero_node,
6699 size_binop (PLUS_EXPR, gnu_size,
6704 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6706 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6708 return annotate_value (temp);
6711 if (!host_integerp (gnu_size, 1))
6714 size = tree_low_cst (gnu_size, 1);
6716 /* This peculiar test is to make sure that the size fits in an int
6717 on machines where HOST_WIDE_INT is not "int". */
6718 if (tree_low_cst (gnu_size, 1) == size)
6719 return UI_From_Int (size);
6724 /* The only case we handle here is a simple discriminant reference. */
6725 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6726 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6727 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6728 return Create_Node (Discrim_Val,
6729 annotate_value (DECL_DISCRIMINANT_NUMBER
6730 (TREE_OPERAND (gnu_size, 1))),
6735 CASE_CONVERT: case NON_LVALUE_EXPR:
6736 return annotate_value (TREE_OPERAND (gnu_size, 0));
6738 /* Now just list the operations we handle. */
6739 case COND_EXPR: tcode = Cond_Expr; break;
6740 case PLUS_EXPR: tcode = Plus_Expr; break;
6741 case MINUS_EXPR: tcode = Minus_Expr; break;
6742 case MULT_EXPR: tcode = Mult_Expr; break;
6743 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
6744 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
6745 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
6746 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
6747 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
6748 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
6749 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
6750 case NEGATE_EXPR: tcode = Negate_Expr; break;
6751 case MIN_EXPR: tcode = Min_Expr; break;
6752 case MAX_EXPR: tcode = Max_Expr; break;
6753 case ABS_EXPR: tcode = Abs_Expr; break;
6754 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
6755 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
6756 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
6757 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
6758 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
6759 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
6760 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
6761 case LT_EXPR: tcode = Lt_Expr; break;
6762 case LE_EXPR: tcode = Le_Expr; break;
6763 case GT_EXPR: tcode = Gt_Expr; break;
6764 case GE_EXPR: tcode = Ge_Expr; break;
6765 case EQ_EXPR: tcode = Eq_Expr; break;
6766 case NE_EXPR: tcode = Ne_Expr; break;
6772 /* Now get each of the operands that's relevant for this code. If any
6773 cannot be expressed as a repinfo node, say we can't. */
6774 for (i = 0; i < 3; i++)
6777 for (i = 0; i < len; i++)
6779 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6780 if (ops[i] == No_Uint)
6784 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6786 /* Save the result in the cache. */
6789 *h = GGC_NEW (struct tree_int_map);
6790 (*h)->base.from = gnu_size;
6797 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6798 GCC type, set Component_Bit_Offset and Esize to the position and size
6802 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6806 Entity_Id gnat_field;
6808 /* We operate by first making a list of all fields and their positions
6809 (we can get the sizes easily at any time) by a recursive call
6810 and then update all the sizes into the tree. */
6811 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6812 size_zero_node, bitsize_zero_node,
6815 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6816 gnat_field = Next_Entity (gnat_field))
6817 if ((Ekind (gnat_field) == E_Component
6818 || (Ekind (gnat_field) == E_Discriminant
6819 && !Is_Unchecked_Union (Scope (gnat_field)))))
6821 tree parent_offset = bitsize_zero_node;
6823 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6828 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6830 /* In this mode the tag and parent components have not been
6831 generated, so we add the appropriate offset to each
6832 component. For a component appearing in the current
6833 extension, the offset is the size of the parent. */
6834 if (Is_Derived_Type (gnat_entity)
6835 && Original_Record_Component (gnat_field) == gnat_field)
6837 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6840 parent_offset = bitsize_int (POINTER_SIZE);
6843 Set_Component_Bit_Offset
6846 (size_binop (PLUS_EXPR,
6847 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6848 TREE_VALUE (TREE_VALUE
6849 (TREE_VALUE (gnu_entry)))),
6852 Set_Esize (gnat_field,
6853 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6855 else if (Is_Tagged_Type (gnat_entity)
6856 && Is_Derived_Type (gnat_entity))
6858 /* If there is no gnu_entry, this is an inherited component whose
6859 position is the same as in the parent type. */
6860 Set_Component_Bit_Offset
6862 Component_Bit_Offset (Original_Record_Component (gnat_field)));
6863 Set_Esize (gnat_field,
6864 Esize (Original_Record_Component (gnat_field)));
6869 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6870 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6871 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6872 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6873 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6874 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6878 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6879 tree gnu_bitpos, unsigned int offset_align)
6882 tree gnu_result = gnu_list;
6884 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6885 gnu_field = TREE_CHAIN (gnu_field))
6887 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6888 DECL_FIELD_BIT_OFFSET (gnu_field));
6889 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6890 DECL_FIELD_OFFSET (gnu_field));
6891 unsigned int our_offset_align
6892 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6895 = tree_cons (gnu_field,
6896 tree_cons (gnu_our_offset,
6897 tree_cons (size_int (our_offset_align),
6898 gnu_our_bitpos, NULL_TREE),
6902 if (DECL_INTERNAL_P (gnu_field))
6904 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6905 gnu_our_offset, gnu_our_bitpos,
6912 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6913 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6914 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6915 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6916 for the size of a field. COMPONENT_P is true if we are being called
6917 to process the Component_Size of GNAT_OBJECT. This is used for error
6918 message handling and to indicate to use the object size of GNU_TYPE.
6919 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6920 it means that a size of zero should be treated as an unspecified size. */
6923 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6924 enum tree_code kind, bool component_p, bool zero_ok)
6926 Node_Id gnat_error_node;
6927 tree type_size, size;
6929 if (kind == VAR_DECL
6930 /* If a type needs strict alignment, a component of this type in
6931 a packed record cannot be packed and thus uses the type size. */
6932 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
6933 type_size = TYPE_SIZE (gnu_type);
6935 type_size = rm_size (gnu_type);
6937 /* Find the node to use for errors. */
6938 if ((Ekind (gnat_object) == E_Component
6939 || Ekind (gnat_object) == E_Discriminant)
6940 && Present (Component_Clause (gnat_object)))
6941 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6942 else if (Present (Size_Clause (gnat_object)))
6943 gnat_error_node = Expression (Size_Clause (gnat_object));
6945 gnat_error_node = gnat_object;
6947 /* Return 0 if no size was specified, either because Esize was not Present or
6948 the specified size was zero. */
6949 if (No (uint_size) || uint_size == No_Uint)
6952 /* Get the size as a tree. Give an error if a size was specified, but cannot
6953 be represented as in sizetype. */
6954 size = UI_To_gnu (uint_size, bitsizetype);
6955 if (TREE_OVERFLOW (size))
6957 post_error_ne (component_p ? "component size of & is too large"
6958 : "size of & is too large",
6959 gnat_error_node, gnat_object);
6963 /* Ignore a negative size since that corresponds to our back-annotation.
6964 Also ignore a zero size unless a size clause exists. */
6965 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6968 /* The size of objects is always a multiple of a byte. */
6969 if (kind == VAR_DECL
6970 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6973 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6974 gnat_error_node, gnat_object);
6976 post_error_ne ("size for& is not a multiple of Storage_Unit",
6977 gnat_error_node, gnat_object);
6981 /* If this is an integral type or a packed array type, the front-end has
6982 verified the size, so we need not do it here (which would entail
6983 checking against the bounds). However, if this is an aliased object, it
6984 may not be smaller than the type of the object. */
6985 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
6986 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
6989 /* If the object is a record that contains a template, add the size of
6990 the template to the specified size. */
6991 if (TREE_CODE (gnu_type) == RECORD_TYPE
6992 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6993 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
6995 /* Modify the size of the type to be that of the maximum size if it has a
6997 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
6998 type_size = max_size (type_size, true);
7000 /* If this is an access type or a fat pointer, the minimum size is that given
7001 by the smallest integral mode that's valid for pointers. */
7002 if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
7004 enum machine_mode p_mode;
7006 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7007 !targetm.valid_pointer_mode (p_mode);
7008 p_mode = GET_MODE_WIDER_MODE (p_mode))
7011 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7014 /* If the size of the object is a constant, the new size must not be
7016 if (TREE_CODE (type_size) != INTEGER_CST
7017 || TREE_OVERFLOW (type_size)
7018 || tree_int_cst_lt (size, type_size))
7022 ("component size for& too small{, minimum allowed is ^}",
7023 gnat_error_node, gnat_object, type_size);
7025 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7026 gnat_error_node, gnat_object, type_size);
7028 if (kind == VAR_DECL && !component_p
7029 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7030 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7031 post_error_ne_tree_2
7032 ("\\size of ^ is not a multiple of alignment (^ bits)",
7033 gnat_error_node, gnat_object, rm_size (gnu_type),
7034 TYPE_ALIGN (gnu_type));
7036 else if (INTEGRAL_TYPE_P (gnu_type))
7037 post_error_ne ("\\size would be legal if & were not aliased!",
7038 gnat_error_node, gnat_object);
7046 /* Similarly, but both validate and process a value of RM_Size. This
7047 routine is only called for types. */
7050 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7052 /* Only give an error if a Value_Size clause was explicitly given.
7053 Otherwise, we'd be duplicating an error on the Size clause. */
7054 Node_Id gnat_attr_node
7055 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7056 tree old_size = rm_size (gnu_type);
7059 /* Get the size as a tree. Do nothing if none was specified, either
7060 because RM_Size was not Present or if the specified size was zero.
7061 Give an error if a size was specified, but cannot be represented as
7063 if (No (uint_size) || uint_size == No_Uint)
7066 size = UI_To_gnu (uint_size, bitsizetype);
7067 if (TREE_OVERFLOW (size))
7069 if (Present (gnat_attr_node))
7070 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7076 /* Ignore a negative size since that corresponds to our back-annotation.
7077 Also ignore a zero size unless a size clause exists, a Value_Size
7078 clause exists, or this is an integer type, in which case the
7079 front end will have always set it. */
7080 else if (tree_int_cst_sgn (size) < 0
7081 || (integer_zerop (size) && No (gnat_attr_node)
7082 && !Has_Size_Clause (gnat_entity)
7083 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7086 /* If the old size is self-referential, get the maximum size. */
7087 if (CONTAINS_PLACEHOLDER_P (old_size))
7088 old_size = max_size (old_size, true);
7090 /* If the size of the object is a constant, the new size must not be
7091 smaller (the front end checks this for scalar types). */
7092 if (TREE_CODE (old_size) != INTEGER_CST
7093 || TREE_OVERFLOW (old_size)
7094 || (AGGREGATE_TYPE_P (gnu_type)
7095 && tree_int_cst_lt (size, old_size)))
7097 if (Present (gnat_attr_node))
7099 ("Value_Size for& too small{, minimum allowed is ^}",
7100 gnat_attr_node, gnat_entity, old_size);
7105 /* Otherwise, set the RM_Size. */
7106 if (TREE_CODE (gnu_type) == INTEGER_TYPE
7107 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7108 TYPE_RM_SIZE_NUM (gnu_type) = size;
7109 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
7110 TYPE_RM_SIZE_NUM (gnu_type) = size;
7111 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7112 || TREE_CODE (gnu_type) == UNION_TYPE
7113 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7114 && !TYPE_IS_FAT_POINTER_P (gnu_type))
7115 SET_TYPE_ADA_SIZE (gnu_type, size);
7118 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7119 If TYPE is the best type, return it. Otherwise, make a new type. We
7120 only support new integral and pointer types. FOR_BIASED is nonzero if
7121 we are making a biased type. */
7124 make_type_from_size (tree type, tree size_tree, bool for_biased)
7126 unsigned HOST_WIDE_INT size;
7130 /* If size indicates an error, just return TYPE to avoid propagating
7131 the error. Likewise if it's too large to represent. */
7132 if (!size_tree || !host_integerp (size_tree, 1))
7135 size = tree_low_cst (size_tree, 1);
7137 switch (TREE_CODE (type))
7141 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7142 && TYPE_BIASED_REPRESENTATION_P (type));
7144 /* Only do something if the type is not a packed array type and
7145 doesn't already have the proper size. */
7146 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7147 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7150 biased_p |= for_biased;
7151 size = MIN (size, LONG_LONG_TYPE_SIZE);
7153 if (TYPE_UNSIGNED (type) || biased_p)
7154 new_type = make_unsigned_type (size);
7156 new_type = make_signed_type (size);
7157 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7158 TYPE_MIN_VALUE (new_type)
7159 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
7160 TYPE_MAX_VALUE (new_type)
7161 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
7162 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7163 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
7167 /* Do something if this is a fat pointer, in which case we
7168 may need to return the thin pointer. */
7169 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7171 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7172 if (!targetm.valid_pointer_mode (p_mode))
7175 build_pointer_type_for_mode
7176 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7182 /* Only do something if this is a thin pointer, in which case we
7183 may need to return the fat pointer. */
7184 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7186 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7196 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7197 a type or object whose present alignment is ALIGN. If this alignment is
7198 valid, return it. Otherwise, give an error and return ALIGN. */
7201 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7203 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7204 unsigned int new_align;
7205 Node_Id gnat_error_node;
7207 /* Don't worry about checking alignment if alignment was not specified
7208 by the source program and we already posted an error for this entity. */
7209 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7212 /* Post the error on the alignment clause if any. */
7213 if (Present (Alignment_Clause (gnat_entity)))
7214 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7216 gnat_error_node = gnat_entity;
7218 /* Within GCC, an alignment is an integer, so we must make sure a value is
7219 specified that fits in that range. Also, there is an upper bound to
7220 alignments we can support/allow. */
7221 if (!UI_Is_In_Int_Range (alignment)
7222 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7223 post_error_ne_num ("largest supported alignment for& is ^",
7224 gnat_error_node, gnat_entity, max_allowed_alignment);
7225 else if (!(Present (Alignment_Clause (gnat_entity))
7226 && From_At_Mod (Alignment_Clause (gnat_entity)))
7227 && new_align * BITS_PER_UNIT < align)
7228 post_error_ne_num ("alignment for& must be at least ^",
7229 gnat_error_node, gnat_entity,
7230 align / BITS_PER_UNIT);
7233 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7234 if (new_align > align)
7241 /* Return the smallest alignment not less than SIZE. */
7244 ceil_alignment (unsigned HOST_WIDE_INT size)
7246 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7249 /* Verify that OBJECT, a type or decl, is something we can implement
7250 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7251 if we require atomic components. */
7254 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7256 Node_Id gnat_error_point = gnat_entity;
7258 enum machine_mode mode;
7262 /* There are three case of what OBJECT can be. It can be a type, in which
7263 case we take the size, alignment and mode from the type. It can be a
7264 declaration that was indirect, in which case the relevant values are
7265 that of the type being pointed to, or it can be a normal declaration,
7266 in which case the values are of the decl. The code below assumes that
7267 OBJECT is either a type or a decl. */
7268 if (TYPE_P (object))
7270 mode = TYPE_MODE (object);
7271 align = TYPE_ALIGN (object);
7272 size = TYPE_SIZE (object);
7274 else if (DECL_BY_REF_P (object))
7276 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7277 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7278 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7282 mode = DECL_MODE (object);
7283 align = DECL_ALIGN (object);
7284 size = DECL_SIZE (object);
7287 /* Consider all floating-point types atomic and any types that that are
7288 represented by integers no wider than a machine word. */
7289 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7290 || ((GET_MODE_CLASS (mode) == MODE_INT
7291 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7292 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7295 /* For the moment, also allow anything that has an alignment equal
7296 to its size and which is smaller than a word. */
7297 if (size && TREE_CODE (size) == INTEGER_CST
7298 && compare_tree_int (size, align) == 0
7299 && align <= BITS_PER_WORD)
7302 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7303 gnat_node = Next_Rep_Item (gnat_node))
7305 if (!comp_p && Nkind (gnat_node) == N_Pragma
7306 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7308 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7309 else if (comp_p && Nkind (gnat_node) == N_Pragma
7310 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7311 == Pragma_Atomic_Components))
7312 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7316 post_error_ne ("atomic access to component of & cannot be guaranteed",
7317 gnat_error_point, gnat_entity);
7319 post_error_ne ("atomic access to & cannot be guaranteed",
7320 gnat_error_point, gnat_entity);
7323 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7324 have compatible signatures so that a call using one type may be safely
7325 issued if the actual target function type is the other. Return 1 if it is
7326 the case, 0 otherwise, and post errors on the incompatibilities.
7328 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7329 that calls to the subprogram will have arguments suitable for the later
7330 underlying builtin expansion. */
7333 compatible_signatures_p (tree ftype1, tree ftype2)
7335 /* As of now, we only perform very trivial tests and consider it's the
7336 programmer's responsibility to ensure the type correctness in the Ada
7337 declaration, as in the regular Import cases.
7339 Mismatches typically result in either error messages from the builtin
7340 expander, internal compiler errors, or in a real call sequence. This
7341 should be refined to issue diagnostics helping error detection and
7344 /* Almost fake test, ensuring a use of each argument. */
7345 if (ftype1 == ftype2)
7351 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7352 type with all size expressions that contain F updated by replacing F
7353 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
7354 nothing has changed. */
7357 substitute_in_type (tree t, tree f, tree r)
7362 switch (TREE_CODE (t))
7367 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7368 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7370 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7371 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7373 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7376 new = build_range_type (TREE_TYPE (t), low, high);
7377 if (TYPE_INDEX_TYPE (t))
7379 (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
7386 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7387 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7389 tree low = NULL_TREE, high = NULL_TREE;
7391 if (TYPE_MIN_VALUE (t))
7392 low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7393 if (TYPE_MAX_VALUE (t))
7394 high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7396 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7400 TYPE_MIN_VALUE (t) = low;
7401 TYPE_MAX_VALUE (t) = high;
7406 tem = substitute_in_type (TREE_TYPE (t), f, r);
7407 if (tem == TREE_TYPE (t))
7410 return build_complex_type (tem);
7416 /* Don't know how to do these yet. */
7421 tree component = substitute_in_type (TREE_TYPE (t), f, r);
7422 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
7424 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
7427 new = build_array_type (component, domain);
7428 TYPE_SIZE (new) = 0;
7429 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
7430 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
7432 TYPE_ALIGN (new) = TYPE_ALIGN (t);
7433 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
7435 /* If we had bounded the sizes of T by a constant, bound the sizes of
7436 NEW by the same constant. */
7437 if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
7439 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
7441 if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
7442 TYPE_SIZE_UNIT (new)
7443 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
7444 TYPE_SIZE_UNIT (new));
7450 case QUAL_UNION_TYPE:
7454 = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
7455 bool field_has_rep = false;
7456 tree last_field = NULL_TREE;
7458 tree new = copy_type (t);
7460 /* Start out with no fields, make new fields, and chain them
7461 in. If we haven't actually changed the type of any field,
7462 discard everything we've done and return the old type. */
7464 TYPE_FIELDS (new) = NULL_TREE;
7465 TYPE_SIZE (new) = NULL_TREE;
7467 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
7469 tree new_field = copy_node (field);
7471 TREE_TYPE (new_field)
7472 = substitute_in_type (TREE_TYPE (new_field), f, r);
7474 if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
7475 field_has_rep = true;
7476 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
7477 changed_field = true;
7479 /* If this is an internal field and the type of this field is
7480 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7481 the type just has one element, treat that as the field.
7482 But don't do this if we are processing a QUAL_UNION_TYPE. */
7483 if (TREE_CODE (t) != QUAL_UNION_TYPE
7484 && DECL_INTERNAL_P (new_field)
7485 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
7486 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
7488 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
7491 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
7494 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
7496 /* Make sure omitting the union doesn't change
7498 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
7499 new_field = next_new_field;
7503 DECL_CONTEXT (new_field) = new;
7504 SET_DECL_ORIGINAL_FIELD (new_field,
7505 (DECL_ORIGINAL_FIELD (field)
7506 ? DECL_ORIGINAL_FIELD (field) : field));
7508 /* If the size of the old field was set at a constant,
7509 propagate the size in case the type's size was variable.
7510 (This occurs in the case of a variant or discriminated
7511 record with a default size used as a field of another
7513 DECL_SIZE (new_field)
7514 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
7515 ? DECL_SIZE (field) : NULL_TREE;
7516 DECL_SIZE_UNIT (new_field)
7517 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
7518 ? DECL_SIZE_UNIT (field) : NULL_TREE;
7520 if (TREE_CODE (t) == QUAL_UNION_TYPE)
7522 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7524 if (new_q != DECL_QUALIFIER (new_field))
7525 changed_field = true;
7527 /* Do the substitution inside the qualifier and if we find
7528 that this field will not be present, omit it. */
7529 DECL_QUALIFIER (new_field) = new_q;
7531 if (integer_zerop (DECL_QUALIFIER (new_field)))
7536 TYPE_FIELDS (new) = new_field;
7538 TREE_CHAIN (last_field) = new_field;
7540 last_field = new_field;
7542 /* If this is a qualified type and this field will always be
7543 present, we are done. */
7544 if (TREE_CODE (t) == QUAL_UNION_TYPE
7545 && integer_onep (DECL_QUALIFIER (new_field)))
7549 /* If this used to be a qualified union type, but we now know what
7550 field will be present, make this a normal union. */
7551 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
7552 && (!TYPE_FIELDS (new)
7553 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7554 TREE_SET_CODE (new, UNION_TYPE);
7555 else if (!changed_field)
7558 gcc_assert (!field_has_rep);
7561 /* If the size was originally a constant use it. */
7562 if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
7563 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
7565 TYPE_SIZE (new) = TYPE_SIZE (t);
7566 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
7567 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
7578 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7579 needed to represent the object. */
7582 rm_size (tree gnu_type)
7584 /* For integer types, this is the precision. For record types, we store
7585 the size explicitly. For other types, this is just the size. */
7587 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7588 return TYPE_RM_SIZE (gnu_type);
7589 else if (TREE_CODE (gnu_type) == RECORD_TYPE
7590 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7591 /* Return the rm_size of the actual data plus the size of the template. */
7593 size_binop (PLUS_EXPR,
7594 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7595 DECL_SIZE (TYPE_FIELDS (gnu_type)));
7596 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7597 || TREE_CODE (gnu_type) == UNION_TYPE
7598 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7599 && !TYPE_IS_FAT_POINTER_P (gnu_type)
7600 && TYPE_ADA_SIZE (gnu_type))
7601 return TYPE_ADA_SIZE (gnu_type);
7603 return TYPE_SIZE (gnu_type);
7606 /* Return an identifier representing the external name to be used for
7607 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7608 and the specified suffix. */
7611 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7613 Entity_Kind kind = Ekind (gnat_entity);
7615 const char *str = (!suffix ? "" : suffix);
7616 String_Template temp = {1, strlen (str)};
7617 Fat_Pointer fp = {str, &temp};
7619 Get_External_Name_With_Suffix (gnat_entity, fp);
7621 /* A variable using the Stdcall convention (meaning we are running
7622 on a Windows box) live in a DLL. Here we adjust its name to use
7623 the jump-table, the _imp__NAME contains the address for the NAME
7625 if ((kind == E_Variable || kind == E_Constant)
7626 && Has_Stdcall_Convention (gnat_entity))
7628 const char *prefix = "_imp__";
7629 int k, plen = strlen (prefix);
7631 for (k = 0; k <= Name_Len; k++)
7632 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
7633 strncpy (Name_Buffer, prefix, plen);
7636 return get_identifier (Name_Buffer);
7639 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7640 fully-qualified name, possibly with type information encoding.
7641 Otherwise, return the name. */
7644 get_entity_name (Entity_Id gnat_entity)
7646 Get_Encoded_Name (gnat_entity);
7647 return get_identifier (Name_Buffer);
7650 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7651 string, return a new IDENTIFIER_NODE that is the concatenation of
7652 the name in GNU_ID and SUFFIX. */
7655 concat_id_with_name (tree gnu_id, const char *suffix)
7657 int len = IDENTIFIER_LENGTH (gnu_id);
7659 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
7660 strncpy (Name_Buffer + len, "___", 3);
7662 strcpy (Name_Buffer + len, suffix);
7663 return get_identifier (Name_Buffer);
7666 #include "gt-ada-decl.h"