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 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4778 /* The parameter can be indirectly modified if its address is taken. */
4779 bool ro_param = in_param && !Address_Taken (gnat_param);
4780 bool by_return = false, by_component_ptr = false, by_ref = false;
4783 /* Copy-return is used only for the first parameter of a valued procedure.
4784 It's a copy mechanism for which a parameter is never allocated. */
4785 if (mech == By_Copy_Return)
4787 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4792 /* If this is either a foreign function or if the underlying type won't
4793 be passed by reference, strip off possible padding type. */
4794 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4795 && TYPE_IS_PADDING_P (gnu_param_type))
4797 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4799 if (mech == By_Reference
4801 || (!must_pass_by_ref (unpadded_type)
4802 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4803 gnu_param_type = unpadded_type;
4806 /* If this is a read-only parameter, make a variant of the type that is
4807 read-only. ??? However, if this is an unconstrained array, that type
4808 can be very complex, so skip it for now. Likewise for any other
4809 self-referential type. */
4811 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4812 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4813 gnu_param_type = build_qualified_type (gnu_param_type,
4814 (TYPE_QUALS (gnu_param_type)
4815 | TYPE_QUAL_CONST));
4817 /* For foreign conventions, pass arrays as pointers to the element type.
4818 First check for unconstrained array and get the underlying array. */
4819 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4821 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4823 /* VMS descriptors are themselves passed by reference. */
4824 if (mech == By_Descriptor)
4826 = build_pointer_type (build_vms_descriptor (gnu_param_type,
4827 Mechanism (gnat_param),
4830 /* Arrays are passed as pointers to element type for foreign conventions. */
4833 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4835 /* Strip off any multi-dimensional entries, then strip
4836 off the last array to get the component type. */
4837 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4838 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4839 gnu_param_type = TREE_TYPE (gnu_param_type);
4841 by_component_ptr = true;
4842 gnu_param_type = TREE_TYPE (gnu_param_type);
4845 gnu_param_type = build_qualified_type (gnu_param_type,
4846 (TYPE_QUALS (gnu_param_type)
4847 | TYPE_QUAL_CONST));
4849 gnu_param_type = build_pointer_type (gnu_param_type);
4852 /* Fat pointers are passed as thin pointers for foreign conventions. */
4853 else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
4855 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
4857 /* If we must pass or were requested to pass by reference, do so.
4858 If we were requested to pass by copy, do so.
4859 Otherwise, for foreign conventions, pass In Out or Out parameters
4860 or aggregates by reference. For COBOL and Fortran, pass all
4861 integer and FP types that way too. For Convention Ada, use
4862 the standard Ada default. */
4863 else if (must_pass_by_ref (gnu_param_type)
4864 || mech == By_Reference
4867 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
4869 && (Convention (gnat_subprog) == Convention_Fortran
4870 || Convention (gnat_subprog) == Convention_COBOL)
4871 && (INTEGRAL_TYPE_P (gnu_param_type)
4872 || FLOAT_TYPE_P (gnu_param_type)))
4874 && default_pass_by_ref (gnu_param_type)))))
4876 gnu_param_type = build_reference_type (gnu_param_type);
4880 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
4884 if (mech == By_Copy && (by_ref || by_component_ptr))
4885 post_error ("?cannot pass & by copy", gnat_param);
4887 /* If this is an Out parameter that isn't passed by reference and isn't
4888 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4889 it will be a VAR_DECL created when we process the procedure, so just
4890 return its type. For the special parameter of a valued procedure,
4893 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4894 Out parameters with discriminants or implicit initial values to be
4895 handled like In Out parameters. These type are normally built as
4896 aggregates, hence passed by reference, except for some packed arrays
4897 which end up encoded in special integer types.
4899 The exception we need to make is then for packed arrays of records
4900 with discriminants or implicit initial values. We have no light/easy
4901 way to check for the latter case, so we merely check for packed arrays
4902 of records. This may lead to useless copy-in operations, but in very
4903 rare cases only, as these would be exceptions in a set of already
4904 exceptional situations. */
4905 if (Ekind (gnat_param) == E_Out_Parameter
4908 || (mech != By_Descriptor
4909 && !POINTER_TYPE_P (gnu_param_type)
4910 && !AGGREGATE_TYPE_P (gnu_param_type)))
4911 && !(Is_Array_Type (Etype (gnat_param))
4912 && Is_Packed (Etype (gnat_param))
4913 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
4914 return gnu_param_type;
4916 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
4917 ro_param || by_ref || by_component_ptr);
4918 DECL_BY_REF_P (gnu_param) = by_ref;
4919 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
4920 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
4921 DECL_POINTS_TO_READONLY_P (gnu_param)
4922 = (ro_param && (by_ref || by_component_ptr));
4924 /* If no Mechanism was specified, indicate what we're using, then
4925 back-annotate it. */
4926 if (mech == Default)
4927 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
4929 Set_Mechanism (gnat_param, mech);
4933 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4936 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4938 while (Present (Corresponding_Discriminant (discr1)))
4939 discr1 = Corresponding_Discriminant (discr1);
4941 while (Present (Corresponding_Discriminant (discr2)))
4942 discr2 = Corresponding_Discriminant (discr2);
4945 Original_Record_Component (discr1) == Original_Record_Component (discr2);
4948 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4949 a non-aliased component in the back-end sense. */
4952 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
4954 /* If the type below this is a multi-array type, then
4955 this does not have aliased components. */
4956 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4957 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
4960 if (Has_Aliased_Components (gnat_type))
4963 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
4966 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4967 be elaborated at the point of its definition, but do nothing else. */
4970 elaborate_entity (Entity_Id gnat_entity)
4972 switch (Ekind (gnat_entity))
4974 case E_Signed_Integer_Subtype:
4975 case E_Modular_Integer_Subtype:
4976 case E_Enumeration_Subtype:
4977 case E_Ordinary_Fixed_Point_Subtype:
4978 case E_Decimal_Fixed_Point_Subtype:
4979 case E_Floating_Point_Subtype:
4981 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4982 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4984 /* ??? Tests for avoiding static constraint error expression
4985 is needed until the front stops generating bogus conversions
4986 on bounds of real types. */
4988 if (!Raises_Constraint_Error (gnat_lb))
4989 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4990 1, 0, Needs_Debug_Info (gnat_entity));
4991 if (!Raises_Constraint_Error (gnat_hb))
4992 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4993 1, 0, Needs_Debug_Info (gnat_entity));
4999 Node_Id full_definition = Declaration_Node (gnat_entity);
5000 Node_Id record_definition = Type_Definition (full_definition);
5002 /* If this is a record extension, go a level further to find the
5003 record definition. */
5004 if (Nkind (record_definition) == N_Derived_Type_Definition)
5005 record_definition = Record_Extension_Part (record_definition);
5009 case E_Record_Subtype:
5010 case E_Private_Subtype:
5011 case E_Limited_Private_Subtype:
5012 case E_Record_Subtype_With_Private:
5013 if (Is_Constrained (gnat_entity)
5014 && Has_Discriminants (Base_Type (gnat_entity))
5015 && Present (Discriminant_Constraint (gnat_entity)))
5017 Node_Id gnat_discriminant_expr;
5018 Entity_Id gnat_field;
5020 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
5021 gnat_discriminant_expr
5022 = First_Elmt (Discriminant_Constraint (gnat_entity));
5023 Present (gnat_field);
5024 gnat_field = Next_Discriminant (gnat_field),
5025 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5026 /* ??? For now, ignore access discriminants. */
5027 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5028 elaborate_expression (Node (gnat_discriminant_expr),
5030 get_entity_name (gnat_field), 1, 0, 0);
5037 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5038 any entities on its entity chain similarly. */
5041 mark_out_of_scope (Entity_Id gnat_entity)
5043 Entity_Id gnat_sub_entity;
5044 unsigned int kind = Ekind (gnat_entity);
5046 /* If this has an entity list, process all in the list. */
5047 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5048 || IN (kind, Private_Kind)
5049 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5050 || kind == E_Function || kind == E_Generic_Function
5051 || kind == E_Generic_Package || kind == E_Generic_Procedure
5052 || kind == E_Loop || kind == E_Operator || kind == E_Package
5053 || kind == E_Package_Body || kind == E_Procedure
5054 || kind == E_Record_Type || kind == E_Record_Subtype
5055 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5056 for (gnat_sub_entity = First_Entity (gnat_entity);
5057 Present (gnat_sub_entity);
5058 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5059 if (Scope (gnat_sub_entity) == gnat_entity
5060 && gnat_sub_entity != gnat_entity)
5061 mark_out_of_scope (gnat_sub_entity);
5063 /* Now clear this if it has been defined, but only do so if it isn't
5064 a subprogram or parameter. We could refine this, but it isn't
5065 worth it. If this is statically allocated, it is supposed to
5066 hang around out of cope. */
5067 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5068 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5070 save_gnu_tree (gnat_entity, NULL_TREE, true);
5071 save_gnu_tree (gnat_entity, error_mark_node, true);
5075 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
5076 is a multi-dimensional array type, do this recursively. */
5079 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
5081 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5082 of a one-dimensional array, since the padding has the same alias set
5083 as the field type, but if it's a multi-dimensional array, we need to
5084 see the inner types. */
5085 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5086 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5087 || TYPE_IS_PADDING_P (gnu_old_type)))
5088 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5090 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
5091 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
5092 so we need to go down to what does. */
5093 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5095 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5097 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5098 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5099 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5100 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
5102 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5103 record_component_aliases (gnu_new_type);
5106 /* Return a TREE_LIST describing the substitutions needed to reflect
5107 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5108 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
5109 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
5110 gives the tree for the discriminant and TREE_VALUES is the replacement
5111 value. They are in the form of operands to substitute_in_expr.
5112 DEFINITION is as in gnat_to_gnu_entity. */
5115 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
5116 tree gnu_list, bool definition)
5118 Entity_Id gnat_discrim;
5122 gnat_type = Implementation_Base_Type (gnat_subtype);
5124 if (Has_Discriminants (gnat_type))
5125 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
5126 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
5127 Present (gnat_discrim);
5128 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
5129 gnat_value = Next_Elmt (gnat_value))
5130 /* Ignore access discriminants. */
5131 if (!Is_Access_Type (Etype (Node (gnat_value))))
5132 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
5133 elaborate_expression
5134 (Node (gnat_value), gnat_subtype,
5135 get_entity_name (gnat_discrim), definition,
5142 /* Return true if the size represented by GNU_SIZE can be handled by an
5143 allocation. If STATIC_P is true, consider only what can be done with a
5144 static allocation. */
5147 allocatable_size_p (tree gnu_size, bool static_p)
5149 HOST_WIDE_INT our_size;
5151 /* If this is not a static allocation, the only case we want to forbid
5152 is an overflowing size. That will be converted into a raise a
5155 return !(TREE_CODE (gnu_size) == INTEGER_CST
5156 && TREE_OVERFLOW (gnu_size));
5158 /* Otherwise, we need to deal with both variable sizes and constant
5159 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5160 since assemblers may not like very large sizes. */
5161 if (!host_integerp (gnu_size, 1))
5164 our_size = tree_low_cst (gnu_size, 1);
5165 return (int) our_size == our_size;
5168 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5169 NAME, ARGS and ERROR_POINT. */
5172 prepend_one_attribute_to (struct attrib ** attr_list,
5173 enum attr_type attr_type,
5176 Node_Id attr_error_point)
5178 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5180 attr->type = attr_type;
5181 attr->name = attr_name;
5182 attr->args = attr_args;
5183 attr->error_point = attr_error_point;
5185 attr->next = *attr_list;
5189 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5192 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5196 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5197 gnat_temp = Next_Rep_Item (gnat_temp))
5198 if (Nkind (gnat_temp) == N_Pragma)
5200 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5201 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5202 enum attr_type etype;
5204 if (Present (gnat_assoc) && Present (First (gnat_assoc))
5205 && Present (Next (First (gnat_assoc)))
5206 && (Nkind (Expression (Next (First (gnat_assoc))))
5207 == N_String_Literal))
5209 gnu_arg0 = get_identifier (TREE_STRING_POINTER
5212 (First (gnat_assoc))))));
5213 if (Present (Next (Next (First (gnat_assoc))))
5214 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
5215 == N_String_Literal))
5216 gnu_arg1 = get_identifier (TREE_STRING_POINTER
5220 (First (gnat_assoc)))))));
5223 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5225 case Pragma_Machine_Attribute:
5226 etype = ATTR_MACHINE_ATTRIBUTE;
5229 case Pragma_Linker_Alias:
5230 etype = ATTR_LINK_ALIAS;
5233 case Pragma_Linker_Section:
5234 etype = ATTR_LINK_SECTION;
5237 case Pragma_Linker_Constructor:
5238 etype = ATTR_LINK_CONSTRUCTOR;
5241 case Pragma_Linker_Destructor:
5242 etype = ATTR_LINK_DESTRUCTOR;
5245 case Pragma_Weak_External:
5246 etype = ATTR_WEAK_EXTERNAL;
5254 /* Prepend to the list now. Make a list of the argument we might
5255 have, as GCC expects it. */
5256 prepend_one_attribute_to
5259 (gnu_arg1 != NULL_TREE)
5260 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5261 Present (Next (First (gnat_assoc)))
5262 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5266 /* Get the unpadded version of a GNAT type. */
5269 get_unpadded_type (Entity_Id gnat_entity)
5271 tree type = gnat_to_gnu_type (gnat_entity);
5273 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5274 type = TREE_TYPE (TYPE_FIELDS (type));
5279 /* Called when we need to protect a variable object using a save_expr. */
5282 maybe_variable (tree gnu_operand)
5284 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
5285 || TREE_CODE (gnu_operand) == SAVE_EXPR
5286 || TREE_CODE (gnu_operand) == NULL_EXPR)
5289 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5291 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
5292 TREE_TYPE (gnu_operand),
5293 variable_size (TREE_OPERAND (gnu_operand, 0)));
5295 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5296 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5300 return variable_size (gnu_operand);
5303 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5304 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5305 return the GCC tree to use for that expression. GNU_NAME is the
5306 qualification to use if an external name is appropriate and DEFINITION is
5307 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
5308 we need a result. Otherwise, we are just elaborating this for
5309 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
5310 purposes even if it isn't needed for code generation. */
5313 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
5314 tree gnu_name, bool definition, bool need_value,
5319 /* If we already elaborated this expression (e.g., it was involved
5320 in the definition of a private type), use the old value. */
5321 if (present_gnu_tree (gnat_expr))
5322 return get_gnu_tree (gnat_expr);
5324 /* If we don't need a value and this is static or a discriminant, we
5325 don't need to do anything. */
5326 else if (!need_value
5327 && (Is_OK_Static_Expression (gnat_expr)
5328 || (Nkind (gnat_expr) == N_Identifier
5329 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5332 /* Otherwise, convert this tree to its GCC equivalent. */
5334 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5335 gnu_name, definition, need_debug);
5337 /* Save the expression in case we try to elaborate this entity again. Since
5338 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5339 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5340 save_gnu_tree (gnat_expr, gnu_expr, true);
5342 return need_value ? gnu_expr : error_mark_node;
5345 /* Similar, but take a GNU expression. */
5348 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5349 tree gnu_expr, tree gnu_name, bool definition,
5352 tree gnu_decl = NULL_TREE;
5353 /* Skip any conversions and simple arithmetics to see if the expression
5354 is a read-only variable.
5355 ??? This really should remain read-only, but we have to think about
5356 the typing of the tree here. */
5358 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5359 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5362 /* In most cases, we won't see a naked FIELD_DECL here because a
5363 discriminant reference will have been replaced with a COMPONENT_REF
5364 when the type is being elaborated. However, there are some cases
5365 involving child types where we will. So convert it to a COMPONENT_REF
5366 here. We have to hope it will be at the highest level of the
5367 expression in these cases. */
5368 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5369 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5370 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5371 gnu_expr, NULL_TREE);
5373 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5374 that is read-only, make a variable that is initialized to contain the
5375 bound when the package containing the definition is elaborated. If
5376 this entity is defined at top level and a bound or discriminant value
5377 isn't a constant or a reference to a discriminant, replace the bound
5378 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5379 rely here on the fact that an expression cannot contain both the
5380 discriminant and some other variable. */
5382 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5383 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5384 && (TREE_READONLY (gnu_inner_expr)
5385 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5386 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5388 /* If this is a static expression or contains a discriminant, we don't
5389 need the variable for debugging (and can't elaborate anyway if a
5392 && (Is_OK_Static_Expression (gnat_expr)
5393 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5396 /* Now create the variable if we need it. */
5397 if (need_debug || (expr_variable && expr_global))
5399 = create_var_decl (create_concat_name (gnat_entity,
5400 IDENTIFIER_POINTER (gnu_name)),
5401 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5402 !need_debug, Is_Public (gnat_entity),
5403 !definition, false, NULL, gnat_entity);
5405 /* We only need to use this variable if we are in global context since GCC
5406 can do the right thing in the local case. */
5407 if (expr_global && expr_variable)
5409 else if (!expr_variable)
5412 return maybe_variable (gnu_expr);
5415 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5416 starting bit position so that it is aligned to ALIGN bits, and leaving at
5417 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5418 record is guaranteed to get. */
5421 make_aligning_type (tree type, unsigned int align, tree size,
5422 unsigned int base_align, int room)
5424 /* We will be crafting a record type with one field at a position set to be
5425 the next multiple of ALIGN past record'address + room bytes. We use a
5426 record placeholder to express record'address. */
5428 tree record_type = make_node (RECORD_TYPE);
5429 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5432 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5434 /* The diagram below summarizes the shape of what we manipulate:
5436 <--------- pos ---------->
5437 { +------------+-------------+-----------------+
5438 record =>{ |############| ... | field (type) |
5439 { +------------+-------------+-----------------+
5440 |<-- room -->|<- voffset ->|<---- size ----->|
5443 record_addr vblock_addr
5445 Every length is in sizetype bytes there, except "pos" which has to be
5446 set as a bit position in the GCC tree for the record. */
5448 tree room_st = size_int (room);
5449 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5450 tree voffset_st, pos, field;
5452 tree name = TYPE_NAME (type);
5454 if (TREE_CODE (name) == TYPE_DECL)
5455 name = DECL_NAME (name);
5457 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
5459 /* Compute VOFFSET and then POS. The next byte position multiple of some
5460 alignment after some address is obtained by "and"ing the alignment minus
5461 1 with the two's complement of the address. */
5463 voffset_st = size_binop (BIT_AND_EXPR,
5464 size_diffop (size_zero_node, vblock_addr_st),
5465 ssize_int ((align / BITS_PER_UNIT) - 1));
5467 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5469 pos = size_binop (MULT_EXPR,
5470 convert (bitsizetype,
5471 size_binop (PLUS_EXPR, room_st, voffset_st)),
5474 /* Craft the GCC record representation. We exceptionally do everything
5475 manually here because 1) our generic circuitry is not quite ready to
5476 handle the complex position/size expressions we are setting up, 2) we
5477 have a strong simplifying factor at hand: we know the maximum possible
5478 value of voffset, and 3) we have to set/reset at least the sizes in
5479 accordance with this maximum value anyway, as we need them to convey
5480 what should be "alloc"ated for this type.
5482 Use -1 as the 'addressable' indication for the field to prevent the
5483 creation of a bitfield. We don't need one, it would have damaging
5484 consequences on the alignment computation, and create_field_decl would
5485 make one without this special argument, for instance because of the
5486 complex position expression. */
5488 field = create_field_decl (get_identifier ("F"), type, record_type,
5490 TYPE_FIELDS (record_type) = field;
5492 TYPE_ALIGN (record_type) = base_align;
5493 TYPE_USER_ALIGN (record_type) = 1;
5495 TYPE_SIZE (record_type)
5496 = size_binop (PLUS_EXPR,
5497 size_binop (MULT_EXPR, convert (bitsizetype, size),
5499 bitsize_int (align + room * BITS_PER_UNIT));
5500 TYPE_SIZE_UNIT (record_type)
5501 = size_binop (PLUS_EXPR, size,
5502 size_int (room + align / BITS_PER_UNIT));
5504 TYPE_MODE (record_type) = BLKmode;
5506 copy_alias_set (record_type, type);
5510 /* Return the result of rounding T up to ALIGN. */
5512 static inline unsigned HOST_WIDE_INT
5513 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5521 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5522 as the field type of a packed record if IN_RECORD is true, or as the
5523 component type of a packed array if IN_RECORD is false. See if we can
5524 rewrite it either as a type that has a non-BLKmode, which we can pack
5525 tighter in the packed record case, or as a smaller type with BLKmode.
5526 If so, return the new type. If not, return the original type. */
5529 make_packable_type (tree type, bool in_record)
5531 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5532 unsigned HOST_WIDE_INT new_size;
5533 tree new_type, old_field, field_list = NULL_TREE;
5535 /* No point in doing anything if the size is zero. */
5539 new_type = make_node (TREE_CODE (type));
5541 /* Copy the name and flags from the old type to that of the new.
5542 Note that we rely on the pointer equality created here for
5543 TYPE_NAME to look through conversions in various places. */
5544 TYPE_NAME (new_type) = TYPE_NAME (type);
5545 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5546 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5547 if (TREE_CODE (type) == RECORD_TYPE)
5548 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5550 /* If we are in a record and have a small size, set the alignment to
5551 try for an integral mode. Otherwise set it to try for a smaller
5552 type with BLKmode. */
5553 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5555 TYPE_ALIGN (new_type) = ceil_alignment (size);
5556 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5560 unsigned HOST_WIDE_INT align;
5562 /* Do not try to shrink the size if the RM size is not constant. */
5563 if (TYPE_CONTAINS_TEMPLATE_P (type)
5564 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5567 /* Round the RM size up to a unit boundary to get the minimal size
5568 for a BLKmode record. Give up if it's already the size. */
5569 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5570 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5571 if (new_size == size)
5574 align = new_size & -new_size;
5575 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5578 TYPE_USER_ALIGN (new_type) = 1;
5580 /* Now copy the fields, keeping the position and size as we don't want
5581 to change the layout by propagating the packedness downwards. */
5582 for (old_field = TYPE_FIELDS (type); old_field;
5583 old_field = TREE_CHAIN (old_field))
5585 tree new_field_type = TREE_TYPE (old_field);
5586 tree new_field, new_size;
5588 if (TYPE_MODE (new_field_type) == BLKmode
5589 && (TREE_CODE (new_field_type) == RECORD_TYPE
5590 || TREE_CODE (new_field_type) == UNION_TYPE
5591 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5592 && host_integerp (TYPE_SIZE (new_field_type), 1))
5593 new_field_type = make_packable_type (new_field_type, true);
5595 /* However, for the last field in a not already packed record type
5596 that is of an aggregate type, we need to use the RM_Size in the
5597 packable version of the record type, see finish_record_type. */
5598 if (!TREE_CHAIN (old_field)
5599 && !TYPE_PACKED (type)
5600 && (TREE_CODE (new_field_type) == RECORD_TYPE
5601 || TREE_CODE (new_field_type) == UNION_TYPE
5602 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5603 && !TYPE_IS_FAT_POINTER_P (new_field_type)
5604 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5605 && TYPE_ADA_SIZE (new_field_type))
5606 new_size = TYPE_ADA_SIZE (new_field_type);
5608 new_size = DECL_SIZE (old_field);
5610 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5611 new_type, TYPE_PACKED (type), new_size,
5612 bit_position (old_field),
5613 !DECL_NONADDRESSABLE_P (old_field));
5615 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5616 SET_DECL_ORIGINAL_FIELD
5617 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5618 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5620 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5621 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5623 TREE_CHAIN (new_field) = field_list;
5624 field_list = new_field;
5627 finish_record_type (new_type, nreverse (field_list), 2, true);
5628 copy_alias_set (new_type, type);
5630 /* If this is a padding record, we never want to make the size smaller
5631 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5632 if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5633 || TREE_CODE (type) == QUAL_UNION_TYPE)
5635 TYPE_SIZE (new_type) = TYPE_SIZE (type);
5636 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5640 TYPE_SIZE (new_type) = bitsize_int (new_size);
5641 TYPE_SIZE_UNIT (new_type)
5642 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
5645 if (!TYPE_CONTAINS_TEMPLATE_P (type))
5646 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
5648 compute_record_mode (new_type);
5650 /* Try harder to get a packable type if necessary, for example
5651 in case the record itself contains a BLKmode field. */
5652 if (in_record && TYPE_MODE (new_type) == BLKmode)
5653 TYPE_MODE (new_type)
5654 = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
5656 /* If neither the mode nor the size has shrunk, return the old type. */
5657 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
5663 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5664 if needed. We have already verified that SIZE and TYPE are large enough.
5666 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5669 IS_USER_TYPE is true if we must complete the original type.
5671 DEFINITION is true if this type is being defined.
5673 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
5674 to SIZE too; otherwise, it's set to the RM_Size of the original type. */
5677 maybe_pad_type (tree type, tree size, unsigned int align,
5678 Entity_Id gnat_entity, const char *name_trailer,
5679 bool is_user_type, bool definition, bool same_rm_size)
5681 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
5682 tree orig_size = TYPE_SIZE (type);
5683 unsigned int orig_align = align;
5686 /* If TYPE is a padded type, see if it agrees with any size and alignment
5687 we were given. If so, return the original type. Otherwise, strip
5688 off the padding, since we will either be returning the inner type
5689 or repadding it. If no size or alignment is specified, use that of
5690 the original padded type. */
5691 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5694 || operand_equal_p (round_up (size,
5695 MAX (align, TYPE_ALIGN (type))),
5696 round_up (TYPE_SIZE (type),
5697 MAX (align, TYPE_ALIGN (type))),
5699 && (align == 0 || align == TYPE_ALIGN (type)))
5703 size = TYPE_SIZE (type);
5705 align = TYPE_ALIGN (type);
5707 type = TREE_TYPE (TYPE_FIELDS (type));
5708 orig_size = TYPE_SIZE (type);
5711 /* If the size is either not being changed or is being made smaller (which
5712 is not done here (and is only valid for bitfields anyway), show the size
5713 isn't changing. Likewise, clear the alignment if it isn't being
5714 changed. Then return if we aren't doing anything. */
5716 && (operand_equal_p (size, orig_size, 0)
5717 || (TREE_CODE (orig_size) == INTEGER_CST
5718 && tree_int_cst_lt (size, orig_size))))
5721 if (align == TYPE_ALIGN (type))
5724 if (align == 0 && !size)
5727 /* If requested, complete the original type and give it a name. */
5729 create_type_decl (get_entity_name (gnat_entity), type,
5730 NULL, !Comes_From_Source (gnat_entity),
5732 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5733 && DECL_IGNORED_P (TYPE_NAME (type))),
5736 /* We used to modify the record in place in some cases, but that could
5737 generate incorrect debugging information. So make a new record
5739 record = make_node (RECORD_TYPE);
5740 TYPE_IS_PADDING_P (record) = 1;
5742 if (Present (gnat_entity))
5743 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5745 TYPE_VOLATILE (record)
5746 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5748 TYPE_ALIGN (record) = align;
5750 TYPE_USER_ALIGN (record) = align;
5752 TYPE_SIZE (record) = size ? size : orig_size;
5753 TYPE_SIZE_UNIT (record)
5754 = convert (sizetype,
5755 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
5756 bitsize_unit_node));
5758 /* If we are changing the alignment and the input type is a record with
5759 BLKmode and a small constant size, try to make a form that has an
5760 integral mode. This might allow the padding record to also have an
5761 integral mode, which will be much more efficient. There is no point
5762 in doing so if a size is specified unless it is also a small constant
5763 size and it is incorrect to do so if we cannot guarantee that the mode
5764 will be naturally aligned since the field must always be addressable.
5766 ??? This might not always be a win when done for a stand-alone object:
5767 since the nominal and the effective type of the object will now have
5768 different modes, a VIEW_CONVERT_EXPR will be required for converting
5769 between them and it might be hard to overcome afterwards, including
5770 at the RTL level when the stand-alone object is accessed as a whole. */
5772 && TREE_CODE (type) == RECORD_TYPE
5773 && TYPE_MODE (type) == BLKmode
5774 && TREE_CODE (orig_size) == INTEGER_CST
5775 && !TREE_CONSTANT_OVERFLOW (orig_size)
5776 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
5778 || (TREE_CODE (size) == INTEGER_CST
5779 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
5781 tree packable_type = make_packable_type (type, true);
5782 if (TYPE_MODE (packable_type) != BLKmode
5783 && align >= TYPE_ALIGN (packable_type))
5784 type = packable_type;
5787 /* Now create the field with the original size. */
5788 field = create_field_decl (get_identifier ("F"), type, record, 0,
5789 orig_size, bitsize_zero_node, 1);
5790 DECL_INTERNAL_P (field) = 1;
5792 /* Do not finalize it until after the auxiliary record is built. */
5793 finish_record_type (record, field, 1, true);
5795 /* Set the same size for its RM_size if requested; otherwise reuse
5796 the RM_size of the original type. */
5797 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
5799 /* Unless debugging information isn't being written for the input type,
5800 write a record that shows what we are a subtype of and also make a
5801 variable that indicates our size, if still variable. */
5802 if (TYPE_NAME (record)
5803 && AGGREGATE_TYPE_P (type)
5804 && TREE_CODE (orig_size) != INTEGER_CST
5805 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5806 && DECL_IGNORED_P (TYPE_NAME (type))))
5808 tree marker = make_node (RECORD_TYPE);
5809 tree name = TYPE_NAME (record);
5810 tree orig_name = TYPE_NAME (type);
5812 if (TREE_CODE (name) == TYPE_DECL)
5813 name = DECL_NAME (name);
5815 if (TREE_CODE (orig_name) == TYPE_DECL)
5816 orig_name = DECL_NAME (orig_name);
5818 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5819 finish_record_type (marker,
5820 create_field_decl (orig_name, integer_type_node,
5821 marker, 0, NULL_TREE, NULL_TREE,
5825 add_parallel_type (TYPE_STUB_DECL (record), marker);
5827 if (size && TREE_CODE (size) != INTEGER_CST && definition)
5828 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5829 bitsizetype, TYPE_SIZE (record), false, false, false,
5830 false, NULL, gnat_entity);
5833 rest_of_record_type_compilation (record);
5835 /* If the size was widened explicitly, maybe give a warning. Take the
5836 original size as the maximum size of the input if there was an
5837 unconstrained record involved and round it up to the specified alignment,
5838 if one was specified. */
5839 if (CONTAINS_PLACEHOLDER_P (orig_size))
5840 orig_size = max_size (orig_size, true);
5843 orig_size = round_up (orig_size, align);
5845 if (size && Present (gnat_entity)
5846 && !operand_equal_p (size, orig_size, 0)
5847 && !(TREE_CODE (size) == INTEGER_CST
5848 && TREE_CODE (orig_size) == INTEGER_CST
5849 && tree_int_cst_lt (size, orig_size)))
5851 Node_Id gnat_error_node = Empty;
5853 if (Is_Packed_Array_Type (gnat_entity))
5854 gnat_entity = Original_Array_Type (gnat_entity);
5856 if ((Ekind (gnat_entity) == E_Component
5857 || Ekind (gnat_entity) == E_Discriminant)
5858 && Present (Component_Clause (gnat_entity)))
5859 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5860 else if (Present (Size_Clause (gnat_entity)))
5861 gnat_error_node = Expression (Size_Clause (gnat_entity));
5863 /* Generate message only for entities that come from source, since
5864 if we have an entity created by expansion, the message will be
5865 generated for some other corresponding source entity. */
5866 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5867 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5869 size_diffop (size, orig_size));
5871 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5872 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5873 gnat_entity, gnat_entity,
5874 size_diffop (size, orig_size));
5880 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5881 the value passed against the list of choices. */
5884 choices_to_gnu (tree operand, Node_Id choices)
5888 tree result = integer_zero_node;
5889 tree this_test, low = 0, high = 0, single = 0;
5891 for (choice = First (choices); Present (choice); choice = Next (choice))
5893 switch (Nkind (choice))
5896 low = gnat_to_gnu (Low_Bound (choice));
5897 high = gnat_to_gnu (High_Bound (choice));
5899 /* There's no good type to use here, so we might as well use
5900 integer_type_node. */
5902 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5903 build_binary_op (GE_EXPR, integer_type_node,
5905 build_binary_op (LE_EXPR, integer_type_node,
5910 case N_Subtype_Indication:
5911 gnat_temp = Range_Expression (Constraint (choice));
5912 low = gnat_to_gnu (Low_Bound (gnat_temp));
5913 high = gnat_to_gnu (High_Bound (gnat_temp));
5916 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5917 build_binary_op (GE_EXPR, integer_type_node,
5919 build_binary_op (LE_EXPR, integer_type_node,
5924 case N_Expanded_Name:
5925 /* This represents either a subtype range, an enumeration
5926 literal, or a constant Ekind says which. If an enumeration
5927 literal or constant, fall through to the next case. */
5928 if (Ekind (Entity (choice)) != E_Enumeration_Literal
5929 && Ekind (Entity (choice)) != E_Constant)
5931 tree type = gnat_to_gnu_type (Entity (choice));
5933 low = TYPE_MIN_VALUE (type);
5934 high = TYPE_MAX_VALUE (type);
5937 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5938 build_binary_op (GE_EXPR, integer_type_node,
5940 build_binary_op (LE_EXPR, integer_type_node,
5944 /* ... fall through ... */
5945 case N_Character_Literal:
5946 case N_Integer_Literal:
5947 single = gnat_to_gnu (choice);
5948 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5952 case N_Others_Choice:
5953 this_test = integer_one_node;
5960 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5967 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5968 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
5971 adjust_packed (tree field_type, tree record_type, int packed)
5973 /* If the field contains an item of variable size, we cannot pack it
5974 because we cannot create temporaries of non-fixed size in case
5975 we need to take the address of the field. See addressable_p and
5976 the notes on the addressability issues for further details. */
5977 if (is_variable_size (field_type))
5980 /* If the alignment of the record is specified and the field type
5981 is over-aligned, request Storage_Unit alignment for the field. */
5984 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
5993 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5994 placed in GNU_RECORD_TYPE.
5996 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
5997 record has Component_Alignment of Storage_Unit, -2 if the enclosing
5998 record has a specified alignment.
6000 DEFINITION is true if this field is for a record being defined. */
6003 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6006 tree gnu_field_id = get_entity_name (gnat_field);
6007 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6008 tree gnu_field, gnu_size, gnu_pos;
6009 bool needs_strict_alignment
6010 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6011 || Treat_As_Volatile (gnat_field));
6013 /* If this field requires strict alignment, we cannot pack it because
6014 it would very likely be under-aligned in the record. */
6015 if (needs_strict_alignment)
6018 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6020 /* If a size is specified, use it. Otherwise, if the record type is packed,
6021 use the official RM size. See "Handling of Type'Size Values" in Einfo
6022 for further details. */
6023 if (Known_Static_Esize (gnat_field))
6024 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6025 gnat_field, FIELD_DECL, false, true);
6026 else if (packed == 1)
6027 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6028 gnat_field, FIELD_DECL, false, true);
6030 gnu_size = NULL_TREE;
6032 /* If we have a specified size that's smaller than that of the field type,
6033 or a position is specified, and the field type is also a record that's
6034 BLKmode, see if we can get either an integral mode form of the type or
6035 a smaller BLKmode form. If we can, show a size was specified for the
6036 field if there wasn't one already, so we know to make this a bitfield
6037 and avoid making things wider.
6039 Doing this is first useful if the record is packed because we may then
6040 place the field at a non-byte-aligned position and so achieve tighter
6043 This is in addition *required* if the field shares a byte with another
6044 field and the front-end lets the back-end handle the references, because
6045 GCC does not handle BLKmode bitfields properly.
6047 We avoid the transformation if it is not required or potentially useful,
6048 as it might entail an increase of the field's alignment and have ripple
6049 effects on the outer record type. A typical case is a field known to be
6050 byte aligned and not to share a byte with another field.
6052 Besides, we don't even look the possibility of a transformation in cases
6053 known to be in error already, for instance when an invalid size results
6054 from a component clause. */
6056 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6057 && TYPE_MODE (gnu_field_type) == BLKmode
6058 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6061 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6062 || Present (Component_Clause (gnat_field))))))
6064 /* See what the alternate type and size would be. */
6065 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6067 bool has_byte_aligned_clause
6068 = Present (Component_Clause (gnat_field))
6069 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6070 % BITS_PER_UNIT == 0);
6072 /* Compute whether we should avoid the substitution. */
6074 /* There is no point substituting if there is no change... */
6075 = (gnu_packable_type == gnu_field_type)
6076 /* ... nor when the field is known to be byte aligned and not to
6077 share a byte with another field. */
6078 || (has_byte_aligned_clause
6079 && value_factor_p (gnu_size, BITS_PER_UNIT))
6080 /* The size of an aliased field must be an exact multiple of the
6081 type's alignment, which the substitution might increase. Reject
6082 substitutions that would so invalidate a component clause when the
6083 specified position is byte aligned, as the change would have no
6084 real benefit from the packing standpoint anyway. */
6085 || (Is_Aliased (gnat_field)
6086 && has_byte_aligned_clause
6087 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6089 /* Substitute unless told otherwise. */
6092 gnu_field_type = gnu_packable_type;
6095 gnu_size = rm_size (gnu_field_type);
6099 /* If we are packing the record and the field is BLKmode, round the
6100 size up to a byte boundary. */
6101 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6102 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6104 if (Present (Component_Clause (gnat_field)))
6106 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6107 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6108 gnat_field, FIELD_DECL, false, true);
6110 /* Ensure the position does not overlap with the parent subtype,
6112 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
6115 = gnat_to_gnu_type (Parent_Subtype
6116 (Underlying_Type (Scope (gnat_field))));
6118 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6119 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6122 ("offset of& must be beyond parent{, minimum allowed is ^}",
6123 First_Bit (Component_Clause (gnat_field)), gnat_field,
6124 TYPE_SIZE_UNIT (gnu_parent));
6128 /* If this field needs strict alignment, ensure the record is
6129 sufficiently aligned and that that position and size are
6130 consistent with the alignment. */
6131 if (needs_strict_alignment)
6133 TYPE_ALIGN (gnu_record_type)
6134 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6137 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6139 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6141 ("atomic field& must be natural size of type{ (^)}",
6142 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6143 TYPE_SIZE (gnu_field_type));
6145 else if (Is_Aliased (gnat_field))
6147 ("size of aliased field& must be ^ bits",
6148 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6149 TYPE_SIZE (gnu_field_type));
6151 else if (Strict_Alignment (Etype (gnat_field)))
6153 ("size of & with aliased or tagged components not ^ bits",
6154 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6155 TYPE_SIZE (gnu_field_type));
6157 gnu_size = NULL_TREE;
6160 if (!integer_zerop (size_binop
6161 (TRUNC_MOD_EXPR, gnu_pos,
6162 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6164 if (Is_Aliased (gnat_field))
6166 ("position of aliased field& must be multiple of ^ bits",
6167 First_Bit (Component_Clause (gnat_field)), gnat_field,
6168 TYPE_ALIGN (gnu_field_type));
6170 else if (Treat_As_Volatile (gnat_field))
6172 ("position of volatile field& must be multiple of ^ bits",
6173 First_Bit (Component_Clause (gnat_field)), gnat_field,
6174 TYPE_ALIGN (gnu_field_type));
6176 else if (Strict_Alignment (Etype (gnat_field)))
6178 ("position of & with aliased or tagged components not multiple of ^ bits",
6179 First_Bit (Component_Clause (gnat_field)), gnat_field,
6180 TYPE_ALIGN (gnu_field_type));
6185 gnu_pos = NULL_TREE;
6189 if (Is_Atomic (gnat_field))
6190 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6193 /* If the record has rep clauses and this is the tag field, make a rep
6194 clause for it as well. */
6195 else if (Has_Specified_Layout (Scope (gnat_field))
6196 && Chars (gnat_field) == Name_uTag)
6198 gnu_pos = bitsize_zero_node;
6199 gnu_size = TYPE_SIZE (gnu_field_type);
6203 gnu_pos = NULL_TREE;
6205 /* We need to make the size the maximum for the type if it is
6206 self-referential and an unconstrained type. In that case, we can't
6207 pack the field since we can't make a copy to align it. */
6208 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6210 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6211 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6213 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6217 /* If a size is specified, adjust the field's type to it. */
6220 /* If the field's type is justified modular, we would need to remove
6221 the wrapper to (better) meet the layout requirements. However we
6222 can do so only if the field is not aliased to preserve the unique
6223 layout and if the prescribed size is not greater than that of the
6224 packed array to preserve the justification. */
6225 if (!needs_strict_alignment
6226 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6227 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6228 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6230 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6233 = make_type_from_size (gnu_field_type, gnu_size,
6234 Has_Biased_Representation (gnat_field));
6235 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6236 "PAD", false, definition, true);
6239 /* Otherwise (or if there was an error), don't specify a position. */
6241 gnu_pos = NULL_TREE;
6243 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6244 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6246 /* Now create the decl for the field. */
6247 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6248 packed, gnu_size, gnu_pos,
6249 Is_Aliased (gnat_field));
6250 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6251 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6253 if (Ekind (gnat_field) == E_Discriminant)
6254 DECL_DISCRIMINANT_NUMBER (gnu_field)
6255 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6260 /* Return true if TYPE is a type with variable size, a padding type with a
6261 field of variable size or is a record that has a field such a field. */
6264 is_variable_size (tree type)
6268 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6271 if (TREE_CODE (type) == RECORD_TYPE
6272 && TYPE_IS_PADDING_P (type)
6273 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6276 if (TREE_CODE (type) != RECORD_TYPE
6277 && TREE_CODE (type) != UNION_TYPE
6278 && TREE_CODE (type) != QUAL_UNION_TYPE)
6281 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6282 if (is_variable_size (TREE_TYPE (field)))
6288 /* qsort comparer for the bit positions of two record components. */
6291 compare_field_bitpos (const PTR rt1, const PTR rt2)
6293 const_tree const field1 = * (const_tree const *) rt1;
6294 const_tree const field2 = * (const_tree const *) rt2;
6296 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6298 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6301 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6302 of GCC trees for fields that are in the record and have already been
6303 processed. When called from gnat_to_gnu_entity during the processing of a
6304 record type definition, the GCC nodes for the discriminants will be on
6305 the chain. The other calls to this function are recursive calls from
6306 itself for the Component_List of a variant and the chain is empty.
6308 PACKED is 1 if this is for a packed record, -1 if this is for a record
6309 with Component_Alignment of Storage_Unit, -2 if this is for a record
6310 with a specified alignment.
6312 DEFINITION is true if we are defining this record.
6314 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6315 with a rep clause is to be added. If it is nonzero, that is all that
6316 should be done with such fields.
6318 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6319 laying out the record. This means the alignment only serves to force fields
6320 to be bitfields, but not require the record to be that aligned. This is
6323 ALL_REP, if true, means a rep clause was found for all the fields. This
6324 simplifies the logic since we know we're not in the mixed case.
6326 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6327 modified afterwards so it will not be sent to the back-end for finalization.
6329 UNCHECKED_UNION, if true, means that we are building a type for a record
6330 with a Pragma Unchecked_Union.
6332 The processing of the component list fills in the chain with all of the
6333 fields of the record and then the record type is finished. */
6336 components_to_record (tree gnu_record_type, Node_Id component_list,
6337 tree gnu_field_list, int packed, bool definition,
6338 tree *p_gnu_rep_list, bool cancel_alignment,
6339 bool all_rep, bool do_not_finalize, bool unchecked_union)
6341 Node_Id component_decl;
6342 Entity_Id gnat_field;
6343 Node_Id variant_part;
6344 tree gnu_our_rep_list = NULL_TREE;
6345 tree gnu_field, gnu_last;
6346 bool layout_with_rep = false;
6347 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6349 /* For each variable within each component declaration create a GCC field
6350 and add it to the list, skipping any pragmas in the list. */
6351 if (Present (Component_Items (component_list)))
6352 for (component_decl = First_Non_Pragma (Component_Items (component_list));
6353 Present (component_decl);
6354 component_decl = Next_Non_Pragma (component_decl))
6356 gnat_field = Defining_Entity (component_decl);
6358 if (Chars (gnat_field) == Name_uParent)
6359 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
6362 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
6363 packed, definition);
6365 /* If this is the _Tag field, put it before any discriminants,
6366 instead of after them as is the case for all other fields.
6367 Ignore field of void type if only annotating. */
6368 if (Chars (gnat_field) == Name_uTag)
6369 gnu_field_list = chainon (gnu_field_list, gnu_field);
6372 TREE_CHAIN (gnu_field) = gnu_field_list;
6373 gnu_field_list = gnu_field;
6377 save_gnu_tree (gnat_field, gnu_field, false);
6380 /* At the end of the component list there may be a variant part. */
6381 variant_part = Variant_Part (component_list);
6383 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6384 mutually exclusive and should go in the same memory. To do this we need
6385 to treat each variant as a record whose elements are created from the
6386 component list for the variant. So here we create the records from the
6387 lists for the variants and put them all into the QUAL_UNION_TYPE.
6388 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6389 use GNU_RECORD_TYPE if there are no fields so far. */
6390 if (Present (variant_part))
6392 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
6394 tree gnu_name = TYPE_NAME (gnu_record_type);
6396 = concat_id_with_name (get_identifier (Get_Name_String
6397 (Chars (Name (variant_part)))),
6399 tree gnu_union_type;
6400 tree gnu_union_name;
6401 tree gnu_union_field;
6402 tree gnu_variant_list = NULL_TREE;
6404 if (TREE_CODE (gnu_name) == TYPE_DECL)
6405 gnu_name = DECL_NAME (gnu_name);
6407 gnu_union_name = concat_id_with_name (gnu_name,
6408 IDENTIFIER_POINTER (gnu_var_name));
6410 /* Reuse an enclosing union if all fields are in the variant part
6411 and there is no representation clause on the record, to match
6412 the layout of C unions. There is an associated check below. */
6414 && TREE_CODE (gnu_record_type) == UNION_TYPE
6415 && !TYPE_PACKED (gnu_record_type))
6416 gnu_union_type = gnu_record_type;
6420 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6422 TYPE_NAME (gnu_union_type) = gnu_union_name;
6423 TYPE_ALIGN (gnu_union_type) = 0;
6424 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6427 for (variant = First_Non_Pragma (Variants (variant_part));
6429 variant = Next_Non_Pragma (variant))
6431 tree gnu_variant_type = make_node (RECORD_TYPE);
6432 tree gnu_inner_name;
6435 Get_Variant_Encoding (variant);
6436 gnu_inner_name = get_identifier (Name_Buffer);
6437 TYPE_NAME (gnu_variant_type)
6438 = concat_id_with_name (gnu_union_name,
6439 IDENTIFIER_POINTER (gnu_inner_name));
6441 /* Set the alignment of the inner type in case we need to make
6442 inner objects into bitfields, but then clear it out
6443 so the record actually gets only the alignment required. */
6444 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6445 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6447 /* Similarly, if the outer record has a size specified and all fields
6448 have record rep clauses, we can propagate the size into the
6450 if (all_rep_and_size)
6452 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6453 TYPE_SIZE_UNIT (gnu_variant_type)
6454 = TYPE_SIZE_UNIT (gnu_record_type);
6457 /* Create the record type for the variant. Note that we defer
6458 finalizing it until after we are sure to actually use it. */
6459 components_to_record (gnu_variant_type, Component_List (variant),
6460 NULL_TREE, packed, definition,
6461 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6462 true, unchecked_union);
6464 gnu_qual = choices_to_gnu (gnu_discriminant,
6465 Discrete_Choices (variant));
6467 Set_Present_Expr (variant, annotate_value (gnu_qual));
6469 /* If this is an Unchecked_Union and we have exactly one field,
6470 use this field directly to match the layout of C unions. */
6472 && TYPE_FIELDS (gnu_variant_type)
6473 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6474 gnu_field = TYPE_FIELDS (gnu_variant_type);
6477 /* Deal with packedness like in gnat_to_gnu_field. */
6479 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6481 /* Finalize the record type now. We used to throw away
6482 empty records but we no longer do that because we need
6483 them to generate complete debug info for the variant;
6484 otherwise, the union type definition will be lacking
6485 the fields associated with these empty variants. */
6486 rest_of_record_type_compilation (gnu_variant_type);
6488 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6489 gnu_union_type, field_packed,
6491 ? TYPE_SIZE (gnu_variant_type)
6494 ? bitsize_zero_node : 0),
6497 DECL_INTERNAL_P (gnu_field) = 1;
6499 if (!unchecked_union)
6500 DECL_QUALIFIER (gnu_field) = gnu_qual;
6503 TREE_CHAIN (gnu_field) = gnu_variant_list;
6504 gnu_variant_list = gnu_field;
6507 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6508 if (gnu_variant_list)
6510 int union_field_packed;
6512 if (all_rep_and_size)
6514 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6515 TYPE_SIZE_UNIT (gnu_union_type)
6516 = TYPE_SIZE_UNIT (gnu_record_type);
6519 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6520 all_rep_and_size ? 1 : 0, false);
6522 /* If GNU_UNION_TYPE is our record type, it means we must have an
6523 Unchecked_Union with no fields. Verify that and, if so, just
6525 if (gnu_union_type == gnu_record_type)
6527 gcc_assert (unchecked_union
6529 && !gnu_our_rep_list);
6533 /* Deal with packedness like in gnat_to_gnu_field. */
6535 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6538 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6540 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6541 all_rep ? bitsize_zero_node : 0, 0);
6543 DECL_INTERNAL_P (gnu_union_field) = 1;
6544 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6545 gnu_field_list = gnu_union_field;
6549 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6550 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6551 in a separate pass since we want to handle the discriminants but can't
6552 play with them until we've used them in debugging data above.
6554 ??? Note: if we then reorder them, debugging information will be wrong,
6555 but there's nothing that can be done about this at the moment. */
6556 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6558 if (DECL_FIELD_OFFSET (gnu_field))
6560 tree gnu_next = TREE_CHAIN (gnu_field);
6563 gnu_field_list = gnu_next;
6565 TREE_CHAIN (gnu_last) = gnu_next;
6567 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6568 gnu_our_rep_list = gnu_field;
6569 gnu_field = gnu_next;
6573 gnu_last = gnu_field;
6574 gnu_field = TREE_CHAIN (gnu_field);
6578 /* If we have any items in our rep'ed field list, it is not the case that all
6579 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6580 set it and ignore the items. */
6581 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6582 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6583 else if (gnu_our_rep_list)
6585 /* Otherwise, sort the fields by bit position and put them into their
6586 own record if we have any fields without rep clauses. */
6588 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6589 int len = list_length (gnu_our_rep_list);
6590 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6593 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6594 gnu_field = TREE_CHAIN (gnu_field), i++)
6595 gnu_arr[i] = gnu_field;
6597 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6599 /* Put the fields in the list in order of increasing position, which
6600 means we start from the end. */
6601 gnu_our_rep_list = NULL_TREE;
6602 for (i = len - 1; i >= 0; i--)
6604 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6605 gnu_our_rep_list = gnu_arr[i];
6606 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6611 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6612 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6613 gnu_record_type, 0, 0, 0, 1);
6614 DECL_INTERNAL_P (gnu_field) = 1;
6615 gnu_field_list = chainon (gnu_field_list, gnu_field);
6619 layout_with_rep = true;
6620 gnu_field_list = nreverse (gnu_our_rep_list);
6624 if (cancel_alignment)
6625 TYPE_ALIGN (gnu_record_type) = 0;
6627 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6628 layout_with_rep ? 1 : 0, do_not_finalize);
6631 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6632 placed into an Esize, Component_Bit_Offset, or Component_Size value
6633 in the GNAT tree. */
6636 annotate_value (tree gnu_size)
6638 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6640 Node_Ref_Or_Val ops[3], ret;
6643 struct tree_int_map **h = NULL;
6645 /* See if we've already saved the value for this node. */
6646 if (EXPR_P (gnu_size))
6648 struct tree_int_map in;
6649 if (!annotate_value_cache)
6650 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6651 tree_int_map_eq, 0);
6652 in.base.from = gnu_size;
6653 h = (struct tree_int_map **)
6654 htab_find_slot (annotate_value_cache, &in, INSERT);
6657 return (Node_Ref_Or_Val) (*h)->to;
6660 /* If we do not return inside this switch, TCODE will be set to the
6661 code to use for a Create_Node operand and LEN (set above) will be
6662 the number of recursive calls for us to make. */
6664 switch (TREE_CODE (gnu_size))
6667 if (TREE_OVERFLOW (gnu_size))
6670 /* This may have come from a conversion from some smaller type,
6671 so ensure this is in bitsizetype. */
6672 gnu_size = convert (bitsizetype, gnu_size);
6674 /* For negative values, use NEGATE_EXPR of the supplied value. */
6675 if (tree_int_cst_sgn (gnu_size) < 0)
6677 /* The ridiculous code below is to handle the case of the largest
6678 negative integer. */
6679 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6680 bool adjust = false;
6683 if (TREE_OVERFLOW (negative_size))
6686 = size_binop (MINUS_EXPR, bitsize_zero_node,
6687 size_binop (PLUS_EXPR, gnu_size,
6692 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6694 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6696 return annotate_value (temp);
6699 if (!host_integerp (gnu_size, 1))
6702 size = tree_low_cst (gnu_size, 1);
6704 /* This peculiar test is to make sure that the size fits in an int
6705 on machines where HOST_WIDE_INT is not "int". */
6706 if (tree_low_cst (gnu_size, 1) == size)
6707 return UI_From_Int (size);
6712 /* The only case we handle here is a simple discriminant reference. */
6713 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6714 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6715 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6716 return Create_Node (Discrim_Val,
6717 annotate_value (DECL_DISCRIMINANT_NUMBER
6718 (TREE_OPERAND (gnu_size, 1))),
6723 CASE_CONVERT: case NON_LVALUE_EXPR:
6724 return annotate_value (TREE_OPERAND (gnu_size, 0));
6726 /* Now just list the operations we handle. */
6727 case COND_EXPR: tcode = Cond_Expr; break;
6728 case PLUS_EXPR: tcode = Plus_Expr; break;
6729 case MINUS_EXPR: tcode = Minus_Expr; break;
6730 case MULT_EXPR: tcode = Mult_Expr; break;
6731 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
6732 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
6733 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
6734 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
6735 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
6736 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
6737 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
6738 case NEGATE_EXPR: tcode = Negate_Expr; break;
6739 case MIN_EXPR: tcode = Min_Expr; break;
6740 case MAX_EXPR: tcode = Max_Expr; break;
6741 case ABS_EXPR: tcode = Abs_Expr; break;
6742 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
6743 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
6744 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
6745 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
6746 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
6747 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
6748 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
6749 case LT_EXPR: tcode = Lt_Expr; break;
6750 case LE_EXPR: tcode = Le_Expr; break;
6751 case GT_EXPR: tcode = Gt_Expr; break;
6752 case GE_EXPR: tcode = Ge_Expr; break;
6753 case EQ_EXPR: tcode = Eq_Expr; break;
6754 case NE_EXPR: tcode = Ne_Expr; break;
6760 /* Now get each of the operands that's relevant for this code. If any
6761 cannot be expressed as a repinfo node, say we can't. */
6762 for (i = 0; i < 3; i++)
6765 for (i = 0; i < len; i++)
6767 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6768 if (ops[i] == No_Uint)
6772 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6774 /* Save the result in the cache. */
6777 *h = GGC_NEW (struct tree_int_map);
6778 (*h)->base.from = gnu_size;
6785 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6786 GCC type, set Component_Bit_Offset and Esize to the position and size
6790 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6794 Entity_Id gnat_field;
6796 /* We operate by first making a list of all fields and their positions
6797 (we can get the sizes easily at any time) by a recursive call
6798 and then update all the sizes into the tree. */
6799 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6800 size_zero_node, bitsize_zero_node,
6803 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6804 gnat_field = Next_Entity (gnat_field))
6805 if ((Ekind (gnat_field) == E_Component
6806 || (Ekind (gnat_field) == E_Discriminant
6807 && !Is_Unchecked_Union (Scope (gnat_field)))))
6809 tree parent_offset = bitsize_zero_node;
6811 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6816 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6818 /* In this mode the tag and parent components have not been
6819 generated, so we add the appropriate offset to each
6820 component. For a component appearing in the current
6821 extension, the offset is the size of the parent. */
6822 if (Is_Derived_Type (gnat_entity)
6823 && Original_Record_Component (gnat_field) == gnat_field)
6825 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6828 parent_offset = bitsize_int (POINTER_SIZE);
6831 Set_Component_Bit_Offset
6834 (size_binop (PLUS_EXPR,
6835 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6836 TREE_VALUE (TREE_VALUE
6837 (TREE_VALUE (gnu_entry)))),
6840 Set_Esize (gnat_field,
6841 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6843 else if (Is_Tagged_Type (gnat_entity)
6844 && Is_Derived_Type (gnat_entity))
6846 /* If there is no gnu_entry, this is an inherited component whose
6847 position is the same as in the parent type. */
6848 Set_Component_Bit_Offset
6850 Component_Bit_Offset (Original_Record_Component (gnat_field)));
6851 Set_Esize (gnat_field,
6852 Esize (Original_Record_Component (gnat_field)));
6857 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6858 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6859 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6860 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6861 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6862 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6866 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6867 tree gnu_bitpos, unsigned int offset_align)
6870 tree gnu_result = gnu_list;
6872 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6873 gnu_field = TREE_CHAIN (gnu_field))
6875 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6876 DECL_FIELD_BIT_OFFSET (gnu_field));
6877 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6878 DECL_FIELD_OFFSET (gnu_field));
6879 unsigned int our_offset_align
6880 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6883 = tree_cons (gnu_field,
6884 tree_cons (gnu_our_offset,
6885 tree_cons (size_int (our_offset_align),
6886 gnu_our_bitpos, NULL_TREE),
6890 if (DECL_INTERNAL_P (gnu_field))
6892 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6893 gnu_our_offset, gnu_our_bitpos,
6900 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6901 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6902 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6903 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6904 for the size of a field. COMPONENT_P is true if we are being called
6905 to process the Component_Size of GNAT_OBJECT. This is used for error
6906 message handling and to indicate to use the object size of GNU_TYPE.
6907 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6908 it means that a size of zero should be treated as an unspecified size. */
6911 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6912 enum tree_code kind, bool component_p, bool zero_ok)
6914 Node_Id gnat_error_node;
6915 tree type_size, size;
6917 if (kind == VAR_DECL
6918 /* If a type needs strict alignment, a component of this type in
6919 a packed record cannot be packed and thus uses the type size. */
6920 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
6921 type_size = TYPE_SIZE (gnu_type);
6923 type_size = rm_size (gnu_type);
6925 /* Find the node to use for errors. */
6926 if ((Ekind (gnat_object) == E_Component
6927 || Ekind (gnat_object) == E_Discriminant)
6928 && Present (Component_Clause (gnat_object)))
6929 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6930 else if (Present (Size_Clause (gnat_object)))
6931 gnat_error_node = Expression (Size_Clause (gnat_object));
6933 gnat_error_node = gnat_object;
6935 /* Return 0 if no size was specified, either because Esize was not Present or
6936 the specified size was zero. */
6937 if (No (uint_size) || uint_size == No_Uint)
6940 /* Get the size as a tree. Give an error if a size was specified, but cannot
6941 be represented as in sizetype. */
6942 size = UI_To_gnu (uint_size, bitsizetype);
6943 if (TREE_OVERFLOW (size))
6945 post_error_ne (component_p ? "component size of & is too large"
6946 : "size of & is too large",
6947 gnat_error_node, gnat_object);
6951 /* Ignore a negative size since that corresponds to our back-annotation.
6952 Also ignore a zero size unless a size clause exists. */
6953 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6956 /* The size of objects is always a multiple of a byte. */
6957 if (kind == VAR_DECL
6958 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6961 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6962 gnat_error_node, gnat_object);
6964 post_error_ne ("size for& is not a multiple of Storage_Unit",
6965 gnat_error_node, gnat_object);
6969 /* If this is an integral type or a packed array type, the front-end has
6970 verified the size, so we need not do it here (which would entail
6971 checking against the bounds). However, if this is an aliased object, it
6972 may not be smaller than the type of the object. */
6973 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
6974 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
6977 /* If the object is a record that contains a template, add the size of
6978 the template to the specified size. */
6979 if (TREE_CODE (gnu_type) == RECORD_TYPE
6980 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6981 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
6983 /* Modify the size of the type to be that of the maximum size if it has a
6985 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
6986 type_size = max_size (type_size, true);
6988 /* If this is an access type or a fat pointer, the minimum size is that given
6989 by the smallest integral mode that's valid for pointers. */
6990 if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
6992 enum machine_mode p_mode;
6994 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
6995 !targetm.valid_pointer_mode (p_mode);
6996 p_mode = GET_MODE_WIDER_MODE (p_mode))
6999 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7002 /* If the size of the object is a constant, the new size must not be
7004 if (TREE_CODE (type_size) != INTEGER_CST
7005 || TREE_OVERFLOW (type_size)
7006 || tree_int_cst_lt (size, type_size))
7010 ("component size for& too small{, minimum allowed is ^}",
7011 gnat_error_node, gnat_object, type_size);
7013 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7014 gnat_error_node, gnat_object, type_size);
7016 if (kind == VAR_DECL && !component_p
7017 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7018 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7019 post_error_ne_tree_2
7020 ("\\size of ^ is not a multiple of alignment (^ bits)",
7021 gnat_error_node, gnat_object, rm_size (gnu_type),
7022 TYPE_ALIGN (gnu_type));
7024 else if (INTEGRAL_TYPE_P (gnu_type))
7025 post_error_ne ("\\size would be legal if & were not aliased!",
7026 gnat_error_node, gnat_object);
7034 /* Similarly, but both validate and process a value of RM_Size. This
7035 routine is only called for types. */
7038 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7040 /* Only give an error if a Value_Size clause was explicitly given.
7041 Otherwise, we'd be duplicating an error on the Size clause. */
7042 Node_Id gnat_attr_node
7043 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7044 tree old_size = rm_size (gnu_type);
7047 /* Get the size as a tree. Do nothing if none was specified, either
7048 because RM_Size was not Present or if the specified size was zero.
7049 Give an error if a size was specified, but cannot be represented as
7051 if (No (uint_size) || uint_size == No_Uint)
7054 size = UI_To_gnu (uint_size, bitsizetype);
7055 if (TREE_OVERFLOW (size))
7057 if (Present (gnat_attr_node))
7058 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7064 /* Ignore a negative size since that corresponds to our back-annotation.
7065 Also ignore a zero size unless a size clause exists, a Value_Size
7066 clause exists, or this is an integer type, in which case the
7067 front end will have always set it. */
7068 else if (tree_int_cst_sgn (size) < 0
7069 || (integer_zerop (size) && No (gnat_attr_node)
7070 && !Has_Size_Clause (gnat_entity)
7071 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7074 /* If the old size is self-referential, get the maximum size. */
7075 if (CONTAINS_PLACEHOLDER_P (old_size))
7076 old_size = max_size (old_size, true);
7078 /* If the size of the object is a constant, the new size must not be
7079 smaller (the front end checks this for scalar types). */
7080 if (TREE_CODE (old_size) != INTEGER_CST
7081 || TREE_OVERFLOW (old_size)
7082 || (AGGREGATE_TYPE_P (gnu_type)
7083 && tree_int_cst_lt (size, old_size)))
7085 if (Present (gnat_attr_node))
7087 ("Value_Size for& too small{, minimum allowed is ^}",
7088 gnat_attr_node, gnat_entity, old_size);
7093 /* Otherwise, set the RM_Size. */
7094 if (TREE_CODE (gnu_type) == INTEGER_TYPE
7095 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7096 TYPE_RM_SIZE_NUM (gnu_type) = size;
7097 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
7098 TYPE_RM_SIZE_NUM (gnu_type) = size;
7099 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7100 || TREE_CODE (gnu_type) == UNION_TYPE
7101 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7102 && !TYPE_IS_FAT_POINTER_P (gnu_type))
7103 SET_TYPE_ADA_SIZE (gnu_type, size);
7106 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7107 If TYPE is the best type, return it. Otherwise, make a new type. We
7108 only support new integral and pointer types. FOR_BIASED is nonzero if
7109 we are making a biased type. */
7112 make_type_from_size (tree type, tree size_tree, bool for_biased)
7114 unsigned HOST_WIDE_INT size;
7118 /* If size indicates an error, just return TYPE to avoid propagating
7119 the error. Likewise if it's too large to represent. */
7120 if (!size_tree || !host_integerp (size_tree, 1))
7123 size = tree_low_cst (size_tree, 1);
7125 switch (TREE_CODE (type))
7129 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7130 && TYPE_BIASED_REPRESENTATION_P (type));
7132 /* Only do something if the type is not a packed array type and
7133 doesn't already have the proper size. */
7134 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7135 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7138 biased_p |= for_biased;
7139 size = MIN (size, LONG_LONG_TYPE_SIZE);
7141 if (TYPE_UNSIGNED (type) || biased_p)
7142 new_type = make_unsigned_type (size);
7144 new_type = make_signed_type (size);
7145 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7146 TYPE_MIN_VALUE (new_type)
7147 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
7148 TYPE_MAX_VALUE (new_type)
7149 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
7150 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7151 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
7155 /* Do something if this is a fat pointer, in which case we
7156 may need to return the thin pointer. */
7157 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7160 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
7164 /* Only do something if this is a thin pointer, in which case we
7165 may need to return the fat pointer. */
7166 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7168 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7178 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7179 a type or object whose present alignment is ALIGN. If this alignment is
7180 valid, return it. Otherwise, give an error and return ALIGN. */
7183 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7185 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7186 unsigned int new_align;
7187 Node_Id gnat_error_node;
7189 /* Don't worry about checking alignment if alignment was not specified
7190 by the source program and we already posted an error for this entity. */
7191 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7194 /* Post the error on the alignment clause if any. */
7195 if (Present (Alignment_Clause (gnat_entity)))
7196 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7198 gnat_error_node = gnat_entity;
7200 /* Within GCC, an alignment is an integer, so we must make sure a value is
7201 specified that fits in that range. Also, there is an upper bound to
7202 alignments we can support/allow. */
7203 if (!UI_Is_In_Int_Range (alignment)
7204 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7205 post_error_ne_num ("largest supported alignment for& is ^",
7206 gnat_error_node, gnat_entity, max_allowed_alignment);
7207 else if (!(Present (Alignment_Clause (gnat_entity))
7208 && From_At_Mod (Alignment_Clause (gnat_entity)))
7209 && new_align * BITS_PER_UNIT < align)
7210 post_error_ne_num ("alignment for& must be at least ^",
7211 gnat_error_node, gnat_entity,
7212 align / BITS_PER_UNIT);
7215 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7216 if (new_align > align)
7223 /* Return the smallest alignment not less than SIZE. */
7226 ceil_alignment (unsigned HOST_WIDE_INT size)
7228 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7231 /* Verify that OBJECT, a type or decl, is something we can implement
7232 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7233 if we require atomic components. */
7236 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7238 Node_Id gnat_error_point = gnat_entity;
7240 enum machine_mode mode;
7244 /* There are three case of what OBJECT can be. It can be a type, in which
7245 case we take the size, alignment and mode from the type. It can be a
7246 declaration that was indirect, in which case the relevant values are
7247 that of the type being pointed to, or it can be a normal declaration,
7248 in which case the values are of the decl. The code below assumes that
7249 OBJECT is either a type or a decl. */
7250 if (TYPE_P (object))
7252 mode = TYPE_MODE (object);
7253 align = TYPE_ALIGN (object);
7254 size = TYPE_SIZE (object);
7256 else if (DECL_BY_REF_P (object))
7258 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7259 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7260 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7264 mode = DECL_MODE (object);
7265 align = DECL_ALIGN (object);
7266 size = DECL_SIZE (object);
7269 /* Consider all floating-point types atomic and any types that that are
7270 represented by integers no wider than a machine word. */
7271 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7272 || ((GET_MODE_CLASS (mode) == MODE_INT
7273 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7274 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7277 /* For the moment, also allow anything that has an alignment equal
7278 to its size and which is smaller than a word. */
7279 if (size && TREE_CODE (size) == INTEGER_CST
7280 && compare_tree_int (size, align) == 0
7281 && align <= BITS_PER_WORD)
7284 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7285 gnat_node = Next_Rep_Item (gnat_node))
7287 if (!comp_p && Nkind (gnat_node) == N_Pragma
7288 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7290 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7291 else if (comp_p && Nkind (gnat_node) == N_Pragma
7292 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7293 == Pragma_Atomic_Components))
7294 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7298 post_error_ne ("atomic access to component of & cannot be guaranteed",
7299 gnat_error_point, gnat_entity);
7301 post_error_ne ("atomic access to & cannot be guaranteed",
7302 gnat_error_point, gnat_entity);
7305 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7306 have compatible signatures so that a call using one type may be safely
7307 issued if the actual target function type is the other. Return 1 if it is
7308 the case, 0 otherwise, and post errors on the incompatibilities.
7310 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7311 that calls to the subprogram will have arguments suitable for the later
7312 underlying builtin expansion. */
7315 compatible_signatures_p (tree ftype1, tree ftype2)
7317 /* As of now, we only perform very trivial tests and consider it's the
7318 programmer's responsibility to ensure the type correctness in the Ada
7319 declaration, as in the regular Import cases.
7321 Mismatches typically result in either error messages from the builtin
7322 expander, internal compiler errors, or in a real call sequence. This
7323 should be refined to issue diagnostics helping error detection and
7326 /* Almost fake test, ensuring a use of each argument. */
7327 if (ftype1 == ftype2)
7333 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
7334 type with all size expressions that contain F updated by replacing F
7335 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
7336 nothing has changed. */
7339 substitute_in_type (tree t, tree f, tree r)
7344 switch (TREE_CODE (t))
7349 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7350 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7352 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7353 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7355 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7358 new = build_range_type (TREE_TYPE (t), low, high);
7359 if (TYPE_INDEX_TYPE (t))
7361 (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
7368 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7369 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7371 tree low = NULL_TREE, high = NULL_TREE;
7373 if (TYPE_MIN_VALUE (t))
7374 low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7375 if (TYPE_MAX_VALUE (t))
7376 high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7378 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7382 TYPE_MIN_VALUE (t) = low;
7383 TYPE_MAX_VALUE (t) = high;
7388 tem = substitute_in_type (TREE_TYPE (t), f, r);
7389 if (tem == TREE_TYPE (t))
7392 return build_complex_type (tem);
7398 /* Don't know how to do these yet. */
7403 tree component = substitute_in_type (TREE_TYPE (t), f, r);
7404 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
7406 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
7409 new = build_array_type (component, domain);
7410 TYPE_SIZE (new) = 0;
7411 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
7412 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
7414 TYPE_ALIGN (new) = TYPE_ALIGN (t);
7415 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
7417 /* If we had bounded the sizes of T by a constant, bound the sizes of
7418 NEW by the same constant. */
7419 if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
7421 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
7423 if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
7424 TYPE_SIZE_UNIT (new)
7425 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
7426 TYPE_SIZE_UNIT (new));
7432 case QUAL_UNION_TYPE:
7436 = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
7437 bool field_has_rep = false;
7438 tree last_field = NULL_TREE;
7440 tree new = copy_type (t);
7442 /* Start out with no fields, make new fields, and chain them
7443 in. If we haven't actually changed the type of any field,
7444 discard everything we've done and return the old type. */
7446 TYPE_FIELDS (new) = NULL_TREE;
7447 TYPE_SIZE (new) = NULL_TREE;
7449 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
7451 tree new_field = copy_node (field);
7453 TREE_TYPE (new_field)
7454 = substitute_in_type (TREE_TYPE (new_field), f, r);
7456 if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
7457 field_has_rep = true;
7458 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
7459 changed_field = true;
7461 /* If this is an internal field and the type of this field is
7462 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7463 the type just has one element, treat that as the field.
7464 But don't do this if we are processing a QUAL_UNION_TYPE. */
7465 if (TREE_CODE (t) != QUAL_UNION_TYPE
7466 && DECL_INTERNAL_P (new_field)
7467 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
7468 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
7470 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
7473 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
7476 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
7478 /* Make sure omitting the union doesn't change
7480 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
7481 new_field = next_new_field;
7485 DECL_CONTEXT (new_field) = new;
7486 SET_DECL_ORIGINAL_FIELD (new_field,
7487 (DECL_ORIGINAL_FIELD (field)
7488 ? DECL_ORIGINAL_FIELD (field) : field));
7490 /* If the size of the old field was set at a constant,
7491 propagate the size in case the type's size was variable.
7492 (This occurs in the case of a variant or discriminated
7493 record with a default size used as a field of another
7495 DECL_SIZE (new_field)
7496 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
7497 ? DECL_SIZE (field) : NULL_TREE;
7498 DECL_SIZE_UNIT (new_field)
7499 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
7500 ? DECL_SIZE_UNIT (field) : NULL_TREE;
7502 if (TREE_CODE (t) == QUAL_UNION_TYPE)
7504 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7506 if (new_q != DECL_QUALIFIER (new_field))
7507 changed_field = true;
7509 /* Do the substitution inside the qualifier and if we find
7510 that this field will not be present, omit it. */
7511 DECL_QUALIFIER (new_field) = new_q;
7513 if (integer_zerop (DECL_QUALIFIER (new_field)))
7518 TYPE_FIELDS (new) = new_field;
7520 TREE_CHAIN (last_field) = new_field;
7522 last_field = new_field;
7524 /* If this is a qualified type and this field will always be
7525 present, we are done. */
7526 if (TREE_CODE (t) == QUAL_UNION_TYPE
7527 && integer_onep (DECL_QUALIFIER (new_field)))
7531 /* If this used to be a qualified union type, but we now know what
7532 field will be present, make this a normal union. */
7533 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
7534 && (!TYPE_FIELDS (new)
7535 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7536 TREE_SET_CODE (new, UNION_TYPE);
7537 else if (!changed_field)
7540 gcc_assert (!field_has_rep);
7543 /* If the size was originally a constant use it. */
7544 if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
7545 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
7547 TYPE_SIZE (new) = TYPE_SIZE (t);
7548 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
7549 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
7560 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7561 needed to represent the object. */
7564 rm_size (tree gnu_type)
7566 /* For integer types, this is the precision. For record types, we store
7567 the size explicitly. For other types, this is just the size. */
7569 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7570 return TYPE_RM_SIZE (gnu_type);
7571 else if (TREE_CODE (gnu_type) == RECORD_TYPE
7572 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7573 /* Return the rm_size of the actual data plus the size of the template. */
7575 size_binop (PLUS_EXPR,
7576 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7577 DECL_SIZE (TYPE_FIELDS (gnu_type)));
7578 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7579 || TREE_CODE (gnu_type) == UNION_TYPE
7580 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7581 && !TYPE_IS_FAT_POINTER_P (gnu_type)
7582 && TYPE_ADA_SIZE (gnu_type))
7583 return TYPE_ADA_SIZE (gnu_type);
7585 return TYPE_SIZE (gnu_type);
7588 /* Return an identifier representing the external name to be used for
7589 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7590 and the specified suffix. */
7593 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7595 Entity_Kind kind = Ekind (gnat_entity);
7597 const char *str = (!suffix ? "" : suffix);
7598 String_Template temp = {1, strlen (str)};
7599 Fat_Pointer fp = {str, &temp};
7601 Get_External_Name_With_Suffix (gnat_entity, fp);
7603 /* A variable using the Stdcall convention (meaning we are running
7604 on a Windows box) live in a DLL. Here we adjust its name to use
7605 the jump-table, the _imp__NAME contains the address for the NAME
7607 if ((kind == E_Variable || kind == E_Constant)
7608 && Has_Stdcall_Convention (gnat_entity))
7610 const char *prefix = "_imp__";
7611 int k, plen = strlen (prefix);
7613 for (k = 0; k <= Name_Len; k++)
7614 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
7615 strncpy (Name_Buffer, prefix, plen);
7618 return get_identifier (Name_Buffer);
7621 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7622 fully-qualified name, possibly with type information encoding.
7623 Otherwise, return the name. */
7626 get_entity_name (Entity_Id gnat_entity)
7628 Get_Encoded_Name (gnat_entity);
7629 return get_identifier (Name_Buffer);
7632 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7633 string, return a new IDENTIFIER_NODE that is the concatenation of
7634 the name in GNU_ID and SUFFIX. */
7637 concat_id_with_name (tree gnu_id, const char *suffix)
7639 int len = IDENTIFIER_LENGTH (gnu_id);
7641 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
7642 strncpy (Name_Buffer + len, "___", 3);
7644 strcpy (Name_Buffer + len, suffix);
7645 return get_identifier (Name_Buffer);
7648 #include "gt-ada-decl.h"