1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2009, 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"
36 #include "tree-inline.h"
54 #ifndef MAX_FIXED_MODE_SIZE
55 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
58 /* Convention_Stdcall should be processed in a specific way on Windows targets
59 only. The macro below is a helper to avoid having to check for a Windows
60 specific attribute throughout this unit. */
62 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
63 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Stdcall_Convention(E) (0)
68 /* Stack realignment for functions with foreign conventions is provided on a
69 per back-end basis now, as it is handled by the prologue expanders and not
70 as part of the function's body any more. It might be requested by way of a
71 dedicated function type attribute on the targets that support it.
73 We need a way to avoid setting the attribute on the targets that don't
74 support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
76 It is defined on targets where the circuitry is available, and indicates
77 whether the realignment is needed for 'main'. We use this to decide for
78 foreign subprograms as well.
80 It is not defined on targets where the circuitry is not implemented, and
81 we just never set the attribute in these cases.
83 Whether it is defined on all targets that would need it in theory is
84 not entirely clear. We currently trust the base GCC settings for this
87 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
88 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
93 struct incomplete *next;
98 /* These variables are used to defer recursively expanding incomplete types
99 while we are processing an array, a record or a subprogram type. */
100 static int defer_incomplete_level = 0;
101 static struct incomplete *defer_incomplete_list;
103 /* This variable is used to delay expanding From_With_Type types until the
105 static struct incomplete *defer_limited_with;
107 /* These variables are used to defer finalizing types. The element of the
108 list is the TYPE_DECL associated with the type. */
109 static int defer_finalize_level = 0;
110 static VEC (tree,heap) *defer_finalize_list;
112 /* A hash table used to cache the result of annotate_value. */
113 static GTY ((if_marked ("tree_int_map_marked_p"),
114 param_is (struct tree_int_map))) htab_t annotate_value_cache;
123 static void relate_alias_sets (tree, tree, enum alias_set_op);
125 static bool allocatable_size_p (tree, bool);
126 static void prepend_one_attribute_to (struct attrib **,
127 enum attr_type, tree, tree, Node_Id);
128 static void prepend_attributes (Entity_Id, struct attrib **);
129 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
130 static bool is_variable_size (tree);
131 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
132 static tree make_packable_type (tree, bool);
133 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
134 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
136 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
137 static bool same_discriminant_p (Entity_Id, Entity_Id);
138 static bool array_type_has_nonaliased_component (Entity_Id, tree);
139 static bool compile_time_known_address_p (Node_Id);
140 static bool cannot_be_superflat_p (Node_Id);
141 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
142 bool, bool, bool, bool, bool);
143 static Uint annotate_value (tree);
144 static void annotate_rep (Entity_Id, tree);
145 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
146 static tree build_subst_list (Entity_Id, Entity_Id, bool);
147 static tree build_variant_list (tree, tree, tree);
148 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
149 static void set_rm_size (Uint, tree, Entity_Id);
150 static tree make_type_from_size (tree, tree, bool);
151 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
152 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
153 static void check_ok_for_atomic (tree, Entity_Id, bool);
154 static int compatible_signatures_p (tree, tree);
155 static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
156 static tree get_rep_part (tree);
157 static tree get_variant_part (tree);
158 static tree create_variant_part_from (tree, tree, tree, tree, tree);
159 static void copy_and_substitute_in_size (tree, tree, tree);
160 static void rest_of_type_decl_compilation_no_defer (tree);
162 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
163 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
164 and associate the ..._DECL node with the input GNAT defining identifier.
166 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
167 initial value (in GCC tree form). This is optional for a variable. For
168 a renamed entity, GNU_EXPR gives the object being renamed.
170 DEFINITION is nonzero if this call is intended for a definition. This is
171 used for separate compilation where it is necessary to know whether an
172 external declaration or a definition must be created if the GCC equivalent
173 was not created previously. The value of 1 is normally used for a nonzero
174 DEFINITION, but a value of 2 is used in special circumstances, defined in
178 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
180 /* Contains the kind of the input GNAT node. */
181 const Entity_Kind kind = Ekind (gnat_entity);
182 /* True if this is a type. */
183 const bool is_type = IN (kind, Type_Kind);
184 /* For a type, contains the equivalent GNAT node to be used in gigi. */
185 Entity_Id gnat_equiv_type = Empty;
186 /* Temporary used to walk the GNAT tree. */
188 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
189 This node will be associated with the GNAT node by calling at the end
190 of the `switch' statement. */
191 tree gnu_decl = NULL_TREE;
192 /* Contains the GCC type to be used for the GCC node. */
193 tree gnu_type = NULL_TREE;
194 /* Contains the GCC size tree to be used for the GCC node. */
195 tree gnu_size = NULL_TREE;
196 /* Contains the GCC name to be used for the GCC node. */
197 tree gnu_entity_name;
198 /* True if we have already saved gnu_decl as a GNAT association. */
200 /* True if we incremented defer_incomplete_level. */
201 bool this_deferred = false;
202 /* True if we incremented force_global. */
203 bool this_global = false;
204 /* True if we should check to see if elaborated during processing. */
205 bool maybe_present = false;
206 /* True if we made GNU_DECL and its type here. */
207 bool this_made_decl = false;
208 /* True if debug info is requested for this entity. */
209 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
210 || debug_info_level == DINFO_LEVEL_VERBOSE);
211 /* True if this entity is to be considered as imported. */
212 bool imported_p = (Is_Imported (gnat_entity)
213 && No (Address_Clause (gnat_entity)));
214 /* Size and alignment of the GCC node, if meaningful. */
215 unsigned int esize = 0, align = 0;
216 /* Contains the list of attributes directly attached to the entity. */
217 struct attrib *attr_list = NULL;
219 /* Since a use of an Itype is a definition, process it as such if it
220 is not in a with'ed unit. */
223 && Is_Itype (gnat_entity)
224 && !present_gnu_tree (gnat_entity)
225 && In_Extended_Main_Code_Unit (gnat_entity))
227 /* Ensure that we are in a subprogram mentioned in the Scope chain of
228 this entity, our current scope is global, or we encountered a task
229 or entry (where we can't currently accurately check scoping). */
230 if (!current_function_decl
231 || DECL_ELABORATION_PROC_P (current_function_decl))
233 process_type (gnat_entity);
234 return get_gnu_tree (gnat_entity);
237 for (gnat_temp = Scope (gnat_entity);
239 gnat_temp = Scope (gnat_temp))
241 if (Is_Type (gnat_temp))
242 gnat_temp = Underlying_Type (gnat_temp);
244 if (Ekind (gnat_temp) == E_Subprogram_Body)
246 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
248 if (IN (Ekind (gnat_temp), Subprogram_Kind)
249 && Present (Protected_Body_Subprogram (gnat_temp)))
250 gnat_temp = Protected_Body_Subprogram (gnat_temp);
252 if (Ekind (gnat_temp) == E_Entry
253 || Ekind (gnat_temp) == E_Entry_Family
254 || Ekind (gnat_temp) == E_Task_Type
255 || (IN (Ekind (gnat_temp), Subprogram_Kind)
256 && present_gnu_tree (gnat_temp)
257 && (current_function_decl
258 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
260 process_type (gnat_entity);
261 return get_gnu_tree (gnat_entity);
265 /* This abort means the Itype has an incorrect scope, i.e. that its
266 scope does not correspond to the subprogram it is declared in. */
270 /* If we've already processed this entity, return what we got last time.
271 If we are defining the node, we should not have already processed it.
272 In that case, we will abort below when we try to save a new GCC tree
273 for this object. We also need to handle the case of getting a dummy
274 type when a Full_View exists. */
275 if ((!definition || (is_type && imported_p))
276 && present_gnu_tree (gnat_entity))
278 gnu_decl = get_gnu_tree (gnat_entity);
280 if (TREE_CODE (gnu_decl) == TYPE_DECL
281 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
282 && IN (kind, Incomplete_Or_Private_Kind)
283 && Present (Full_View (gnat_entity)))
286 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
287 save_gnu_tree (gnat_entity, NULL_TREE, false);
288 save_gnu_tree (gnat_entity, gnu_decl, false);
294 /* If this is a numeric or enumeral type, or an access type, a nonzero
295 Esize must be specified unless it was specified by the programmer. */
296 gcc_assert (!Unknown_Esize (gnat_entity)
297 || Has_Size_Clause (gnat_entity)
298 || (!IN (kind, Numeric_Kind)
299 && !IN (kind, Enumeration_Kind)
300 && (!IN (kind, Access_Kind)
301 || kind == E_Access_Protected_Subprogram_Type
302 || kind == E_Anonymous_Access_Protected_Subprogram_Type
303 || kind == E_Access_Subtype)));
305 /* The RM size must be specified for all discrete and fixed-point types. */
306 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
307 && Unknown_RM_Size (gnat_entity)));
309 /* If we get here, it means we have not yet done anything with this entity.
310 If we are not defining it, it must be a type or an entity that is defined
311 elsewhere or externally, otherwise we should have defined it already. */
312 gcc_assert (definition
313 || type_annotate_only
315 || kind == E_Discriminant
316 || kind == E_Component
318 || (kind == E_Constant && Present (Full_View (gnat_entity)))
319 || Is_Public (gnat_entity));
321 /* Get the name of the entity and set up the line number and filename of
322 the original definition for use in any decl we make. */
323 gnu_entity_name = get_entity_name (gnat_entity);
324 Sloc_to_locus (Sloc (gnat_entity), &input_location);
326 /* For cases when we are not defining (i.e., we are referencing from
327 another compilation unit) public entities, show we are at global level
328 for the purpose of computing scopes. Don't do this for components or
329 discriminants since the relevant test is whether or not the record is
332 && kind != E_Component
333 && kind != E_Discriminant
334 && Is_Public (gnat_entity)
335 && !Is_Statically_Allocated (gnat_entity))
336 force_global++, this_global = true;
338 /* Handle any attributes directly attached to the entity. */
339 if (Has_Gigi_Rep_Item (gnat_entity))
340 prepend_attributes (gnat_entity, &attr_list);
342 /* Do some common processing for types. */
345 /* Compute the equivalent type to be used in gigi. */
346 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
348 /* Machine_Attributes on types are expected to be propagated to
349 subtypes. The corresponding Gigi_Rep_Items are only attached
350 to the first subtype though, so we handle the propagation here. */
351 if (Base_Type (gnat_entity) != gnat_entity
352 && !Is_First_Subtype (gnat_entity)
353 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
354 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
357 /* Compute a default value for the size of the type. */
358 if (Known_Esize (gnat_entity)
359 && UI_Is_In_Int_Range (Esize (gnat_entity)))
361 unsigned int max_esize;
362 esize = UI_To_Int (Esize (gnat_entity));
364 if (IN (kind, Float_Kind))
365 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
366 else if (IN (kind, Access_Kind))
367 max_esize = POINTER_SIZE * 2;
369 max_esize = LONG_LONG_TYPE_SIZE;
371 if (esize > max_esize)
375 esize = LONG_LONG_TYPE_SIZE;
381 /* If this is a use of a deferred constant without address clause,
382 get its full definition. */
384 && No (Address_Clause (gnat_entity))
385 && Present (Full_View (gnat_entity)))
388 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
393 /* If we have an external constant that we are not defining, get the
394 expression that is was defined to represent. We may throw that
395 expression away later if it is not a constant. Do not retrieve the
396 expression if it is an aggregate or allocator, because in complex
397 instantiation contexts it may not be expanded */
399 && Present (Expression (Declaration_Node (gnat_entity)))
400 && !No_Initialization (Declaration_Node (gnat_entity))
401 && (Nkind (Expression (Declaration_Node (gnat_entity)))
403 && (Nkind (Expression (Declaration_Node (gnat_entity)))
405 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
407 /* Ignore deferred constant definitions without address clause since
408 they are processed fully in the front-end. If No_Initialization
409 is set, this is not a deferred constant but a constant whose value
410 is built manually. And constants that are renamings are handled
414 && No (Address_Clause (gnat_entity))
415 && !No_Initialization (Declaration_Node (gnat_entity))
416 && No (Renamed_Object (gnat_entity)))
418 gnu_decl = error_mark_node;
423 /* Ignore constant definitions already marked with the error node. See
424 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
427 && present_gnu_tree (gnat_entity)
428 && get_gnu_tree (gnat_entity) == error_mark_node)
430 maybe_present = true;
437 /* We used to special case VMS exceptions here to directly map them to
438 their associated condition code. Since this code had to be masked
439 dynamically to strip off the severity bits, this caused trouble in
440 the GCC/ZCX case because the "type" pointers we store in the tables
441 have to be static. We now don't special case here anymore, and let
442 the regular processing take place, which leaves us with a regular
443 exception data object for VMS exceptions too. The condition code
444 mapping is taken care of by the front end and the bitmasking by the
451 /* The GNAT record where the component was defined. */
452 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
454 /* If the variable is an inherited record component (in the case of
455 extended record types), just return the inherited entity, which
456 must be a FIELD_DECL. Likewise for discriminants.
457 For discriminants of untagged records which have explicit
458 stored discriminants, return the entity for the corresponding
459 stored discriminant. Also use Original_Record_Component
460 if the record has a private extension. */
461 if (Present (Original_Record_Component (gnat_entity))
462 && Original_Record_Component (gnat_entity) != gnat_entity)
465 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
466 gnu_expr, definition);
471 /* If the enclosing record has explicit stored discriminants,
472 then it is an untagged record. If the Corresponding_Discriminant
473 is not empty then this must be a renamed discriminant and its
474 Original_Record_Component must point to the corresponding explicit
475 stored discriminant (i.e. we should have taken the previous
477 else if (Present (Corresponding_Discriminant (gnat_entity))
478 && Is_Tagged_Type (gnat_record))
480 /* A tagged record has no explicit stored discriminants. */
481 gcc_assert (First_Discriminant (gnat_record)
482 == First_Stored_Discriminant (gnat_record));
484 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
485 gnu_expr, definition);
490 else if (Present (CR_Discriminant (gnat_entity))
491 && type_annotate_only)
493 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
494 gnu_expr, definition);
499 /* If the enclosing record has explicit stored discriminants, then
500 it is an untagged record. If the Corresponding_Discriminant
501 is not empty then this must be a renamed discriminant and its
502 Original_Record_Component must point to the corresponding explicit
503 stored discriminant (i.e. we should have taken the first
505 else if (Present (Corresponding_Discriminant (gnat_entity))
506 && (First_Discriminant (gnat_record)
507 != First_Stored_Discriminant (gnat_record)))
510 /* Otherwise, if we are not defining this and we have no GCC type
511 for the containing record, make one for it. Then we should
512 have made our own equivalent. */
513 else if (!definition && !present_gnu_tree (gnat_record))
515 /* ??? If this is in a record whose scope is a protected
516 type and we have an Original_Record_Component, use it.
517 This is a workaround for major problems in protected type
519 Entity_Id Scop = Scope (Scope (gnat_entity));
520 if ((Is_Protected_Type (Scop)
521 || (Is_Private_Type (Scop)
522 && Present (Full_View (Scop))
523 && Is_Protected_Type (Full_View (Scop))))
524 && Present (Original_Record_Component (gnat_entity)))
527 = gnat_to_gnu_entity (Original_Record_Component
534 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
535 gnu_decl = get_gnu_tree (gnat_entity);
541 /* Here we have no GCC type and this is a reference rather than a
542 definition. This should never happen. Most likely the cause is
543 reference before declaration in the gnat tree for gnat_entity. */
547 case E_Loop_Parameter:
548 case E_Out_Parameter:
551 /* Simple variables, loop variables, Out parameters, and exceptions. */
554 bool used_by_ref = false;
556 = ((kind == E_Constant || kind == E_Variable)
557 && Is_True_Constant (gnat_entity)
558 && !Treat_As_Volatile (gnat_entity)
559 && (((Nkind (Declaration_Node (gnat_entity))
560 == N_Object_Declaration)
561 && Present (Expression (Declaration_Node (gnat_entity))))
562 || Present (Renamed_Object (gnat_entity))));
563 bool inner_const_flag = const_flag;
564 bool static_p = Is_Statically_Allocated (gnat_entity);
565 bool mutable_p = false;
566 tree gnu_ext_name = NULL_TREE;
567 tree renamed_obj = NULL_TREE;
568 tree gnu_object_size;
570 if (Present (Renamed_Object (gnat_entity)) && !definition)
572 if (kind == E_Exception)
573 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
576 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
579 /* Get the type after elaborating the renamed object. */
580 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
582 /* For a debug renaming declaration, build a pure debug entity. */
583 if (Present (Debug_Renaming_Link (gnat_entity)))
586 gnu_decl = build_decl (input_location,
587 VAR_DECL, gnu_entity_name, gnu_type);
588 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
589 if (global_bindings_p ())
590 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
592 addr = stack_pointer_rtx;
593 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
594 gnat_pushdecl (gnu_decl, gnat_entity);
598 /* If this is a loop variable, its type should be the base type.
599 This is because the code for processing a loop determines whether
600 a normal loop end test can be done by comparing the bounds of the
601 loop against those of the base type, which is presumed to be the
602 size used for computation. But this is not correct when the size
603 of the subtype is smaller than the type. */
604 if (kind == E_Loop_Parameter)
605 gnu_type = get_base_type (gnu_type);
607 /* Reject non-renamed objects whose types are unconstrained arrays or
608 any object whose type is a dummy type or VOID_TYPE. */
610 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
611 && No (Renamed_Object (gnat_entity)))
612 || TYPE_IS_DUMMY_P (gnu_type)
613 || TREE_CODE (gnu_type) == VOID_TYPE)
615 gcc_assert (type_annotate_only);
618 return error_mark_node;
621 /* If an alignment is specified, use it if valid. Note that exceptions
622 are objects but don't have an alignment. We must do this before we
623 validate the size, since the alignment can affect the size. */
624 if (kind != E_Exception && Known_Alignment (gnat_entity))
626 gcc_assert (Present (Alignment (gnat_entity)));
627 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
628 TYPE_ALIGN (gnu_type));
629 /* No point in changing the type if there is an address clause
630 as the final type of the object will be a reference type. */
631 if (Present (Address_Clause (gnat_entity)))
635 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
636 false, false, definition, true);
639 /* If we are defining the object, see if it has a Size value and
640 validate it if so. If we are not defining the object and a Size
641 clause applies, simply retrieve the value. We don't want to ignore
642 the clause and it is expected to have been validated already. Then
643 get the new type, if any. */
645 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
646 gnat_entity, VAR_DECL, false,
647 Has_Size_Clause (gnat_entity));
648 else if (Has_Size_Clause (gnat_entity))
649 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
654 = make_type_from_size (gnu_type, gnu_size,
655 Has_Biased_Representation (gnat_entity));
657 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
658 gnu_size = NULL_TREE;
661 /* If this object has self-referential size, it must be a record with
662 a default value. We are supposed to allocate an object of the
663 maximum size in this case unless it is a constant with an
664 initializing expression, in which case we can get the size from
665 that. Note that the resulting size may still be a variable, so
666 this may end up with an indirect allocation. */
667 if (No (Renamed_Object (gnat_entity))
668 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
670 if (gnu_expr && kind == E_Constant)
672 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
673 if (CONTAINS_PLACEHOLDER_P (size))
675 /* If the initializing expression is itself a constant,
676 despite having a nominal type with self-referential
677 size, we can get the size directly from it. */
678 if (TREE_CODE (gnu_expr) == COMPONENT_REF
680 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
681 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
682 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
683 || DECL_READONLY_ONCE_ELAB
684 (TREE_OPERAND (gnu_expr, 0))))
685 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
688 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
693 /* We may have no GNU_EXPR because No_Initialization is
694 set even though there's an Expression. */
695 else if (kind == E_Constant
696 && (Nkind (Declaration_Node (gnat_entity))
697 == N_Object_Declaration)
698 && Present (Expression (Declaration_Node (gnat_entity))))
700 = TYPE_SIZE (gnat_to_gnu_type
702 (Expression (Declaration_Node (gnat_entity)))));
705 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
710 /* If the size is zero bytes, make it one byte since some linkers have
711 trouble with zero-sized objects. If the object will have a
712 template, that will make it nonzero so don't bother. Also avoid
713 doing that for an object renaming or an object with an address
714 clause, as we would lose useful information on the view size
715 (e.g. for null array slices) and we are not allocating the object
718 && integer_zerop (gnu_size)
719 && !TREE_OVERFLOW (gnu_size))
720 || (TYPE_SIZE (gnu_type)
721 && integer_zerop (TYPE_SIZE (gnu_type))
722 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
723 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
724 || !Is_Array_Type (Etype (gnat_entity)))
725 && No (Renamed_Object (gnat_entity))
726 && No (Address_Clause (gnat_entity)))
727 gnu_size = bitsize_unit_node;
729 /* If this is an object with no specified size and alignment, and
730 if either it is atomic or we are not optimizing alignment for
731 space and it is composite and not an exception, an Out parameter
732 or a reference to another object, and the size of its type is a
733 constant, set the alignment to the smallest one which is not
734 smaller than the size, with an appropriate cap. */
735 if (!gnu_size && align == 0
736 && (Is_Atomic (gnat_entity)
737 || (!Optimize_Alignment_Space (gnat_entity)
738 && kind != E_Exception
739 && kind != E_Out_Parameter
740 && Is_Composite_Type (Etype (gnat_entity))
741 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
743 && No (Renamed_Object (gnat_entity))
744 && No (Address_Clause (gnat_entity))))
745 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
747 /* No point in jumping through all the hoops needed in order
748 to support BIGGEST_ALIGNMENT if we don't really have to.
749 So we cap to the smallest alignment that corresponds to
750 a known efficient memory access pattern of the target. */
751 unsigned int align_cap = Is_Atomic (gnat_entity)
753 : get_mode_alignment (ptr_mode);
755 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
756 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
759 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
761 /* But make sure not to under-align the object. */
762 if (align <= TYPE_ALIGN (gnu_type))
765 /* And honor the minimum valid atomic alignment, if any. */
766 #ifdef MINIMUM_ATOMIC_ALIGNMENT
767 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
768 align = MINIMUM_ATOMIC_ALIGNMENT;
772 /* If the object is set to have atomic components, find the component
773 type and validate it.
775 ??? Note that we ignore Has_Volatile_Components on objects; it's
776 not at all clear what to do in that case. */
778 if (Has_Atomic_Components (gnat_entity))
780 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
781 ? TREE_TYPE (gnu_type) : gnu_type);
783 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
784 && TYPE_MULTI_ARRAY_P (gnu_inner))
785 gnu_inner = TREE_TYPE (gnu_inner);
787 check_ok_for_atomic (gnu_inner, gnat_entity, true);
790 /* Now check if the type of the object allows atomic access. Note
791 that we must test the type, even if this object has size and
792 alignment to allow such access, because we will be going
793 inside the padded record to assign to the object. We could fix
794 this by always copying via an intermediate value, but it's not
795 clear it's worth the effort. */
796 if (Is_Atomic (gnat_entity))
797 check_ok_for_atomic (gnu_type, gnat_entity, false);
799 /* If this is an aliased object with an unconstrained nominal subtype,
800 make a type that includes the template. */
801 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
802 && Is_Array_Type (Etype (gnat_entity))
803 && !type_annotate_only)
806 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
809 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
810 concat_name (gnu_entity_name,
814 #ifdef MINIMUM_ATOMIC_ALIGNMENT
815 /* If the size is a constant and no alignment is specified, force
816 the alignment to be the minimum valid atomic alignment. The
817 restriction on constant size avoids problems with variable-size
818 temporaries; if the size is variable, there's no issue with
819 atomic access. Also don't do this for a constant, since it isn't
820 necessary and can interfere with constant replacement. Finally,
821 do not do it for Out parameters since that creates an
822 size inconsistency with In parameters. */
823 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
824 && !FLOAT_TYPE_P (gnu_type)
825 && !const_flag && No (Renamed_Object (gnat_entity))
826 && !imported_p && No (Address_Clause (gnat_entity))
827 && kind != E_Out_Parameter
828 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
829 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
830 align = MINIMUM_ATOMIC_ALIGNMENT;
833 /* Make a new type with the desired size and alignment, if needed.
834 But do not take into account alignment promotions to compute the
835 size of the object. */
836 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
837 if (gnu_size || align > 0)
838 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
839 false, false, definition,
840 gnu_size ? true : false);
842 /* If this is a renaming, avoid as much as possible to create a new
843 object. However, in several cases, creating it is required.
844 This processing needs to be applied to the raw expression so
845 as to make it more likely to rename the underlying object. */
846 if (Present (Renamed_Object (gnat_entity)))
848 bool create_normal_object = false;
850 /* If the renamed object had padding, strip off the reference
851 to the inner object and reset our type. */
852 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
853 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
854 /* Strip useless conversions around the object. */
855 || (TREE_CODE (gnu_expr) == NOP_EXPR
856 && gnat_types_compatible_p
857 (TREE_TYPE (gnu_expr),
858 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
860 gnu_expr = TREE_OPERAND (gnu_expr, 0);
861 gnu_type = TREE_TYPE (gnu_expr);
864 /* Case 1: If this is a constant renaming stemming from a function
865 call, treat it as a normal object whose initial value is what
866 is being renamed. RM 3.3 says that the result of evaluating a
867 function call is a constant object. As a consequence, it can
868 be the inner object of a constant renaming. In this case, the
869 renaming must be fully instantiated, i.e. it cannot be a mere
870 reference to (part of) an existing object. */
873 tree inner_object = gnu_expr;
874 while (handled_component_p (inner_object))
875 inner_object = TREE_OPERAND (inner_object, 0);
876 if (TREE_CODE (inner_object) == CALL_EXPR)
877 create_normal_object = true;
880 /* Otherwise, see if we can proceed with a stabilized version of
881 the renamed entity or if we need to make a new object. */
882 if (!create_normal_object)
884 tree maybe_stable_expr = NULL_TREE;
887 /* Case 2: If the renaming entity need not be materialized and
888 the renamed expression is something we can stabilize, use
889 that for the renaming. At the global level, we can only do
890 this if we know no SAVE_EXPRs need be made, because the
891 expression we return might be used in arbitrary conditional
892 branches so we must force the SAVE_EXPRs evaluation
893 immediately and this requires a function context. */
894 if (!Materialize_Entity (gnat_entity)
895 && (!global_bindings_p ()
896 || (staticp (gnu_expr)
897 && !TREE_SIDE_EFFECTS (gnu_expr))))
900 = maybe_stabilize_reference (gnu_expr, true, &stable);
904 /* ??? No DECL_EXPR is created so we need to mark
905 the expression manually lest it is shared. */
906 if (global_bindings_p ())
907 MARK_VISITED (maybe_stable_expr);
908 gnu_decl = maybe_stable_expr;
909 save_gnu_tree (gnat_entity, gnu_decl, true);
911 annotate_object (gnat_entity, gnu_type, NULL_TREE,
916 /* The stabilization failed. Keep maybe_stable_expr
917 untouched here to let the pointer case below know
918 about that failure. */
921 /* Case 3: If this is a constant renaming and creating a
922 new object is allowed and cheap, treat it as a normal
923 object whose initial value is what is being renamed. */
925 && !Is_Composite_Type
926 (Underlying_Type (Etype (gnat_entity))))
929 /* Case 4: Make this into a constant pointer to the object we
930 are to rename and attach the object to the pointer if it is
931 something we can stabilize.
933 From the proper scope, attached objects will be referenced
934 directly instead of indirectly via the pointer to avoid
935 subtle aliasing problems with non-addressable entities.
936 They have to be stable because we must not evaluate the
937 variables in the expression every time the renaming is used.
938 The pointer is called a "renaming" pointer in this case.
940 In the rare cases where we cannot stabilize the renamed
941 object, we just make a "bare" pointer, and the renamed
942 entity is always accessed indirectly through it. */
945 gnu_type = build_reference_type (gnu_type);
946 inner_const_flag = TREE_READONLY (gnu_expr);
949 /* If the previous attempt at stabilizing failed, there
950 is no point in trying again and we reuse the result
951 without attaching it to the pointer. In this case it
952 will only be used as the initializing expression of
953 the pointer and thus needs no special treatment with
954 regard to multiple evaluations. */
955 if (maybe_stable_expr)
958 /* Otherwise, try to stabilize and attach the expression
959 to the pointer if the stabilization succeeds.
961 Note that this might introduce SAVE_EXPRs and we don't
962 check whether we're at the global level or not. This
963 is fine since we are building a pointer initializer and
964 neither the pointer nor the initializing expression can
965 be accessed before the pointer elaboration has taken
966 place in a correct program.
968 These SAVE_EXPRs will be evaluated at the right place
969 by either the evaluation of the initializer for the
970 non-global case or the elaboration code for the global
971 case, and will be attached to the elaboration procedure
972 in the latter case. */
976 = maybe_stabilize_reference (gnu_expr, true, &stable);
979 renamed_obj = maybe_stable_expr;
981 /* Attaching is actually performed downstream, as soon
982 as we have a VAR_DECL for the pointer we make. */
986 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
988 gnu_size = NULL_TREE;
994 /* Make a volatile version of this object's type if we are to make
995 the object volatile. We also interpret 13.3(19) conservatively
996 and disallow any optimizations for such a non-constant object. */
997 if ((Treat_As_Volatile (gnat_entity)
999 && (Is_Exported (gnat_entity)
1000 || Is_Imported (gnat_entity)
1001 || Present (Address_Clause (gnat_entity)))))
1002 && !TYPE_VOLATILE (gnu_type))
1003 gnu_type = build_qualified_type (gnu_type,
1004 (TYPE_QUALS (gnu_type)
1005 | TYPE_QUAL_VOLATILE));
1007 /* If we are defining an aliased object whose nominal subtype is
1008 unconstrained, the object is a record that contains both the
1009 template and the object. If there is an initializer, it will
1010 have already been converted to the right type, but we need to
1011 create the template if there is no initializer. */
1014 && TREE_CODE (gnu_type) == RECORD_TYPE
1015 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1016 /* Beware that padding might have been introduced above. */
1017 || (TYPE_PADDING_P (gnu_type)
1018 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1020 && TYPE_CONTAINS_TEMPLATE_P
1021 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1024 = TYPE_PADDING_P (gnu_type)
1025 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1026 : TYPE_FIELDS (gnu_type);
1029 = gnat_build_constructor
1033 build_template (TREE_TYPE (template_field),
1034 TREE_TYPE (TREE_CHAIN (template_field)),
1039 /* Convert the expression to the type of the object except in the
1040 case where the object's type is unconstrained or the object's type
1041 is a padded record whose field is of self-referential size. In
1042 the former case, converting will generate unnecessary evaluations
1043 of the CONSTRUCTOR to compute the size and in the latter case, we
1044 want to only copy the actual data. */
1046 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1047 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1048 && !(TYPE_IS_PADDING_P (gnu_type)
1049 && CONTAINS_PLACEHOLDER_P
1050 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1051 gnu_expr = convert (gnu_type, gnu_expr);
1053 /* If this is a pointer and it does not have an initializing
1054 expression, initialize it to NULL, unless the object is
1057 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1058 && !Is_Imported (gnat_entity) && !gnu_expr)
1059 gnu_expr = integer_zero_node;
1061 /* If we are defining the object and it has an Address clause, we must
1062 either get the address expression from the saved GCC tree for the
1063 object if it has a Freeze node, or elaborate the address expression
1064 here since the front-end has guaranteed that the elaboration has no
1065 effects in this case. */
1066 if (definition && Present (Address_Clause (gnat_entity)))
1069 = present_gnu_tree (gnat_entity)
1070 ? get_gnu_tree (gnat_entity)
1071 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)));
1073 save_gnu_tree (gnat_entity, NULL_TREE, false);
1075 /* Ignore the size. It's either meaningless or was handled
1077 gnu_size = NULL_TREE;
1078 /* Convert the type of the object to a reference type that can
1079 alias everything as per 13.3(19). */
1081 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1082 gnu_address = convert (gnu_type, gnu_address);
1084 const_flag = !Is_Public (gnat_entity)
1085 || compile_time_known_address_p (Expression (Address_Clause
1088 /* If this is a deferred constant, the initializer is attached to
1090 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1093 (Expression (Declaration_Node (Full_View (gnat_entity))));
1095 /* If we don't have an initializing expression for the underlying
1096 variable, the initializing expression for the pointer is the
1097 specified address. Otherwise, we have to make a COMPOUND_EXPR
1098 to assign both the address and the initial value. */
1100 gnu_expr = gnu_address;
1103 = build2 (COMPOUND_EXPR, gnu_type,
1105 (MODIFY_EXPR, NULL_TREE,
1106 build_unary_op (INDIRECT_REF, NULL_TREE,
1112 /* If it has an address clause and we are not defining it, mark it
1113 as an indirect object. Likewise for Stdcall objects that are
1115 if ((!definition && Present (Address_Clause (gnat_entity)))
1116 || (Is_Imported (gnat_entity)
1117 && Has_Stdcall_Convention (gnat_entity)))
1119 /* Convert the type of the object to a reference type that can
1120 alias everything as per 13.3(19). */
1122 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1123 gnu_size = NULL_TREE;
1125 /* No point in taking the address of an initializing expression
1126 that isn't going to be used. */
1127 gnu_expr = NULL_TREE;
1129 /* If it has an address clause whose value is known at compile
1130 time, make the object a CONST_DECL. This will avoid a
1131 useless dereference. */
1132 if (Present (Address_Clause (gnat_entity)))
1134 Node_Id gnat_address
1135 = Expression (Address_Clause (gnat_entity));
1137 if (compile_time_known_address_p (gnat_address))
1139 gnu_expr = gnat_to_gnu (gnat_address);
1147 /* If we are at top level and this object is of variable size,
1148 make the actual type a hidden pointer to the real type and
1149 make the initializer be a memory allocation and initialization.
1150 Likewise for objects we aren't defining (presumed to be
1151 external references from other packages), but there we do
1152 not set up an initialization.
1154 If the object's size overflows, make an allocator too, so that
1155 Storage_Error gets raised. Note that we will never free
1156 such memory, so we presume it never will get allocated. */
1158 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1159 global_bindings_p () || !definition
1162 && ! allocatable_size_p (gnu_size,
1163 global_bindings_p () || !definition
1166 gnu_type = build_reference_type (gnu_type);
1167 gnu_size = NULL_TREE;
1171 /* In case this was a aliased object whose nominal subtype is
1172 unconstrained, the pointer above will be a thin pointer and
1173 build_allocator will automatically make the template.
1175 If we have a template initializer only (that we made above),
1176 pretend there is none and rely on what build_allocator creates
1177 again anyway. Otherwise (if we have a full initializer), get
1178 the data part and feed that to build_allocator.
1180 If we are elaborating a mutable object, tell build_allocator to
1181 ignore a possibly simpler size from the initializer, if any, as
1182 we must allocate the maximum possible size in this case. */
1186 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1188 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1189 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1192 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1194 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1195 && 1 == VEC_length (constructor_elt,
1196 CONSTRUCTOR_ELTS (gnu_expr)))
1200 = build_component_ref
1201 (gnu_expr, NULL_TREE,
1202 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1206 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1207 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1208 && !Is_Imported (gnat_entity))
1209 post_error ("?Storage_Error will be raised at run-time!",
1213 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1214 Empty, Empty, gnat_entity, mutable_p);
1218 gnu_expr = NULL_TREE;
1223 /* If this object would go into the stack and has an alignment larger
1224 than the largest stack alignment the back-end can honor, resort to
1225 a variable of "aligning type". */
1226 if (!global_bindings_p () && !static_p && definition
1227 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1229 /* Create the new variable. No need for extra room before the
1230 aligned field as this is in automatic storage. */
1232 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1233 TYPE_SIZE_UNIT (gnu_type),
1234 BIGGEST_ALIGNMENT, 0);
1236 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1237 NULL_TREE, gnu_new_type, NULL_TREE, false,
1238 false, false, false, NULL, gnat_entity);
1240 /* Initialize the aligned field if we have an initializer. */
1243 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1245 (gnu_new_var, NULL_TREE,
1246 TYPE_FIELDS (gnu_new_type), false),
1250 /* And setup this entity as a reference to the aligned field. */
1251 gnu_type = build_reference_type (gnu_type);
1254 (ADDR_EXPR, gnu_type,
1255 build_component_ref (gnu_new_var, NULL_TREE,
1256 TYPE_FIELDS (gnu_new_type), false));
1258 gnu_size = NULL_TREE;
1264 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1265 | TYPE_QUAL_CONST));
1267 /* Convert the expression to the type of the object except in the
1268 case where the object's type is unconstrained or the object's type
1269 is a padded record whose field is of self-referential size. In
1270 the former case, converting will generate unnecessary evaluations
1271 of the CONSTRUCTOR to compute the size and in the latter case, we
1272 want to only copy the actual data. */
1274 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1275 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1276 && !(TYPE_IS_PADDING_P (gnu_type)
1277 && CONTAINS_PLACEHOLDER_P
1278 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1279 gnu_expr = convert (gnu_type, gnu_expr);
1281 /* If this name is external or there was a name specified, use it,
1282 unless this is a VMS exception object since this would conflict
1283 with the symbol we need to export in addition. Don't use the
1284 Interface_Name if there is an address clause (see CD30005). */
1285 if (!Is_VMS_Exception (gnat_entity)
1286 && ((Present (Interface_Name (gnat_entity))
1287 && No (Address_Clause (gnat_entity)))
1288 || (Is_Public (gnat_entity)
1289 && (!Is_Imported (gnat_entity)
1290 || Is_Exported (gnat_entity)))))
1291 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1293 /* If this is constant initialized to a static constant and the
1294 object has an aggregate type, force it to be statically
1295 allocated. This will avoid an initialization copy. */
1296 if (!static_p && const_flag
1297 && gnu_expr && TREE_CONSTANT (gnu_expr)
1298 && AGGREGATE_TYPE_P (gnu_type)
1299 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1300 && !(TYPE_IS_PADDING_P (gnu_type)
1301 && !host_integerp (TYPE_SIZE_UNIT
1302 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1305 gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1306 gnu_expr, const_flag,
1307 Is_Public (gnat_entity),
1308 imported_p || !definition,
1309 static_p, attr_list, gnat_entity);
1310 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1311 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1312 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1314 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1315 if (global_bindings_p ())
1317 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1318 record_global_renaming_pointer (gnu_decl);
1322 if (definition && DECL_SIZE_UNIT (gnu_decl)
1323 && get_block_jmpbuf_decl ()
1324 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1325 || (flag_stack_check == GENERIC_STACK_CHECK
1326 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1327 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1328 add_stmt_with_node (build_call_1_expr
1329 (update_setjmp_buf_decl,
1330 build_unary_op (ADDR_EXPR, NULL_TREE,
1331 get_block_jmpbuf_decl ())),
1334 /* If we are defining an Out parameter and we're not optimizing,
1335 create a fake PARM_DECL for debugging purposes and make it
1336 point to the VAR_DECL. Suppress debug info for the latter
1337 but make sure it will still live on the stack so it can be
1338 accessed from within the debugger through the PARM_DECL. */
1339 if (kind == E_Out_Parameter && definition && !optimize)
1341 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1342 gnat_pushdecl (param, gnat_entity);
1343 SET_DECL_VALUE_EXPR (param, gnu_decl);
1344 DECL_HAS_VALUE_EXPR_P (param) = 1;
1346 debug_info_p = false;
1348 DECL_IGNORED_P (param) = 1;
1349 TREE_ADDRESSABLE (gnu_decl) = 1;
1352 /* If this is a public constant or we're not optimizing and we're not
1353 making a VAR_DECL for it, make one just for export or debugger use.
1354 Likewise if the address is taken or if either the object or type is
1355 aliased. Make an external declaration for a reference, unless this
1356 is a Standard entity since there no real symbol at the object level
1358 if (TREE_CODE (gnu_decl) == CONST_DECL
1359 && (definition || Sloc (gnat_entity) > Standard_Location)
1360 && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
1362 || Address_Taken (gnat_entity)
1363 || Is_Aliased (gnat_entity)
1364 || Is_Aliased (Etype (gnat_entity))))
1367 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1368 gnu_expr, true, Is_Public (gnat_entity),
1369 !definition, static_p, NULL,
1372 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1374 /* As debugging information will be generated for the variable,
1375 do not generate information for the constant. */
1376 DECL_IGNORED_P (gnu_decl) = 1;
1379 /* If this is declared in a block that contains a block with an
1380 exception handler, we must force this variable in memory to
1381 suppress an invalid optimization. */
1382 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1383 && Exception_Mechanism != Back_End_Exceptions)
1384 TREE_ADDRESSABLE (gnu_decl) = 1;
1386 /* Back-annotate Esize and Alignment of the object if not already
1387 known. Note that we pick the values of the type, not those of
1388 the object, to shield ourselves from low-level platform-dependent
1389 adjustments like alignment promotion. This is both consistent with
1390 all the treatment above, where alignment and size are set on the
1391 type of the object and not on the object directly, and makes it
1392 possible to support all confirming representation clauses. */
1393 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1399 /* Return a TYPE_DECL for "void" that we previously made. */
1400 gnu_decl = TYPE_NAME (void_type_node);
1403 case E_Enumeration_Type:
1404 /* A special case: for the types Character and Wide_Character in
1405 Standard, we do not list all the literals. So if the literals
1406 are not specified, make this an unsigned type. */
1407 if (No (First_Literal (gnat_entity)))
1409 gnu_type = make_unsigned_type (esize);
1410 TYPE_NAME (gnu_type) = gnu_entity_name;
1412 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1413 This is needed by the DWARF-2 back-end to distinguish between
1414 unsigned integer types and character types. */
1415 TYPE_STRING_FLAG (gnu_type) = 1;
1419 /* Normal case of non-character type or non-Standard character type. */
1421 /* Here we have a list of enumeral constants in First_Literal.
1422 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1423 the list to be placed into TYPE_FIELDS. Each node in the list
1424 is a TREE_LIST whose TREE_VALUE is the literal name and whose
1425 TREE_PURPOSE is the value of the literal. */
1427 Entity_Id gnat_literal;
1428 tree gnu_literal_list = NULL_TREE;
1430 if (Is_Unsigned_Type (gnat_entity))
1431 gnu_type = make_unsigned_type (esize);
1433 gnu_type = make_signed_type (esize);
1435 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1437 for (gnat_literal = First_Literal (gnat_entity);
1438 Present (gnat_literal);
1439 gnat_literal = Next_Literal (gnat_literal))
1441 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1444 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1445 gnu_type, gnu_value, true, false, false,
1446 false, NULL, gnat_literal);
1448 save_gnu_tree (gnat_literal, gnu_literal, false);
1449 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1450 gnu_value, gnu_literal_list);
1453 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1455 /* Note that the bounds are updated at the end of this function
1456 to avoid an infinite recursion since they refer to the type. */
1460 case E_Signed_Integer_Type:
1461 case E_Ordinary_Fixed_Point_Type:
1462 case E_Decimal_Fixed_Point_Type:
1463 /* For integer types, just make a signed type the appropriate number
1465 gnu_type = make_signed_type (esize);
1468 case E_Modular_Integer_Type:
1470 /* For modular types, make the unsigned type of the proper number
1471 of bits and then set up the modulus, if required. */
1472 tree gnu_modulus, gnu_high = NULL_TREE;
1474 /* Packed array types are supposed to be subtypes only. */
1475 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1477 gnu_type = make_unsigned_type (esize);
1479 /* Get the modulus in this type. If it overflows, assume it is because
1480 it is equal to 2**Esize. Note that there is no overflow checking
1481 done on unsigned type, so we detect the overflow by looking for
1482 a modulus of zero, which is otherwise invalid. */
1483 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1485 if (!integer_zerop (gnu_modulus))
1487 TYPE_MODULAR_P (gnu_type) = 1;
1488 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1489 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1490 convert (gnu_type, integer_one_node));
1493 /* If the upper bound is not maximal, make an extra subtype. */
1495 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1497 tree gnu_subtype = make_unsigned_type (esize);
1498 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1499 TREE_TYPE (gnu_subtype) = gnu_type;
1500 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1501 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1502 gnu_type = gnu_subtype;
1507 case E_Signed_Integer_Subtype:
1508 case E_Enumeration_Subtype:
1509 case E_Modular_Integer_Subtype:
1510 case E_Ordinary_Fixed_Point_Subtype:
1511 case E_Decimal_Fixed_Point_Subtype:
1513 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1514 not want to call create_range_type since we would like each subtype
1515 node to be distinct. ??? Historically this was in preparation for
1516 when memory aliasing is implemented, but that's obsolete now given
1517 the call to relate_alias_sets below.
1519 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1520 this fact is used by the arithmetic conversion functions.
1522 We elaborate the Ancestor_Subtype if it is not in the current unit
1523 and one of our bounds is non-static. We do this to ensure consistent
1524 naming in the case where several subtypes share the same bounds, by
1525 elaborating the first such subtype first, thus using its name. */
1528 && Present (Ancestor_Subtype (gnat_entity))
1529 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1530 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1531 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1532 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1534 /* Set the precision to the Esize except for bit-packed arrays. */
1535 if (Is_Packed_Array_Type (gnat_entity)
1536 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1537 esize = UI_To_Int (RM_Size (gnat_entity));
1539 /* This should be an unsigned type if the base type is unsigned or
1540 if the lower bound is constant and non-negative or if the type
1542 if (Is_Unsigned_Type (Etype (gnat_entity))
1543 || Is_Unsigned_Type (gnat_entity)
1544 || Has_Biased_Representation (gnat_entity))
1545 gnu_type = make_unsigned_type (esize);
1547 gnu_type = make_signed_type (esize);
1548 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1550 SET_TYPE_RM_MIN_VALUE
1552 convert (TREE_TYPE (gnu_type),
1553 elaborate_expression (Type_Low_Bound (gnat_entity),
1554 gnat_entity, get_identifier ("L"),
1556 Needs_Debug_Info (gnat_entity))));
1558 SET_TYPE_RM_MAX_VALUE
1560 convert (TREE_TYPE (gnu_type),
1561 elaborate_expression (Type_High_Bound (gnat_entity),
1562 gnat_entity, get_identifier ("U"),
1564 Needs_Debug_Info (gnat_entity))));
1566 /* One of the above calls might have caused us to be elaborated,
1567 so don't blow up if so. */
1568 if (present_gnu_tree (gnat_entity))
1570 maybe_present = true;
1574 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1575 = Has_Biased_Representation (gnat_entity);
1577 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1578 TYPE_STUB_DECL (gnu_type)
1579 = create_type_stub_decl (gnu_entity_name, gnu_type);
1581 /* Inherit our alias set from what we're a subtype of. Subtypes
1582 are not different types and a pointer can designate any instance
1583 within a subtype hierarchy. */
1584 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1586 /* For a packed array, make the original array type a parallel type. */
1588 && Is_Packed_Array_Type (gnat_entity)
1589 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1590 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1592 (Original_Array_Type (gnat_entity)));
1594 /* If the type we are dealing with represents a bit-packed array,
1595 we need to have the bits left justified on big-endian targets
1596 and right justified on little-endian targets. We also need to
1597 ensure that when the value is read (e.g. for comparison of two
1598 such values), we only get the good bits, since the unused bits
1599 are uninitialized. Both goals are accomplished by wrapping up
1600 the modular type in an enclosing record type. */
1601 if (Is_Packed_Array_Type (gnat_entity)
1602 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1604 tree gnu_field_type, gnu_field;
1606 /* Set the RM size before wrapping up the type. */
1607 SET_TYPE_RM_SIZE (gnu_type,
1608 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1609 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1610 gnu_field_type = gnu_type;
1612 gnu_type = make_node (RECORD_TYPE);
1613 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1615 /* Propagate the alignment of the modular type to the record.
1616 This means that bit-packed arrays have "ceil" alignment for
1617 their size, which may seem counter-intuitive but makes it
1618 possible to easily overlay them on modular types. */
1619 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1620 TYPE_PACKED (gnu_type) = 1;
1622 /* Create a stripped-down declaration of the original type, mainly
1624 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1625 debug_info_p, gnat_entity);
1627 /* Don't notify the field as "addressable", since we won't be taking
1628 it's address and it would prevent create_field_decl from making a
1630 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1631 gnu_field_type, gnu_type, 1, 0, 0, 0);
1633 /* Do not finalize it until after the parallel type is added. */
1634 finish_record_type (gnu_type, gnu_field, 0, true);
1635 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1637 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1639 /* Make the original array type a parallel type. */
1641 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1642 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1644 (Original_Array_Type (gnat_entity)));
1646 rest_of_record_type_compilation (gnu_type);
1649 /* If the type we are dealing with has got a smaller alignment than the
1650 natural one, we need to wrap it up in a record type and under-align
1651 the latter. We reuse the padding machinery for this purpose. */
1652 else if (Present (Alignment_Clause (gnat_entity))
1653 && UI_Is_In_Int_Range (Alignment (gnat_entity))
1654 && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
1655 && align < TYPE_ALIGN (gnu_type))
1657 tree gnu_field_type, gnu_field;
1659 /* Set the RM size before wrapping up the type. */
1660 SET_TYPE_RM_SIZE (gnu_type,
1661 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1662 gnu_field_type = gnu_type;
1664 gnu_type = make_node (RECORD_TYPE);
1665 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1667 TYPE_ALIGN (gnu_type) = align;
1668 TYPE_PACKED (gnu_type) = 1;
1670 /* Create a stripped-down declaration of the original type, mainly
1672 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1673 debug_info_p, gnat_entity);
1675 /* Don't notify the field as "addressable", since we won't be taking
1676 it's address and it would prevent create_field_decl from making a
1678 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1679 gnu_field_type, gnu_type, 1, 0, 0, 0);
1681 finish_record_type (gnu_type, gnu_field, 0, false);
1682 TYPE_PADDING_P (gnu_type) = 1;
1684 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1687 /* Otherwise reset the alignment lest we computed it above. */
1693 case E_Floating_Point_Type:
1694 /* If this is a VAX floating-point type, use an integer of the proper
1695 size. All the operations will be handled with ASM statements. */
1696 if (Vax_Float (gnat_entity))
1698 gnu_type = make_signed_type (esize);
1699 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1700 SET_TYPE_DIGITS_VALUE (gnu_type,
1701 UI_To_gnu (Digits_Value (gnat_entity),
1706 /* The type of the Low and High bounds can be our type if this is
1707 a type from Standard, so set them at the end of the function. */
1708 gnu_type = make_node (REAL_TYPE);
1709 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1710 layout_type (gnu_type);
1713 case E_Floating_Point_Subtype:
1714 if (Vax_Float (gnat_entity))
1716 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1722 && Present (Ancestor_Subtype (gnat_entity))
1723 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1724 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1725 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1726 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1729 gnu_type = make_node (REAL_TYPE);
1730 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1731 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1732 TYPE_GCC_MIN_VALUE (gnu_type)
1733 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1734 TYPE_GCC_MAX_VALUE (gnu_type)
1735 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1736 layout_type (gnu_type);
1738 SET_TYPE_RM_MIN_VALUE
1740 convert (TREE_TYPE (gnu_type),
1741 elaborate_expression (Type_Low_Bound (gnat_entity),
1742 gnat_entity, get_identifier ("L"),
1744 Needs_Debug_Info (gnat_entity))));
1746 SET_TYPE_RM_MAX_VALUE
1748 convert (TREE_TYPE (gnu_type),
1749 elaborate_expression (Type_High_Bound (gnat_entity),
1750 gnat_entity, get_identifier ("U"),
1752 Needs_Debug_Info (gnat_entity))));
1754 /* One of the above calls might have caused us to be elaborated,
1755 so don't blow up if so. */
1756 if (present_gnu_tree (gnat_entity))
1758 maybe_present = true;
1762 /* Inherit our alias set from what we're a subtype of, as for
1763 integer subtypes. */
1764 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1768 /* Array and String Types and Subtypes
1770 Unconstrained array types are represented by E_Array_Type and
1771 constrained array types are represented by E_Array_Subtype. There
1772 are no actual objects of an unconstrained array type; all we have
1773 are pointers to that type.
1775 The following fields are defined on array types and subtypes:
1777 Component_Type Component type of the array.
1778 Number_Dimensions Number of dimensions (an int).
1779 First_Index Type of first index. */
1784 Entity_Id gnat_index, gnat_name;
1785 const bool convention_fortran_p
1786 = (Convention (gnat_entity) == Convention_Fortran);
1787 const int ndim = Number_Dimensions (gnat_entity);
1788 tree gnu_template_fields = NULL_TREE;
1789 tree gnu_template_type = make_node (RECORD_TYPE);
1790 tree gnu_template_reference;
1791 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1792 tree gnu_fat_type = make_node (RECORD_TYPE);
1793 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
1794 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
1795 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
1798 TYPE_NAME (gnu_template_type)
1799 = create_concat_name (gnat_entity, "XUB");
1801 /* Make a node for the array. If we are not defining the array
1802 suppress expanding incomplete types. */
1803 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1807 defer_incomplete_level++;
1808 this_deferred = true;
1811 /* Build the fat pointer type. Use a "void *" object instead of
1812 a pointer to the array type since we don't have the array type
1813 yet (it will reference the fat pointer via the bounds). */
1814 tem = chainon (chainon (NULL_TREE,
1815 create_field_decl (get_identifier ("P_ARRAY"),
1818 NULL_TREE, NULL_TREE, 0)),
1819 create_field_decl (get_identifier ("P_BOUNDS"),
1822 NULL_TREE, NULL_TREE, 0));
1824 /* Make sure we can put this into a register. */
1825 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1827 /* Do not finalize this record type since the types of its fields
1828 are still incomplete at this point. */
1829 finish_record_type (gnu_fat_type, tem, 0, true);
1830 TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
1832 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1833 is the fat pointer. This will be used to access the individual
1834 fields once we build them. */
1835 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1836 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1837 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1838 gnu_template_reference
1839 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1840 TREE_READONLY (gnu_template_reference) = 1;
1842 /* Now create the GCC type for each index and add the fields for that
1843 index to the template. */
1844 for (index = (convention_fortran_p ? ndim - 1 : 0),
1845 gnat_index = First_Index (gnat_entity);
1846 0 <= index && index < ndim;
1847 index += (convention_fortran_p ? - 1 : 1),
1848 gnat_index = Next_Index (gnat_index))
1850 char field_name[16];
1851 tree gnu_index_base_type
1852 = get_unpadded_type (Base_Type (Etype (gnat_index)));
1853 tree gnu_low_field, gnu_high_field, gnu_low, gnu_high, gnu_max;
1855 /* Make the FIELD_DECLs for the low and high bounds of this
1856 type and then make extractions of these fields from the
1858 sprintf (field_name, "LB%d", index);
1859 gnu_low_field = create_field_decl (get_identifier (field_name),
1860 gnu_index_base_type,
1861 gnu_template_type, 0,
1862 NULL_TREE, NULL_TREE, 0);
1863 Sloc_to_locus (Sloc (gnat_entity),
1864 &DECL_SOURCE_LOCATION (gnu_low_field));
1866 field_name[0] = 'U';
1867 gnu_high_field = create_field_decl (get_identifier (field_name),
1868 gnu_index_base_type,
1869 gnu_template_type, 0,
1870 NULL_TREE, NULL_TREE, 0);
1871 Sloc_to_locus (Sloc (gnat_entity),
1872 &DECL_SOURCE_LOCATION (gnu_high_field));
1874 gnu_temp_fields[index] = chainon (gnu_low_field, gnu_high_field);
1876 /* We can't use build_component_ref here since the template type
1877 isn't complete yet. */
1878 gnu_low = build3 (COMPONENT_REF, gnu_index_base_type,
1879 gnu_template_reference, gnu_low_field,
1881 gnu_high = build3 (COMPONENT_REF, gnu_index_base_type,
1882 gnu_template_reference, gnu_high_field,
1884 TREE_READONLY (gnu_low) = TREE_READONLY (gnu_high) = 1;
1886 /* Compute the size of this dimension. */
1888 = build3 (COND_EXPR, gnu_index_base_type,
1889 build2 (GE_EXPR, integer_type_node, gnu_high, gnu_low),
1891 build2 (MINUS_EXPR, gnu_index_base_type,
1892 gnu_low, fold_convert (gnu_index_base_type,
1893 integer_one_node)));
1895 /* Make a range type with the new range in the Ada base type.
1896 Then make an index type with the size range in sizetype. */
1897 gnu_index_types[index]
1898 = create_index_type (convert (sizetype, gnu_low),
1899 convert (sizetype, gnu_max),
1900 create_range_type (gnu_index_base_type,
1904 /* Update the maximum size of the array in elements. */
1907 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
1909 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
1911 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
1913 = size_binop (MAX_EXPR,
1914 size_binop (PLUS_EXPR, size_one_node,
1915 size_binop (MINUS_EXPR,
1919 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1920 && TREE_OVERFLOW (gnu_this_max))
1921 gnu_max_size = NULL_TREE;
1924 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1927 TYPE_NAME (gnu_index_types[index])
1928 = create_concat_name (gnat_entity, field_name);
1931 for (index = 0; index < ndim; index++)
1933 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1935 /* Install all the fields into the template. */
1936 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1937 TYPE_READONLY (gnu_template_type) = 1;
1939 /* Now make the array of arrays and update the pointer to the array
1940 in the fat pointer. Note that it is the first field. */
1941 tem = gnat_to_gnu_component_type (gnat_entity, definition,
1944 /* If Component_Size is not already specified, annotate it with the
1945 size of the component. */
1946 if (Unknown_Component_Size (gnat_entity))
1947 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1949 /* Compute the maximum size of the array in units and bits. */
1952 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1953 TYPE_SIZE_UNIT (tem));
1954 gnu_max_size = size_binop (MULT_EXPR,
1955 convert (bitsizetype, gnu_max_size),
1959 gnu_max_size_unit = NULL_TREE;
1961 /* Now build the array type. */
1962 for (index = ndim - 1; index >= 0; index--)
1964 tem = build_array_type (tem, gnu_index_types[index]);
1965 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1966 if (array_type_has_nonaliased_component (gnat_entity, tem))
1967 TYPE_NONALIASED_COMPONENT (tem) = 1;
1970 /* If an alignment is specified, use it if valid. But ignore it
1971 for the original type of packed array types. If the alignment
1972 was requested with an explicit alignment clause, state so. */
1973 if (No (Packed_Array_Type (gnat_entity))
1974 && Known_Alignment (gnat_entity))
1977 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1979 if (Present (Alignment_Clause (gnat_entity)))
1980 TYPE_USER_ALIGN (tem) = 1;
1983 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
1984 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1986 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1987 corresponding fat pointer. */
1988 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1989 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1990 SET_TYPE_MODE (gnu_type, BLKmode);
1991 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1992 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1994 /* If the maximum size doesn't overflow, use it. */
1996 && TREE_CODE (gnu_max_size) == INTEGER_CST
1997 && !TREE_OVERFLOW (gnu_max_size)
1998 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1999 && !TREE_OVERFLOW (gnu_max_size_unit))
2001 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2003 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2004 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. If this is a packed type, tell
2012 the debugger how to interpret the underlying bits. */
2013 if (Present (Packed_Array_Type (gnat_entity)))
2014 gnat_name = Packed_Array_Type (gnat_entity);
2016 gnat_name = gnat_entity;
2017 create_type_decl (create_concat_name (gnat_name, "XUP"),
2018 gnu_fat_type, NULL, true,
2019 debug_info_p, gnat_entity);
2021 /* Create the type to be used as what a thin pointer designates: an
2022 record type for the object and its template with the field offsets
2023 shifted to have the template at a negative offset. */
2024 tem = build_unc_object_type (gnu_template_type, tem,
2025 create_concat_name (gnat_name, "XUT"));
2026 shift_unc_components_for_thin_pointers (tem);
2028 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2029 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2033 case E_String_Subtype:
2034 case E_Array_Subtype:
2036 /* This is the actual data type for array variables. Multidimensional
2037 arrays are implemented as arrays of arrays. Note that arrays which
2038 have sparse enumeration subtypes as index components create sparse
2039 arrays, which is obviously space inefficient but so much easier to
2042 Also note that the subtype never refers to the unconstrained array
2043 type, which is somewhat at variance with Ada semantics.
2045 First check to see if this is simply a renaming of the array type.
2046 If so, the result is the array type. */
2048 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2049 if (!Is_Constrained (gnat_entity))
2053 Entity_Id gnat_index, gnat_base_index;
2054 const bool convention_fortran_p
2055 = (Convention (gnat_entity) == Convention_Fortran);
2056 const int ndim = Number_Dimensions (gnat_entity);
2057 tree gnu_base_type = gnu_type;
2058 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
2059 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2060 bool need_index_type_struct = false;
2063 /* First create the GCC type for each index and find out whether
2064 special types are needed for debugging information. */
2065 for (index = (convention_fortran_p ? ndim - 1 : 0),
2066 gnat_index = First_Index (gnat_entity),
2068 = First_Index (Implementation_Base_Type (gnat_entity));
2069 0 <= index && index < ndim;
2070 index += (convention_fortran_p ? - 1 : 1),
2071 gnat_index = Next_Index (gnat_index),
2072 gnat_base_index = Next_Index (gnat_base_index))
2074 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2076 = compare_tree_int (TYPE_RM_SIZE (gnu_index_type),
2077 TYPE_PRECISION (sizetype));
2078 const bool subrange_p = (prec_comp < 0)
2080 && TYPE_UNSIGNED (gnu_index_type)
2081 == TYPE_UNSIGNED (sizetype));
2082 const bool wider_p = (prec_comp > 0);
2083 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2084 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2085 tree gnu_min = convert (sizetype, gnu_orig_min);
2086 tree gnu_max = convert (sizetype, gnu_orig_max);
2087 tree gnu_base_index_type
2088 = get_unpadded_type (Etype (gnat_base_index));
2089 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2090 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2091 tree gnu_high, gnu_low;
2093 /* See if the base array type is already flat. If it is, we
2094 are probably compiling an ACATS test but it will cause the
2095 code below to malfunction if we don't handle it specially. */
2096 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2097 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2098 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2100 gnu_min = size_one_node;
2101 gnu_max = size_zero_node;
2105 /* Similarly, if one of the values overflows in sizetype and the
2106 range is null, use 1..0 for the sizetype bounds. */
2107 else if (!subrange_p
2108 && TREE_CODE (gnu_min) == INTEGER_CST
2109 && TREE_CODE (gnu_max) == INTEGER_CST
2110 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2111 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2113 gnu_min = size_one_node;
2114 gnu_max = size_zero_node;
2118 /* If the minimum and maximum values both overflow in sizetype,
2119 but the difference in the original type does not overflow in
2120 sizetype, ignore the overflow indication. */
2121 else if (!subrange_p
2122 && TREE_CODE (gnu_min) == INTEGER_CST
2123 && TREE_CODE (gnu_max) == INTEGER_CST
2124 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2127 fold_build2 (MINUS_EXPR, gnu_index_type,
2131 TREE_OVERFLOW (gnu_min) = 0;
2132 TREE_OVERFLOW (gnu_max) = 0;
2136 /* Compute the size of this dimension in the general case. We
2137 need to provide GCC with an upper bound to use but have to
2138 deal with the "superflat" case. There are three ways to do
2139 this. If we can prove that the array can never be superflat,
2140 we can just use the high bound of the index type. */
2141 else if (Nkind (gnat_index) == N_Range
2142 && cannot_be_superflat_p (gnat_index))
2145 /* Otherwise, if we can prove that the low bound minus one and
2146 the high bound cannot overflow, we can just use the expression
2147 MAX (hb, lb - 1). Similarly, if we can prove that the high
2148 bound plus one and the low bound cannot overflow, we can use
2149 the high bound as-is and MIN (hb + 1, lb) for the low bound.
2150 Otherwise, we have to fall back to the most general expression
2151 (hb >= lb) ? hb : lb - 1. Note that the comparison must be
2152 done in the original index type, to avoid any overflow during
2156 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2157 gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node);
2159 /* If gnu_high is a constant that has overflowed, the low
2160 bound is the smallest integer so cannot be the maximum.
2161 If gnu_low is a constant that has overflowed, the high
2162 bound is the highest integer so cannot be the minimum. */
2163 if ((TREE_CODE (gnu_high) == INTEGER_CST
2164 && TREE_OVERFLOW (gnu_high))
2165 || (TREE_CODE (gnu_low) == INTEGER_CST
2166 && TREE_OVERFLOW (gnu_low)))
2169 /* If the index type is a subrange and gnu_high a constant
2170 that hasn't overflowed, we can use the maximum. */
2171 else if (subrange_p && TREE_CODE (gnu_high) == INTEGER_CST)
2172 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2174 /* If the index type is a subrange and gnu_low a constant
2175 that hasn't overflowed, we can use the minimum. */
2176 else if (subrange_p && TREE_CODE (gnu_low) == INTEGER_CST)
2179 gnu_min = size_binop (MIN_EXPR, gnu_min, gnu_low);
2184 = build_cond_expr (sizetype,
2185 build_binary_op (GE_EXPR,
2192 gnu_index_types[index]
2193 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2196 /* Update the maximum size of the array in elements. Here we
2197 see if any constraint on the index type of the base type
2198 can be used in the case of self-referential bound on the
2199 index type of the subtype. We look for a non-"infinite"
2200 and non-self-referential bound from any type involved and
2201 handle each bound separately. */
2204 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2205 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2206 tree gnu_base_index_base_type
2207 = get_base_type (gnu_base_index_type);
2208 tree gnu_base_base_min
2209 = convert (sizetype,
2210 TYPE_MIN_VALUE (gnu_base_index_base_type));
2211 tree gnu_base_base_max
2212 = convert (sizetype,
2213 TYPE_MAX_VALUE (gnu_base_index_base_type));
2215 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2216 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2217 && !TREE_OVERFLOW (gnu_base_min)))
2218 gnu_base_min = gnu_min;
2220 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2221 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2222 && !TREE_OVERFLOW (gnu_base_max)))
2223 gnu_base_max = gnu_max;
2225 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2226 && TREE_OVERFLOW (gnu_base_min))
2227 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2228 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2229 && TREE_OVERFLOW (gnu_base_max))
2230 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2231 gnu_max_size = NULL_TREE;
2235 = size_binop (MAX_EXPR,
2236 size_binop (PLUS_EXPR, size_one_node,
2237 size_binop (MINUS_EXPR,
2242 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2243 && TREE_OVERFLOW (gnu_this_max))
2244 gnu_max_size = NULL_TREE;
2247 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2251 /* We need special types for debugging information to point to
2252 the index types if they have variable bounds, are not integer
2253 types, are biased or are wider than sizetype. */
2254 if (!integer_onep (gnu_orig_min)
2255 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2256 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2257 || (TREE_TYPE (gnu_index_type)
2258 && TREE_CODE (TREE_TYPE (gnu_index_type))
2260 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2262 need_index_type_struct = true;
2265 /* Then flatten: create the array of arrays. For an array type
2266 used to implement a packed array, get the component type from
2267 the original array type since the representation clauses that
2268 can affect it are on the latter. */
2269 if (Is_Packed_Array_Type (gnat_entity)
2270 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2272 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2273 for (index = ndim - 1; index >= 0; index--)
2274 gnu_type = TREE_TYPE (gnu_type);
2276 /* One of the above calls might have caused us to be elaborated,
2277 so don't blow up if so. */
2278 if (present_gnu_tree (gnat_entity))
2280 maybe_present = true;
2286 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2289 /* One of the above calls might have caused us to be elaborated,
2290 so don't blow up if so. */
2291 if (present_gnu_tree (gnat_entity))
2293 maybe_present = true;
2298 /* Compute the maximum size of the array in units and bits. */
2301 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2302 TYPE_SIZE_UNIT (gnu_type));
2303 gnu_max_size = size_binop (MULT_EXPR,
2304 convert (bitsizetype, gnu_max_size),
2305 TYPE_SIZE (gnu_type));
2308 gnu_max_size_unit = NULL_TREE;
2310 /* Now build the array type. */
2311 for (index = ndim - 1; index >= 0; index --)
2313 gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
2314 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2315 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2316 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2319 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2320 TYPE_STUB_DECL (gnu_type)
2321 = create_type_stub_decl (gnu_entity_name, gnu_type);
2323 /* If we are at file level and this is a multi-dimensional array,
2324 we need to make a variable corresponding to the stride of the
2325 inner dimensions. */
2326 if (global_bindings_p () && ndim > 1)
2328 tree gnu_str_name = get_identifier ("ST");
2331 for (gnu_arr_type = TREE_TYPE (gnu_type);
2332 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2333 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2334 gnu_str_name = concat_name (gnu_str_name, "ST"))
2336 tree eltype = TREE_TYPE (gnu_arr_type);
2338 TYPE_SIZE (gnu_arr_type)
2339 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2340 gnat_entity, gnu_str_name,
2343 /* ??? For now, store the size as a multiple of the
2344 alignment of the element type in bytes so that we
2345 can see the alignment from the tree. */
2346 TYPE_SIZE_UNIT (gnu_arr_type)
2348 (MULT_EXPR, sizetype,
2349 elaborate_expression_1
2350 (build_binary_op (EXACT_DIV_EXPR, sizetype,
2351 TYPE_SIZE_UNIT (gnu_arr_type),
2352 size_int (TYPE_ALIGN (eltype)
2354 gnat_entity, concat_name (gnu_str_name, "A_U"),
2356 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2358 /* ??? create_type_decl is not invoked on the inner types so
2359 the MULT_EXPR node built above will never be marked. */
2360 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2364 /* If we need to write out a record type giving the names of the
2365 bounds for debugging purposes, do it now and make the record
2366 type a parallel type. This is not needed for a packed array
2367 since the bounds are conveyed by the original array type. */
2368 if (need_index_type_struct
2370 && !Is_Packed_Array_Type (gnat_entity))
2372 tree gnu_bound_rec = make_node (RECORD_TYPE);
2373 tree gnu_field_list = NULL_TREE;
2376 TYPE_NAME (gnu_bound_rec)
2377 = create_concat_name (gnat_entity, "XA");
2379 for (index = ndim - 1; index >= 0; index--)
2381 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2382 tree gnu_index_name = TYPE_NAME (gnu_index);
2384 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2385 gnu_index_name = DECL_NAME (gnu_index_name);
2387 /* Make sure to reference the types themselves, and not just
2388 their names, as the debugger may fall back on them. */
2389 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2391 0, NULL_TREE, NULL_TREE, 0);
2392 TREE_CHAIN (gnu_field) = gnu_field_list;
2393 gnu_field_list = gnu_field;
2396 finish_record_type (gnu_bound_rec, gnu_field_list, 0, false);
2397 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2400 /* Otherwise, for a packed array, make the original array type a
2402 else if (debug_info_p
2403 && Is_Packed_Array_Type (gnat_entity)
2404 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2405 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2407 (Original_Array_Type (gnat_entity)));
2409 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2410 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2411 = (Is_Packed_Array_Type (gnat_entity)
2412 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2414 /* If the size is self-referential and the maximum size doesn't
2415 overflow, use it. */
2416 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2418 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2419 && TREE_OVERFLOW (gnu_max_size))
2420 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2421 && TREE_OVERFLOW (gnu_max_size_unit)))
2423 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2424 TYPE_SIZE (gnu_type));
2425 TYPE_SIZE_UNIT (gnu_type)
2426 = size_binop (MIN_EXPR, gnu_max_size_unit,
2427 TYPE_SIZE_UNIT (gnu_type));
2430 /* Set our alias set to that of our base type. This gives all
2431 array subtypes the same alias set. */
2432 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2434 /* If this is a packed type, make this type the same as the packed
2435 array type, but do some adjusting in the type first. */
2436 if (Present (Packed_Array_Type (gnat_entity)))
2438 Entity_Id gnat_index;
2441 /* First finish the type we had been making so that we output
2442 debugging information for it. */
2443 if (Treat_As_Volatile (gnat_entity))
2445 = build_qualified_type (gnu_type,
2446 TYPE_QUALS (gnu_type)
2447 | TYPE_QUAL_VOLATILE);
2449 /* Make it artificial only if the base type was artificial too.
2450 That's sort of "morally" true and will make it possible for
2451 the debugger to look it up by name in DWARF, which is needed
2452 in order to decode the packed array type. */
2454 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2455 !Comes_From_Source (Etype (gnat_entity))
2456 && !Comes_From_Source (gnat_entity),
2457 debug_info_p, gnat_entity);
2459 /* Save it as our equivalent in case the call below elaborates
2461 save_gnu_tree (gnat_entity, gnu_decl, false);
2463 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2465 this_made_decl = true;
2466 gnu_type = TREE_TYPE (gnu_decl);
2467 save_gnu_tree (gnat_entity, NULL_TREE, false);
2469 gnu_inner = gnu_type;
2470 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2471 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2472 || TYPE_PADDING_P (gnu_inner)))
2473 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2475 /* We need to attach the index type to the type we just made so
2476 that the actual bounds can later be put into a template. */
2477 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2478 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2479 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2480 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2482 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2484 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2485 TYPE_MODULUS for modular types so we make an extra
2486 subtype if necessary. */
2487 if (TYPE_MODULAR_P (gnu_inner))
2490 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2491 TREE_TYPE (gnu_subtype) = gnu_inner;
2492 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2493 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2494 TYPE_MIN_VALUE (gnu_inner));
2495 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2496 TYPE_MAX_VALUE (gnu_inner));
2497 gnu_inner = gnu_subtype;
2500 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2502 #ifdef ENABLE_CHECKING
2503 /* Check for other cases of overloading. */
2504 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2508 for (gnat_index = First_Index (gnat_entity);
2509 Present (gnat_index);
2510 gnat_index = Next_Index (gnat_index))
2511 SET_TYPE_ACTUAL_BOUNDS
2513 tree_cons (NULL_TREE,
2514 get_unpadded_type (Etype (gnat_index)),
2515 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2517 if (Convention (gnat_entity) != Convention_Fortran)
2518 SET_TYPE_ACTUAL_BOUNDS
2519 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2521 if (TREE_CODE (gnu_type) == RECORD_TYPE
2522 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2523 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2528 /* Abort if packed array with no Packed_Array_Type field set. */
2529 gcc_assert (!Is_Packed (gnat_entity));
2533 case E_String_Literal_Subtype:
2534 /* Create the type for a string literal. */
2536 Entity_Id gnat_full_type
2537 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2538 && Present (Full_View (Etype (gnat_entity)))
2539 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2540 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2541 tree gnu_string_array_type
2542 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2543 tree gnu_string_index_type
2544 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2545 (TYPE_DOMAIN (gnu_string_array_type))));
2546 tree gnu_lower_bound
2547 = convert (gnu_string_index_type,
2548 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2549 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2550 tree gnu_length = ssize_int (length - 1);
2551 tree gnu_upper_bound
2552 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2554 convert (gnu_string_index_type, gnu_length));
2556 = create_index_type (convert (sizetype, gnu_lower_bound),
2557 convert (sizetype, gnu_upper_bound),
2558 create_range_type (gnu_string_index_type,
2564 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2566 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2567 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2568 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2572 /* Record Types and Subtypes
2574 The following fields are defined on record types:
2576 Has_Discriminants True if the record has discriminants
2577 First_Discriminant Points to head of list of discriminants
2578 First_Entity Points to head of list of fields
2579 Is_Tagged_Type True if the record is tagged
2581 Implementation of Ada records and discriminated records:
2583 A record type definition is transformed into the equivalent of a C
2584 struct definition. The fields that are the discriminants which are
2585 found in the Full_Type_Declaration node and the elements of the
2586 Component_List found in the Record_Type_Definition node. The
2587 Component_List can be a recursive structure since each Variant of
2588 the Variant_Part of the Component_List has a Component_List.
2590 Processing of a record type definition comprises starting the list of
2591 field declarations here from the discriminants and the calling the
2592 function components_to_record to add the rest of the fields from the
2593 component list and return the gnu type node. The function
2594 components_to_record will call itself recursively as it traverses
2598 if (Has_Complex_Representation (gnat_entity))
2601 = build_complex_type
2603 (Etype (Defining_Entity
2604 (First (Component_Items
2607 (Declaration_Node (gnat_entity)))))))));
2613 Node_Id full_definition = Declaration_Node (gnat_entity);
2614 Node_Id record_definition = Type_Definition (full_definition);
2615 Entity_Id gnat_field;
2616 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2617 /* Set PACKED in keeping with gnat_to_gnu_field. */
2619 = Is_Packed (gnat_entity)
2621 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2623 : (Known_Alignment (gnat_entity)
2624 || (Strict_Alignment (gnat_entity)
2625 && Known_Static_Esize (gnat_entity)))
2628 bool has_discr = Has_Discriminants (gnat_entity);
2629 bool has_rep = Has_Specified_Layout (gnat_entity);
2630 bool all_rep = has_rep;
2632 = (Is_Tagged_Type (gnat_entity)
2633 && Nkind (record_definition) == N_Derived_Type_Definition);
2634 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2636 /* See if all fields have a rep clause. Stop when we find one
2639 for (gnat_field = First_Entity (gnat_entity);
2640 Present (gnat_field);
2641 gnat_field = Next_Entity (gnat_field))
2642 if ((Ekind (gnat_field) == E_Component
2643 || Ekind (gnat_field) == E_Discriminant)
2644 && 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_name;
2666 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2670 defer_incomplete_level++;
2671 this_deferred = true;
2674 /* If both a size and rep clause was specified, put the size in
2675 the record type now so that it can get the proper mode. */
2676 if (has_rep && Known_Esize (gnat_entity))
2677 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2679 /* Always set the alignment here so that it can be used to
2680 set the mode, if it is making the alignment stricter. If
2681 it is invalid, it will be checked again below. If this is to
2682 be Atomic, choose a default alignment of a word unless we know
2683 the size and it's smaller. */
2684 if (Known_Alignment (gnat_entity))
2685 TYPE_ALIGN (gnu_type)
2686 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2687 else if (Is_Atomic (gnat_entity))
2688 TYPE_ALIGN (gnu_type)
2689 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2690 /* If a type needs strict alignment, the minimum size will be the
2691 type size instead of the RM size (see validate_size). Cap the
2692 alignment, lest it causes this type size to become too large. */
2693 else if (Strict_Alignment (gnat_entity)
2694 && Known_Static_Esize (gnat_entity))
2696 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2697 unsigned int raw_align = raw_size & -raw_size;
2698 if (raw_align < BIGGEST_ALIGNMENT)
2699 TYPE_ALIGN (gnu_type) = raw_align;
2702 TYPE_ALIGN (gnu_type) = 0;
2704 /* If we have a Parent_Subtype, make a field for the parent. If
2705 this record has rep clauses, force the position to zero. */
2706 if (Present (Parent_Subtype (gnat_entity)))
2708 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2711 /* A major complexity here is that the parent subtype will
2712 reference our discriminants in its Discriminant_Constraint
2713 list. But those must reference the parent component of this
2714 record which is of the parent subtype we have not built yet!
2715 To break the circle we first build a dummy COMPONENT_REF which
2716 represents the "get to the parent" operation and initialize
2717 each of those discriminants to a COMPONENT_REF of the above
2718 dummy parent referencing the corresponding discriminant of the
2719 base type of the parent subtype. */
2720 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2721 build0 (PLACEHOLDER_EXPR, gnu_type),
2722 build_decl (input_location,
2723 FIELD_DECL, NULL_TREE,
2728 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2729 Present (gnat_field);
2730 gnat_field = Next_Stored_Discriminant (gnat_field))
2731 if (Present (Corresponding_Discriminant (gnat_field)))
2734 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2738 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2739 gnu_get_parent, gnu_field, NULL_TREE),
2743 /* Then we build the parent subtype. If it has discriminants but
2744 the type itself has unknown discriminants, this means that it
2745 doesn't contain information about how the discriminants are
2746 derived from those of the ancestor type, so it cannot be used
2747 directly. Instead it is built by cloning the parent subtype
2748 of the underlying record view of the type, for which the above
2749 derivation of discriminants has been made explicit. */
2750 if (Has_Discriminants (gnat_parent)
2751 && Has_Unknown_Discriminants (gnat_entity))
2753 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2755 /* If we are defining the type, the underlying record
2756 view must already have been elaborated at this point.
2757 Otherwise do it now as its parent subtype cannot be
2758 technically elaborated on its own. */
2760 gcc_assert (present_gnu_tree (gnat_uview));
2762 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2764 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2766 /* Substitute the "get to the parent" of the type for that
2767 of its underlying record view in the cloned type. */
2768 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2769 Present (gnat_field);
2770 gnat_field = Next_Stored_Discriminant (gnat_field))
2771 if (Present (Corresponding_Discriminant (gnat_field)))
2773 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2775 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2776 gnu_get_parent, gnu_field, NULL_TREE);
2778 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2782 gnu_parent = gnat_to_gnu_type (gnat_parent);
2784 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2785 initially built. The discriminants must reference the fields
2786 of the parent subtype and not those of its base type for the
2787 placeholder machinery to properly work. */
2790 /* The actual parent subtype is the full view. */
2791 if (IN (Ekind (gnat_parent), Private_Kind))
2793 if (Present (Full_View (gnat_parent)))
2794 gnat_parent = Full_View (gnat_parent);
2796 gnat_parent = Underlying_Full_View (gnat_parent);
2799 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2800 Present (gnat_field);
2801 gnat_field = Next_Stored_Discriminant (gnat_field))
2802 if (Present (Corresponding_Discriminant (gnat_field)))
2804 Entity_Id field = Empty;
2805 for (field = First_Stored_Discriminant (gnat_parent);
2807 field = Next_Stored_Discriminant (field))
2808 if (same_discriminant_p (gnat_field, field))
2810 gcc_assert (Present (field));
2811 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2812 = gnat_to_gnu_field_decl (field);
2816 /* The "get to the parent" COMPONENT_REF must be given its
2818 TREE_TYPE (gnu_get_parent) = gnu_parent;
2820 /* ...and reference the _Parent field of this record. */
2822 = create_field_decl (get_identifier
2823 (Get_Name_String (Name_uParent)),
2824 gnu_parent, gnu_type, 0,
2826 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2828 ? bitsize_zero_node : NULL_TREE, 1);
2829 DECL_INTERNAL_P (gnu_field) = 1;
2830 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2831 TYPE_FIELDS (gnu_type) = gnu_field;
2834 /* Make the fields for the discriminants and put them into the record
2835 unless it's an Unchecked_Union. */
2837 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2838 Present (gnat_field);
2839 gnat_field = Next_Stored_Discriminant (gnat_field))
2841 /* If this is a record extension and this discriminant is the
2842 renaming of another discriminant, we've handled it above. */
2843 if (Present (Parent_Subtype (gnat_entity))
2844 && Present (Corresponding_Discriminant (gnat_field)))
2848 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
2851 /* Make an expression using a PLACEHOLDER_EXPR from the
2852 FIELD_DECL node just created and link that with the
2853 corresponding GNAT defining identifier. */
2854 save_gnu_tree (gnat_field,
2855 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2856 build0 (PLACEHOLDER_EXPR, gnu_type),
2857 gnu_field, NULL_TREE),
2860 if (!is_unchecked_union)
2862 TREE_CHAIN (gnu_field) = gnu_field_list;
2863 gnu_field_list = gnu_field;
2867 /* Add the fields into the record type and finish it up. */
2868 components_to_record (gnu_type, Component_List (record_definition),
2869 gnu_field_list, packed, definition, NULL,
2870 false, all_rep, false, is_unchecked_union,
2873 /* If it is a tagged record force the type to BLKmode to insure that
2874 these objects will always be put in memory. Likewise for limited
2876 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2877 SET_TYPE_MODE (gnu_type, BLKmode);
2879 /* We used to remove the associations of the discriminants and _Parent
2880 for validity checking but we may need them if there's a Freeze_Node
2881 for a subtype used in this record. */
2882 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2884 /* Fill in locations of fields. */
2885 annotate_rep (gnat_entity, gnu_type);
2887 /* If there are any entities in the chain corresponding to components
2888 that we did not elaborate, ensure we elaborate their types if they
2890 for (gnat_temp = First_Entity (gnat_entity);
2891 Present (gnat_temp);
2892 gnat_temp = Next_Entity (gnat_temp))
2893 if ((Ekind (gnat_temp) == E_Component
2894 || Ekind (gnat_temp) == E_Discriminant)
2895 && Is_Itype (Etype (gnat_temp))
2896 && !present_gnu_tree (gnat_temp))
2897 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2901 case E_Class_Wide_Subtype:
2902 /* If an equivalent type is present, that is what we should use.
2903 Otherwise, fall through to handle this like a record subtype
2904 since it may have constraints. */
2905 if (gnat_equiv_type != gnat_entity)
2907 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2908 maybe_present = true;
2912 /* ... fall through ... */
2914 case E_Record_Subtype:
2915 /* If Cloned_Subtype is Present it means this record subtype has
2916 identical layout to that type or subtype and we should use
2917 that GCC type for this one. The front end guarantees that
2918 the component list is shared. */
2919 if (Present (Cloned_Subtype (gnat_entity)))
2921 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2923 maybe_present = true;
2927 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2928 changing the type, make a new type with each field having the type of
2929 the field in the new subtype but the position computed by transforming
2930 every discriminant reference according to the constraints. We don't
2931 see any difference between private and non-private type here since
2932 derivations from types should have been deferred until the completion
2933 of the private type. */
2936 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2941 defer_incomplete_level++;
2942 this_deferred = true;
2945 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2947 if (present_gnu_tree (gnat_entity))
2949 maybe_present = true;
2953 /* When the subtype has discriminants and these discriminants affect
2954 the initial shape it has inherited, factor them in. But for an
2955 Unchecked_Union (it must be an Itype), just return the type.
2956 We can't just test Is_Constrained because private subtypes without
2957 discriminants of types with discriminants with default expressions
2958 are Is_Constrained but aren't constrained! */
2959 if (IN (Ekind (gnat_base_type), Record_Kind)
2960 && !Is_Unchecked_Union (gnat_base_type)
2961 && !Is_For_Access_Subtype (gnat_entity)
2962 && Is_Constrained (gnat_entity)
2963 && Has_Discriminants (gnat_entity)
2964 && Present (Discriminant_Constraint (gnat_entity))
2965 && Stored_Constraint (gnat_entity) != No_Elist)
2968 = build_subst_list (gnat_entity, gnat_base_type, definition);
2969 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
2970 tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
2971 bool selected_variant = false;
2972 Entity_Id gnat_field;
2974 gnu_type = make_node (RECORD_TYPE);
2975 TYPE_NAME (gnu_type) = gnu_entity_name;
2977 /* Set the size, alignment and alias set of the new type to
2978 match that of the old one, doing required substitutions. */
2979 copy_and_substitute_in_size (gnu_type, gnu_base_type,
2982 if (TYPE_IS_PADDING_P (gnu_base_type))
2983 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2985 gnu_unpad_base_type = gnu_base_type;
2987 /* Look for a REP part in the base type. */
2988 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
2990 /* Look for a variant part in the base type. */
2991 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
2993 /* If there is a variant part, we must compute whether the
2994 constraints statically select a particular variant. If
2995 so, we simply drop the qualified union and flatten the
2996 list of fields. Otherwise we'll build a new qualified
2997 union for the variants that are still relevant. */
2998 if (gnu_variant_part)
3001 = build_variant_list (TREE_TYPE (gnu_variant_part),
3002 gnu_subst_list, NULL_TREE);
3004 /* If all the qualifiers are unconditionally true, the
3005 innermost variant is statically selected. */
3006 selected_variant = true;
3007 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3008 if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
3010 selected_variant = false;
3014 /* Otherwise, create the new variants. */
3015 if (!selected_variant)
3016 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3018 tree old_variant = TREE_PURPOSE (t);
3019 tree new_variant = make_node (RECORD_TYPE);
3020 TYPE_NAME (new_variant)
3021 = DECL_NAME (TYPE_NAME (old_variant));
3022 copy_and_substitute_in_size (new_variant, old_variant,
3024 TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
3029 gnu_variant_list = NULL_TREE;
3030 selected_variant = false;
3034 = build_position_list (gnu_unpad_base_type,
3035 gnu_variant_list && !selected_variant,
3036 size_zero_node, bitsize_zero_node,
3037 BIGGEST_ALIGNMENT, NULL_TREE);
3039 for (gnat_field = First_Entity (gnat_entity);
3040 Present (gnat_field);
3041 gnat_field = Next_Entity (gnat_field))
3042 if ((Ekind (gnat_field) == E_Component
3043 || Ekind (gnat_field) == E_Discriminant)
3044 && !(Present (Corresponding_Discriminant (gnat_field))
3045 && Is_Tagged_Type (gnat_base_type))
3046 && Underlying_Type (Scope (Original_Record_Component
3050 Name_Id gnat_name = Chars (gnat_field);
3051 Entity_Id gnat_old_field
3052 = Original_Record_Component (gnat_field);
3054 = gnat_to_gnu_field_decl (gnat_old_field);
3055 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3056 tree gnu_field, gnu_field_type, gnu_size;
3057 tree gnu_cont_type, gnu_last = NULL_TREE;
3059 /* If the type is the same, retrieve the GCC type from the
3060 old field to take into account possible adjustments. */
3061 if (Etype (gnat_field) == Etype (gnat_old_field))
3062 gnu_field_type = TREE_TYPE (gnu_old_field);
3064 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3066 /* If there was a component clause, the field types must be
3067 the same for the type and subtype, so copy the data from
3068 the old field to avoid recomputation here. Also if the
3069 field is justified modular and the optimization in
3070 gnat_to_gnu_field was applied. */
3071 if (Present (Component_Clause (gnat_old_field))
3072 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3073 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3074 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3075 == TREE_TYPE (gnu_old_field)))
3077 gnu_size = DECL_SIZE (gnu_old_field);
3078 gnu_field_type = TREE_TYPE (gnu_old_field);
3081 /* If the old field was packed and of constant size, we
3082 have to get the old size here, as it might differ from
3083 what the Etype conveys and the latter might overlap
3084 onto the following field. Try to arrange the type for
3085 possible better packing along the way. */
3086 else if (DECL_PACKED (gnu_old_field)
3087 && TREE_CODE (DECL_SIZE (gnu_old_field))
3090 gnu_size = DECL_SIZE (gnu_old_field);
3091 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3092 && !TYPE_FAT_POINTER_P (gnu_field_type)
3093 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3095 = make_packable_type (gnu_field_type, true);
3099 gnu_size = TYPE_SIZE (gnu_field_type);
3101 /* If the context of the old field is the base type or its
3102 REP part (if any), put the field directly in the new
3103 type; otherwise look up the context in the variant list
3104 and put the field either in the new type if there is a
3105 selected variant or in one of the new variants. */
3106 if (gnu_context == gnu_unpad_base_type
3108 && gnu_context == TREE_TYPE (gnu_rep_part)))
3109 gnu_cont_type = gnu_type;
3112 t = purpose_member (gnu_context, gnu_variant_list);
3115 if (selected_variant)
3116 gnu_cont_type = gnu_type;
3118 gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
3121 /* The front-end may pass us "ghost" components if
3122 it fails to recognize that a constrained subtype
3123 is statically constrained. Discard them. */
3127 /* Now create the new field modeled on the old one. */
3129 = create_field_decl_from (gnu_old_field, gnu_field_type,
3130 gnu_cont_type, gnu_size,
3131 gnu_pos_list, gnu_subst_list);
3133 /* Put it in one of the new variants directly. */
3134 if (gnu_cont_type != gnu_type)
3136 TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3137 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3140 /* To match the layout crafted in components_to_record,
3141 if this is the _Tag or _Parent field, put it before
3142 any other fields. */
3143 else if (gnat_name == Name_uTag
3144 || gnat_name == Name_uParent)
3145 gnu_field_list = chainon (gnu_field_list, gnu_field);
3147 /* Similarly, if this is the _Controller field, put
3148 it before the other fields except for the _Tag or
3150 else if (gnat_name == Name_uController && gnu_last)
3152 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
3153 TREE_CHAIN (gnu_last) = gnu_field;
3156 /* Otherwise, if this is a regular field, put it after
3157 the other fields. */
3160 TREE_CHAIN (gnu_field) = gnu_field_list;
3161 gnu_field_list = gnu_field;
3163 gnu_last = gnu_field;
3166 save_gnu_tree (gnat_field, gnu_field, false);
3169 /* If there is a variant list and no selected variant, we need
3170 to create the nest of variant parts from the old nest. */
3171 if (gnu_variant_list && !selected_variant)
3173 tree new_variant_part
3174 = create_variant_part_from (gnu_variant_part,
3175 gnu_variant_list, gnu_type,
3176 gnu_pos_list, gnu_subst_list);
3177 TREE_CHAIN (new_variant_part) = gnu_field_list;
3178 gnu_field_list = new_variant_part;
3181 /* Now go through the entities again looking for Itypes that
3182 we have not elaborated but should (e.g., Etypes of fields
3183 that have Original_Components). */
3184 for (gnat_field = First_Entity (gnat_entity);
3185 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3186 if ((Ekind (gnat_field) == E_Discriminant
3187 || Ekind (gnat_field) == E_Component)
3188 && !present_gnu_tree (Etype (gnat_field)))
3189 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3191 /* Do not finalize it since we're going to modify it below. */
3192 gnu_field_list = nreverse (gnu_field_list);
3193 finish_record_type (gnu_type, gnu_field_list, 2, true);
3195 /* See the E_Record_Type case for the rationale. */
3196 if (Is_Tagged_Type (gnat_entity)
3197 || Is_Limited_Record (gnat_entity))
3198 SET_TYPE_MODE (gnu_type, BLKmode);
3200 compute_record_mode (gnu_type);
3202 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3204 /* Fill in locations of fields. */
3205 annotate_rep (gnat_entity, gnu_type);
3207 /* If debugging information is being written for the type, write
3208 a record that shows what we are a subtype of and also make a
3209 variable that indicates our size, if still variable. */
3212 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3213 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3214 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3216 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3217 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3219 TYPE_NAME (gnu_subtype_marker)
3220 = create_concat_name (gnat_entity, "XVS");
3221 finish_record_type (gnu_subtype_marker,
3222 create_field_decl (gnu_unpad_base_name,
3223 build_reference_type
3224 (gnu_unpad_base_type),
3230 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3231 gnu_subtype_marker);
3234 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3235 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3236 create_var_decl (create_concat_name (gnat_entity, "XVZ"),
3237 NULL_TREE, sizetype, gnu_size_unit, false,
3238 false, false, false, NULL, gnat_entity);
3241 /* Now we can finalize it. */
3242 rest_of_record_type_compilation (gnu_type);
3245 /* Otherwise, go down all the components in the new type and make
3246 them equivalent to those in the base type. */
3249 gnu_type = gnu_base_type;
3251 for (gnat_temp = First_Entity (gnat_entity);
3252 Present (gnat_temp);
3253 gnat_temp = Next_Entity (gnat_temp))
3254 if ((Ekind (gnat_temp) == E_Discriminant
3255 && !Is_Unchecked_Union (gnat_base_type))
3256 || Ekind (gnat_temp) == E_Component)
3257 save_gnu_tree (gnat_temp,
3258 gnat_to_gnu_field_decl
3259 (Original_Record_Component (gnat_temp)),
3265 case E_Access_Subprogram_Type:
3266 /* Use the special descriptor type for dispatch tables if needed,
3267 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3268 Note that we are only required to do so for static tables in
3269 order to be compatible with the C++ ABI, but Ada 2005 allows
3270 to extend library level tagged types at the local level so
3271 we do it in the non-static case as well. */
3272 if (TARGET_VTABLE_USES_DESCRIPTORS
3273 && Is_Dispatch_Table_Entity (gnat_entity))
3275 gnu_type = fdesc_type_node;
3276 gnu_size = TYPE_SIZE (gnu_type);
3280 /* ... fall through ... */
3282 case E_Anonymous_Access_Subprogram_Type:
3283 /* If we are not defining this entity, and we have incomplete
3284 entities being processed above us, make a dummy type and
3285 fill it in later. */
3286 if (!definition && defer_incomplete_level != 0)
3288 struct incomplete *p
3289 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3292 = build_pointer_type
3293 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3294 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3295 !Comes_From_Source (gnat_entity),
3296 debug_info_p, gnat_entity);
3297 this_made_decl = true;
3298 gnu_type = TREE_TYPE (gnu_decl);
3299 save_gnu_tree (gnat_entity, gnu_decl, false);
3302 p->old_type = TREE_TYPE (gnu_type);
3303 p->full_type = Directly_Designated_Type (gnat_entity);
3304 p->next = defer_incomplete_list;
3305 defer_incomplete_list = p;
3309 /* ... fall through ... */
3311 case E_Allocator_Type:
3313 case E_Access_Attribute_Type:
3314 case E_Anonymous_Access_Type:
3315 case E_General_Access_Type:
3317 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3318 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3319 bool is_from_limited_with
3320 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3321 && From_With_Type (gnat_desig_equiv));
3323 /* Get the "full view" of this entity. If this is an incomplete
3324 entity from a limited with, treat its non-limited view as the full
3325 view. Otherwise, if this is an incomplete or private type, use the
3326 full view. In the former case, we might point to a private type,
3327 in which case, we need its full view. Also, we want to look at the
3328 actual type used for the representation, so this takes a total of
3330 Entity_Id gnat_desig_full_direct_first
3331 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3332 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3333 ? Full_View (gnat_desig_equiv) : Empty));
3334 Entity_Id gnat_desig_full_direct
3335 = ((is_from_limited_with
3336 && Present (gnat_desig_full_direct_first)
3337 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3338 ? Full_View (gnat_desig_full_direct_first)
3339 : gnat_desig_full_direct_first);
3340 Entity_Id gnat_desig_full
3341 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3343 /* This the type actually used to represent the designated type,
3344 either gnat_desig_full or gnat_desig_equiv. */
3345 Entity_Id gnat_desig_rep;
3347 /* True if this is a pointer to an unconstrained array. */
3348 bool is_unconstrained_array;
3350 /* We want to know if we'll be seeing the freeze node for any
3351 incomplete type we may be pointing to. */
3353 = (Present (gnat_desig_full)
3354 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3355 : In_Extended_Main_Code_Unit (gnat_desig_type));
3357 /* True if we make a dummy type here. */
3358 bool got_fat_p = false;
3359 /* True if the dummy is a fat pointer. */
3360 bool made_dummy = false;
3361 tree gnu_desig_type = NULL_TREE;
3362 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3364 if (!targetm.valid_pointer_mode (p_mode))
3367 /* If either the designated type or its full view is an unconstrained
3368 array subtype, replace it with the type it's a subtype of. This
3369 avoids problems with multiple copies of unconstrained array types.
3370 Likewise, if the designated type is a subtype of an incomplete
3371 record type, use the parent type to avoid order of elaboration
3372 issues. This can lose some code efficiency, but there is no
3374 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3375 && ! Is_Constrained (gnat_desig_equiv))
3376 gnat_desig_equiv = Etype (gnat_desig_equiv);
3377 if (Present (gnat_desig_full)
3378 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3379 && ! Is_Constrained (gnat_desig_full))
3380 || (Ekind (gnat_desig_full) == E_Record_Subtype
3381 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3382 gnat_desig_full = Etype (gnat_desig_full);
3384 /* Now set the type that actually marks the representation of
3385 the designated type and also flag whether we have a unconstrained
3387 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3388 is_unconstrained_array
3389 = (Is_Array_Type (gnat_desig_rep)
3390 && ! Is_Constrained (gnat_desig_rep));
3392 /* If we are pointing to an incomplete type whose completion is an
3393 unconstrained array, make a fat pointer type. The two types in our
3394 fields will be pointers to dummy nodes and will be replaced in
3395 update_pointer_to. Similarly, if the type itself is a dummy type or
3396 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3397 in case we have any thin pointers to it. */
3398 if (is_unconstrained_array
3399 && (Present (gnat_desig_full)
3400 || (present_gnu_tree (gnat_desig_equiv)
3401 && TYPE_IS_DUMMY_P (TREE_TYPE
3402 (get_gnu_tree (gnat_desig_equiv))))
3403 || (No (gnat_desig_full) && ! in_main_unit
3404 && defer_incomplete_level != 0
3405 && ! present_gnu_tree (gnat_desig_equiv))
3406 || (in_main_unit && is_from_limited_with
3407 && Present (Freeze_Node (gnat_desig_rep)))))
3411 if (present_gnu_tree (gnat_desig_rep))
3412 gnu_old = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3415 gnu_old = make_dummy_type (gnat_desig_rep);
3417 /* Show the dummy we get will be a fat pointer. */
3418 got_fat_p = made_dummy = true;
3421 /* If the call above got something that has a pointer, that
3422 pointer is our type. This could have happened either
3423 because the type was elaborated or because somebody
3424 else executed the code below. */
3425 gnu_type = TYPE_POINTER_TO (gnu_old);
3428 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3429 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3430 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3431 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3434 TYPE_NAME (gnu_template_type)
3435 = create_concat_name (gnat_desig_equiv, "XUB");
3436 TYPE_DUMMY_P (gnu_template_type) = 1;
3438 TYPE_NAME (gnu_array_type)
3439 = create_concat_name (gnat_desig_equiv, "XUA");
3440 TYPE_DUMMY_P (gnu_array_type) = 1;
3442 gnu_type = make_node (RECORD_TYPE);
3443 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3444 TYPE_POINTER_TO (gnu_old) = gnu_type;
3446 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3448 = chainon (chainon (NULL_TREE,
3450 (get_identifier ("P_ARRAY"),
3452 gnu_type, 0, 0, 0, 0)),
3453 create_field_decl (get_identifier ("P_BOUNDS"),
3455 gnu_type, 0, 0, 0, 0));
3457 /* Make sure we can place this into a register. */
3458 TYPE_ALIGN (gnu_type)
3459 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3460 TYPE_FAT_POINTER_P (gnu_type) = 1;
3462 /* Do not finalize this record type since the types of
3463 its fields are incomplete. */
3464 finish_record_type (gnu_type, fields, 0, true);
3466 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3467 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3468 = create_concat_name (gnat_desig_equiv, "XUT");
3469 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3473 /* If we already know what the full type is, use it. */
3474 else if (Present (gnat_desig_full)
3475 && present_gnu_tree (gnat_desig_full))
3476 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3478 /* Get the type of the thing we are to point to and build a pointer
3479 to it. If it is a reference to an incomplete or private type with a
3480 full view that is a record, make a dummy type node and get the
3481 actual type later when we have verified it is safe. */
3482 else if ((! in_main_unit
3483 && ! present_gnu_tree (gnat_desig_equiv)
3484 && Present (gnat_desig_full)
3485 && ! present_gnu_tree (gnat_desig_full)
3486 && Is_Record_Type (gnat_desig_full))
3487 /* Likewise if we are pointing to a record or array and we
3488 are to defer elaborating incomplete types. We do this
3489 since this access type may be the full view of some
3490 private type. Note that the unconstrained array case is
3492 || ((! in_main_unit || imported_p)
3493 && defer_incomplete_level != 0
3494 && ! present_gnu_tree (gnat_desig_equiv)
3495 && ((Is_Record_Type (gnat_desig_rep)
3496 || Is_Array_Type (gnat_desig_rep))))
3497 /* If this is a reference from a limited_with type back to our
3498 main unit and there's a Freeze_Node for it, either we have
3499 already processed the declaration and made the dummy type,
3500 in which case we just reuse the latter, or we have not yet,
3501 in which case we make the dummy type and it will be reused
3502 when the declaration is processed. In both cases, the
3503 pointer eventually created below will be automatically
3504 adjusted when the Freeze_Node is processed. Note that the
3505 unconstrained array case is handled above. */
3506 || (in_main_unit && is_from_limited_with
3507 && Present (Freeze_Node (gnat_desig_rep))))
3509 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3513 /* Otherwise handle the case of a pointer to itself. */
3514 else if (gnat_desig_equiv == gnat_entity)
3517 = build_pointer_type_for_mode (void_type_node, p_mode,
3518 No_Strict_Aliasing (gnat_entity));
3519 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3522 /* If expansion is disabled, the equivalent type of a concurrent
3523 type is absent, so build a dummy pointer type. */
3524 else if (type_annotate_only && No (gnat_desig_equiv))
3525 gnu_type = ptr_void_type_node;
3527 /* Finally, handle the straightforward case where we can just
3528 elaborate our designated type and point to it. */
3530 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3532 /* It is possible that a call to gnat_to_gnu_type above resolved our
3533 type. If so, just return it. */
3534 if (present_gnu_tree (gnat_entity))
3536 maybe_present = true;
3540 /* If we have a GCC type for the designated type, possibly modify it
3541 if we are pointing only to constant objects and then make a pointer
3542 to it. Don't do this for unconstrained arrays. */
3543 if (!gnu_type && gnu_desig_type)
3545 if (Is_Access_Constant (gnat_entity)
3546 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3549 = build_qualified_type
3551 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3553 /* Some extra processing is required if we are building a
3554 pointer to an incomplete type (in the GCC sense). We might
3555 have such a type if we just made a dummy, or directly out
3556 of the call to gnat_to_gnu_type above if we are processing
3557 an access type for a record component designating the
3558 record type itself. */
3559 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3561 /* We must ensure that the pointer to variant we make will
3562 be processed by update_pointer_to when the initial type
3563 is completed. Pretend we made a dummy and let further
3564 processing act as usual. */
3567 /* We must ensure that update_pointer_to will not retrieve
3568 the dummy variant when building a properly qualified
3569 version of the complete type. We take advantage of the
3570 fact that get_qualified_type is requiring TYPE_NAMEs to
3571 match to influence build_qualified_type and then also
3572 update_pointer_to here. */
3573 TYPE_NAME (gnu_desig_type)
3574 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3579 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3580 No_Strict_Aliasing (gnat_entity));
3583 /* If we are not defining this object and we made a dummy pointer,
3584 save our current definition, evaluate the actual type, and replace
3585 the tentative type we made with the actual one. If we are to defer
3586 actually looking up the actual type, make an entry in the
3587 deferred list. If this is from a limited with, we have to defer
3588 to the end of the current spec in two cases: first if the
3589 designated type is in the current unit and second if the access
3591 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3594 = TYPE_IS_FAT_POINTER_P (gnu_type)
3595 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3597 if (esize == POINTER_SIZE
3598 && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
3600 = build_pointer_type
3601 (TYPE_OBJECT_RECORD_TYPE
3602 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3604 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3605 !Comes_From_Source (gnat_entity),
3606 debug_info_p, gnat_entity);
3607 this_made_decl = true;
3608 gnu_type = TREE_TYPE (gnu_decl);
3609 save_gnu_tree (gnat_entity, gnu_decl, false);
3612 if (defer_incomplete_level == 0
3613 && ! (is_from_limited_with
3615 || In_Extended_Main_Code_Unit (gnat_entity))))
3616 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3617 gnat_to_gnu_type (gnat_desig_equiv));
3619 /* Note that the call to gnat_to_gnu_type here might have
3620 updated gnu_old_type directly, in which case it is not a
3621 dummy type any more when we get into update_pointer_to.
3623 This may happen for instance when the designated type is a
3624 record type, because their elaboration starts with an
3625 initial node from make_dummy_type, which may yield the same
3626 node as the one we got.
3628 Besides, variants of this non-dummy type might have been
3629 created along the way. update_pointer_to is expected to
3630 properly take care of those situations. */
3633 struct incomplete *p
3634 = (struct incomplete *) xmalloc (sizeof
3635 (struct incomplete));
3636 struct incomplete **head
3637 = (is_from_limited_with
3639 || In_Extended_Main_Code_Unit (gnat_entity))
3640 ? &defer_limited_with : &defer_incomplete_list);
3642 p->old_type = gnu_old_type;
3643 p->full_type = gnat_desig_equiv;
3651 case E_Access_Protected_Subprogram_Type:
3652 case E_Anonymous_Access_Protected_Subprogram_Type:
3653 if (type_annotate_only && No (gnat_equiv_type))
3654 gnu_type = ptr_void_type_node;
3657 /* The runtime representation is the equivalent type. */
3658 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3659 maybe_present = true;
3662 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3663 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3664 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3665 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3666 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3671 case E_Access_Subtype:
3673 /* We treat this as identical to its base type; any constraint is
3674 meaningful only to the front end.
3676 The designated type must be elaborated as well, if it does
3677 not have its own freeze node. Designated (sub)types created
3678 for constrained components of records with discriminants are
3679 not frozen by the front end and thus not elaborated by gigi,
3680 because their use may appear before the base type is frozen,
3681 and because it is not clear that they are needed anywhere in
3682 Gigi. With the current model, there is no correct place where
3683 they could be elaborated. */
3685 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3686 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3687 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3688 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3689 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3691 /* If we are not defining this entity, and we have incomplete
3692 entities being processed above us, make a dummy type and
3693 elaborate it later. */
3694 if (!definition && defer_incomplete_level != 0)
3696 struct incomplete *p
3697 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3699 = build_pointer_type
3700 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3702 p->old_type = TREE_TYPE (gnu_ptr_type);
3703 p->full_type = Directly_Designated_Type (gnat_entity);
3704 p->next = defer_incomplete_list;
3705 defer_incomplete_list = p;
3707 else if (!IN (Ekind (Base_Type
3708 (Directly_Designated_Type (gnat_entity))),
3709 Incomplete_Or_Private_Kind))
3710 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3714 maybe_present = true;
3717 /* Subprogram Entities
3719 The following access functions are defined for subprograms (functions
3722 First_Formal The first formal parameter.
3723 Is_Imported Indicates that the subprogram has appeared in
3724 an INTERFACE or IMPORT pragma. For now we
3725 assume that the external language is C.
3726 Is_Exported Likewise but for an EXPORT pragma.
3727 Is_Inlined True if the subprogram is to be inlined.
3729 In addition for function subprograms we have:
3731 Etype Return type of the function.
3733 Each parameter is first checked by calling must_pass_by_ref on its
3734 type to determine if it is passed by reference. For parameters which
3735 are copied in, if they are Ada In Out or Out parameters, their return
3736 value becomes part of a record which becomes the return type of the
3737 function (C function - note that this applies only to Ada procedures
3738 so there is no Ada return type). Additional code to store back the
3739 parameters will be generated on the caller side. This transformation
3740 is done here, not in the front-end.
3742 The intended result of the transformation can be seen from the
3743 equivalent source rewritings that follow:
3745 struct temp {int a,b};
3746 procedure P (A,B: In Out ...) is temp P (int A,B)
3749 end P; return {A,B};
3756 For subprogram types we need to perform mainly the same conversions to
3757 GCC form that are needed for procedures and function declarations. The
3758 only difference is that at the end, we make a type declaration instead
3759 of a function declaration. */
3761 case E_Subprogram_Type:
3765 /* The first GCC parameter declaration (a PARM_DECL node). The
3766 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3767 actually is the head of this parameter list. */
3768 tree gnu_param_list = NULL_TREE;
3769 /* Likewise for the stub associated with an exported procedure. */
3770 tree gnu_stub_param_list = NULL_TREE;
3771 /* The type returned by a function. If the subprogram is a procedure
3772 this type should be void_type_node. */
3773 tree gnu_return_type = void_type_node;
3774 /* List of fields in return type of procedure with copy-in copy-out
3776 tree gnu_field_list = NULL_TREE;
3777 /* Non-null for subprograms containing parameters passed by copy-in
3778 copy-out (Ada In Out or Out parameters not passed by reference),
3779 in which case it is the list of nodes used to specify the values of
3780 the in out/out parameters that are returned as a record upon
3781 procedure return. The TREE_PURPOSE of an element of this list is
3782 a field of the record and the TREE_VALUE is the PARM_DECL
3783 corresponding to that field. This list will be saved in the
3784 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3785 tree gnu_return_list = NULL_TREE;
3786 /* If an import pragma asks to map this subprogram to a GCC builtin,
3787 this is the builtin DECL node. */
3788 tree gnu_builtin_decl = NULL_TREE;
3789 /* For the stub associated with an exported procedure. */
3790 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3791 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3792 Entity_Id gnat_param;
3793 bool inline_flag = Is_Inlined (gnat_entity);
3794 bool public_flag = Is_Public (gnat_entity) || imported_p;
3796 = (Is_Public (gnat_entity) && !definition) || imported_p;
3798 /* The semantics of "pure" in Ada essentially matches that of "const"
3799 in the back-end. In particular, both properties are orthogonal to
3800 the "nothrow" property if the EH circuitry is explicit in the
3801 internal representation of the back-end. If we are to completely
3802 hide the EH circuitry from it, we need to declare that calls to pure
3803 Ada subprograms that can throw have side effects since they can
3804 trigger an "abnormal" transfer of control flow; thus they can be
3805 neither "const" nor "pure" in the back-end sense. */
3807 = (Exception_Mechanism == Back_End_Exceptions
3808 && Is_Pure (gnat_entity));
3810 bool volatile_flag = No_Return (gnat_entity);
3811 bool returns_by_ref = false;
3812 bool returns_unconstrained = false;
3813 bool returns_by_target_ptr = false;
3814 bool has_copy_in_out = false;
3815 bool has_stub = false;
3818 /* A parameter may refer to this type, so defer completion of any
3819 incomplete types. */
3820 if (kind == E_Subprogram_Type && !definition)
3822 defer_incomplete_level++;
3823 this_deferred = true;
3826 /* If the subprogram has an alias, it is probably inherited, so
3827 we can use the original one. If the original "subprogram"
3828 is actually an enumeration literal, it may be the first use
3829 of its type, so we must elaborate that type now. */
3830 if (Present (Alias (gnat_entity)))
3832 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3833 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3835 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3838 /* Elaborate any Itypes in the parameters of this entity. */
3839 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3840 Present (gnat_temp);
3841 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3842 if (Is_Itype (Etype (gnat_temp)))
3843 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3848 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3849 corresponding DECL node.
3851 We still want the parameter associations to take place because the
3852 proper generation of calls depends on it (a GNAT parameter without
3853 a corresponding GCC tree has a very specific meaning), so we don't
3855 if (Convention (gnat_entity) == Convention_Intrinsic)
3856 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3858 /* ??? What if we don't find the builtin node above ? warn ? err ?
3859 In the current state we neither warn nor err, and calls will just
3860 be handled as for regular subprograms. */
3862 if (kind == E_Function || kind == E_Subprogram_Type)
3863 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3865 /* If this function returns by reference, make the actual
3866 return type of this function the pointer and mark the decl. */
3867 if (Returns_By_Ref (gnat_entity))
3869 returns_by_ref = true;
3870 gnu_return_type = build_pointer_type (gnu_return_type);
3873 /* If the Mechanism is By_Reference, ensure the return type uses
3874 the machine's by-reference mechanism, which may not the same
3875 as above (e.g., it might be by passing a fake parameter). */
3876 else if (kind == E_Function
3877 && Mechanism (gnat_entity) == By_Reference)
3879 TREE_ADDRESSABLE (gnu_return_type) = 1;
3881 /* We expect this bit to be reset by gigi shortly, so can avoid a
3882 type node copy here. This actually also prevents troubles with
3883 the generation of debug information for the function, because
3884 we might have issued such info for this type already, and would
3885 be attaching a distinct type node to the function if we made a
3889 /* If we are supposed to return an unconstrained array,
3890 actually return a fat pointer and make a note of that. Return
3891 a pointer to an unconstrained record of variable size. */
3892 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3894 gnu_return_type = TREE_TYPE (gnu_return_type);
3895 returns_unconstrained = true;
3898 /* If the type requires a transient scope, the result is allocated
3899 on the secondary stack, so the result type of the function is
3901 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3903 gnu_return_type = build_pointer_type (gnu_return_type);
3904 returns_unconstrained = true;
3907 /* If the type is a padded type and the underlying type would not
3908 be passed by reference or this function has a foreign convention,
3909 return the underlying type. */
3910 else if (TYPE_IS_PADDING_P (gnu_return_type)
3911 && (!default_pass_by_ref (TREE_TYPE
3912 (TYPE_FIELDS (gnu_return_type)))
3913 || Has_Foreign_Convention (gnat_entity)))
3914 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3916 /* If the return type has a non-constant size, we convert the function
3917 into a procedure and its caller will pass a pointer to an object as
3918 the first parameter when we call the function. This can happen for
3919 an unconstrained type with a maximum size or a constrained type with
3920 a size not known at compile time. */
3921 if (TYPE_SIZE_UNIT (gnu_return_type)
3922 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3924 returns_by_target_ptr = true;
3926 = create_param_decl (get_identifier ("TARGET"),
3927 build_reference_type (gnu_return_type),
3929 gnu_return_type = void_type_node;
3932 /* If the return type has a size that overflows, we cannot have
3933 a function that returns that type. This usage doesn't make
3934 sense anyway, so give an error here. */
3935 if (TYPE_SIZE_UNIT (gnu_return_type)
3936 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3937 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3939 post_error ("cannot return type whose size overflows",
3941 gnu_return_type = copy_node (gnu_return_type);
3942 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3943 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3944 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3945 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3948 /* Look at all our parameters and get the type of
3949 each. While doing this, build a copy-out structure if
3952 /* Loop over the parameters and get their associated GCC tree.
3953 While doing this, build a copy-out structure if we need one. */
3954 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3955 Present (gnat_param);
3956 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3958 tree gnu_param_name = get_entity_name (gnat_param);
3959 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3960 tree gnu_param, gnu_field;
3961 bool copy_in_copy_out = false;
3962 Mechanism_Type mech = Mechanism (gnat_param);
3964 /* Builtins are expanded inline and there is no real call sequence
3965 involved. So the type expected by the underlying expander is
3966 always the type of each argument "as is". */
3967 if (gnu_builtin_decl)
3969 /* Handle the first parameter of a valued procedure specially. */
3970 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3971 mech = By_Copy_Return;
3972 /* Otherwise, see if a Mechanism was supplied that forced this
3973 parameter to be passed one way or another. */
3974 else if (mech == Default
3975 || mech == By_Copy || mech == By_Reference)
3977 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3978 mech = By_Descriptor;
3980 else if (By_Short_Descriptor_Last <= mech &&
3981 mech <= By_Short_Descriptor)
3982 mech = By_Short_Descriptor;
3986 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3987 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3988 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3990 mech = By_Reference;
3996 post_error ("unsupported mechanism for&", gnat_param);
4001 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4002 Has_Foreign_Convention (gnat_entity),
4005 /* We are returned either a PARM_DECL or a type if no parameter
4006 needs to be passed; in either case, adjust the type. */
4007 if (DECL_P (gnu_param))
4008 gnu_param_type = TREE_TYPE (gnu_param);
4011 gnu_param_type = gnu_param;
4012 gnu_param = NULL_TREE;
4017 /* If it's an exported subprogram, we build a parameter list
4018 in parallel, in case we need to emit a stub for it. */
4019 if (Is_Exported (gnat_entity))
4022 = chainon (gnu_param, gnu_stub_param_list);
4023 /* Change By_Descriptor parameter to By_Reference for
4024 the internal version of an exported subprogram. */
4025 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4028 = gnat_to_gnu_param (gnat_param, By_Reference,
4034 gnu_param = copy_node (gnu_param);
4037 gnu_param_list = chainon (gnu_param, gnu_param_list);
4038 Sloc_to_locus (Sloc (gnat_param),
4039 &DECL_SOURCE_LOCATION (gnu_param));
4040 save_gnu_tree (gnat_param, gnu_param, false);
4042 /* If a parameter is a pointer, this function may modify
4043 memory through it and thus shouldn't be considered
4044 a const function. Also, the memory may be modified
4045 between two calls, so they can't be CSE'ed. The latter
4046 case also handles by-ref parameters. */
4047 if (POINTER_TYPE_P (gnu_param_type)
4048 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4052 if (copy_in_copy_out)
4054 if (!has_copy_in_out)
4056 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
4057 gnu_return_type = make_node (RECORD_TYPE);
4058 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4059 has_copy_in_out = true;
4062 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
4063 gnu_return_type, 0, 0, 0, 0);
4064 Sloc_to_locus (Sloc (gnat_param),
4065 &DECL_SOURCE_LOCATION (gnu_field));
4066 TREE_CHAIN (gnu_field) = gnu_field_list;
4067 gnu_field_list = gnu_field;
4068 gnu_return_list = tree_cons (gnu_field, gnu_param,
4073 /* Do not compute record for out parameters if subprogram is
4074 stubbed since structures are incomplete for the back-end. */
4075 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
4076 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4079 /* If we have a CICO list but it has only one entry, we convert
4080 this function into a function that simply returns that one
4082 if (list_length (gnu_return_list) == 1)
4083 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
4085 if (Has_Stdcall_Convention (gnat_entity))
4086 prepend_one_attribute_to
4087 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4088 get_identifier ("stdcall"), NULL_TREE,
4091 /* If we are on a target where stack realignment is needed for 'main'
4092 to honor GCC's implicit expectations (stack alignment greater than
4093 what the base ABI guarantees), ensure we do the same for foreign
4094 convention subprograms as they might be used as callbacks from code
4095 breaking such expectations. Note that this applies to task entry
4096 points in particular. */
4097 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4098 && Has_Foreign_Convention (gnat_entity))
4099 prepend_one_attribute_to
4100 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4101 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4104 /* The lists have been built in reverse. */
4105 gnu_param_list = nreverse (gnu_param_list);
4107 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4108 gnu_return_list = nreverse (gnu_return_list);
4110 if (Ekind (gnat_entity) == E_Function)
4111 Set_Mechanism (gnat_entity,
4112 (returns_by_ref || returns_unconstrained
4113 ? By_Reference : By_Copy));
4115 = create_subprog_type (gnu_return_type, gnu_param_list,
4116 gnu_return_list, returns_unconstrained,
4117 returns_by_ref, returns_by_target_ptr);
4121 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4122 gnu_return_list, returns_unconstrained,
4123 returns_by_ref, returns_by_target_ptr);
4125 /* A subprogram (something that doesn't return anything) shouldn't
4126 be considered const since there would be no reason for such a
4127 subprogram. Note that procedures with Out (or In Out) parameters
4128 have already been converted into a function with a return type. */
4129 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4133 = build_qualified_type (gnu_type,
4134 TYPE_QUALS (gnu_type)
4135 | (TYPE_QUAL_CONST * const_flag)
4136 | (TYPE_QUAL_VOLATILE * volatile_flag));
4138 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4142 = build_qualified_type (gnu_stub_type,
4143 TYPE_QUALS (gnu_stub_type)
4144 | (TYPE_QUAL_CONST * const_flag)
4145 | (TYPE_QUAL_VOLATILE * volatile_flag));
4147 /* If we have a builtin decl for that function, check the signatures
4148 compatibilities. If the signatures are compatible, use the builtin
4149 decl. If they are not, we expect the checker predicate to have
4150 posted the appropriate errors, and just continue with what we have
4152 if (gnu_builtin_decl)
4154 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4156 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4158 gnu_decl = gnu_builtin_decl;
4159 gnu_type = gnu_builtin_type;
4164 /* If there was no specified Interface_Name and the external and
4165 internal names of the subprogram are the same, only use the
4166 internal name to allow disambiguation of nested subprograms. */
4167 if (No (Interface_Name (gnat_entity))
4168 && gnu_ext_name == gnu_entity_name)
4169 gnu_ext_name = NULL_TREE;
4171 /* If we are defining the subprogram and it has an Address clause
4172 we must get the address expression from the saved GCC tree for the
4173 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4174 the address expression here since the front-end has guaranteed
4175 in that case that the elaboration has no effects. If there is
4176 an Address clause and we are not defining the object, just
4177 make it a constant. */
4178 if (Present (Address_Clause (gnat_entity)))
4180 tree gnu_address = NULL_TREE;
4184 = (present_gnu_tree (gnat_entity)
4185 ? get_gnu_tree (gnat_entity)
4186 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4188 save_gnu_tree (gnat_entity, NULL_TREE, false);
4190 /* Convert the type of the object to a reference type that can
4191 alias everything as per 13.3(19). */
4193 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4195 gnu_address = convert (gnu_type, gnu_address);
4198 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4199 gnu_address, false, Is_Public (gnat_entity),
4200 extern_flag, false, NULL, gnat_entity);
4201 DECL_BY_REF_P (gnu_decl) = 1;
4204 else if (kind == E_Subprogram_Type)
4205 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4206 !Comes_From_Source (gnat_entity),
4207 debug_info_p, gnat_entity);
4212 gnu_stub_name = gnu_ext_name;
4213 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4214 public_flag = false;
4217 gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4218 gnu_type, gnu_param_list,
4219 inline_flag, public_flag,
4220 extern_flag, attr_list,
4225 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4226 gnu_stub_type, gnu_stub_param_list,
4228 extern_flag, attr_list,
4230 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4233 /* This is unrelated to the stub built right above. */
4234 DECL_STUBBED_P (gnu_decl)
4235 = Convention (gnat_entity) == Convention_Stubbed;
4240 case E_Incomplete_Type:
4241 case E_Incomplete_Subtype:
4242 case E_Private_Type:
4243 case E_Private_Subtype:
4244 case E_Limited_Private_Type:
4245 case E_Limited_Private_Subtype:
4246 case E_Record_Type_With_Private:
4247 case E_Record_Subtype_With_Private:
4249 /* Get the "full view" of this entity. If this is an incomplete
4250 entity from a limited with, treat its non-limited view as the
4251 full view. Otherwise, use either the full view or the underlying
4252 full view, whichever is present. This is used in all the tests
4255 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4256 && From_With_Type (gnat_entity))
4257 ? Non_Limited_View (gnat_entity)
4258 : Present (Full_View (gnat_entity))
4259 ? Full_View (gnat_entity)
4260 : Underlying_Full_View (gnat_entity);
4262 /* If this is an incomplete type with no full view, it must be a Taft
4263 Amendment type, in which case we return a dummy type. Otherwise,
4264 just get the type from its Etype. */
4267 if (kind == E_Incomplete_Type)
4269 gnu_type = make_dummy_type (gnat_entity);
4270 gnu_decl = TYPE_STUB_DECL (gnu_type);
4274 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4276 maybe_present = true;
4281 /* If we already made a type for the full view, reuse it. */
4282 else if (present_gnu_tree (full_view))
4284 gnu_decl = get_gnu_tree (full_view);
4288 /* Otherwise, if we are not defining the type now, get the type
4289 from the full view. But always get the type from the full view
4290 for define on use types, since otherwise we won't see them! */
4291 else if (!definition
4292 || (Is_Itype (full_view)
4293 && No (Freeze_Node (gnat_entity)))
4294 || (Is_Itype (gnat_entity)
4295 && No (Freeze_Node (full_view))))
4297 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4298 maybe_present = true;
4302 /* For incomplete types, make a dummy type entry which will be
4303 replaced later. Save it as the full declaration's type so
4304 we can do any needed updates when we see it. */
4305 gnu_type = make_dummy_type (gnat_entity);
4306 gnu_decl = TYPE_STUB_DECL (gnu_type);
4307 save_gnu_tree (full_view, gnu_decl, 0);
4311 /* Simple class_wide types are always viewed as their root_type
4312 by Gigi unless an Equivalent_Type is specified. */
4313 case E_Class_Wide_Type:
4314 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4315 maybe_present = true;
4319 case E_Task_Subtype:
4320 case E_Protected_Type:
4321 case E_Protected_Subtype:
4322 if (type_annotate_only && No (gnat_equiv_type))
4323 gnu_type = void_type_node;
4325 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4327 maybe_present = true;
4331 gnu_decl = create_label_decl (gnu_entity_name);
4336 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4337 we've already saved it, so we don't try to. */
4338 gnu_decl = error_mark_node;
4346 /* If we had a case where we evaluated another type and it might have
4347 defined this one, handle it here. */
4348 if (maybe_present && present_gnu_tree (gnat_entity))
4350 gnu_decl = get_gnu_tree (gnat_entity);
4354 /* If we are processing a type and there is either no decl for it or
4355 we just made one, do some common processing for the type, such as
4356 handling alignment and possible padding. */
4357 if (is_type && (!gnu_decl || this_made_decl))
4359 if (Is_Tagged_Type (gnat_entity)
4360 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4361 TYPE_ALIGN_OK (gnu_type) = 1;
4363 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4364 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4366 /* ??? Don't set the size for a String_Literal since it is either
4367 confirming or we don't handle it properly (if the low bound is
4369 if (!gnu_size && kind != E_String_Literal_Subtype)
4370 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4372 Has_Size_Clause (gnat_entity));
4374 /* If a size was specified, see if we can make a new type of that size
4375 by rearranging the type, for example from a fat to a thin pointer. */
4379 = make_type_from_size (gnu_type, gnu_size,
4380 Has_Biased_Representation (gnat_entity));
4382 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4383 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4387 /* If the alignment hasn't already been processed and this is
4388 not an unconstrained array, see if an alignment is specified.
4389 If not, we pick a default alignment for atomic objects. */
4390 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4392 else if (Known_Alignment (gnat_entity))
4394 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4395 TYPE_ALIGN (gnu_type));
4397 /* Warn on suspiciously large alignments. This should catch
4398 errors about the (alignment,byte)/(size,bit) discrepancy. */
4399 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4403 /* If a size was specified, take it into account. Otherwise
4404 use the RM size for records as the type size has already
4405 been adjusted to the alignment. */
4408 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4409 || TREE_CODE (gnu_type) == UNION_TYPE
4410 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4411 && !TYPE_FAT_POINTER_P (gnu_type))
4412 size = rm_size (gnu_type);
4414 size = TYPE_SIZE (gnu_type);
4416 /* Consider an alignment as suspicious if the alignment/size
4417 ratio is greater or equal to the byte/bit ratio. */
4418 if (host_integerp (size, 1)
4419 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4420 post_error_ne ("?suspiciously large alignment specified for&",
4421 Expression (Alignment_Clause (gnat_entity)),
4425 else if (Is_Atomic (gnat_entity) && !gnu_size
4426 && host_integerp (TYPE_SIZE (gnu_type), 1)
4427 && integer_pow2p (TYPE_SIZE (gnu_type)))
4428 align = MIN (BIGGEST_ALIGNMENT,
4429 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4430 else if (Is_Atomic (gnat_entity) && gnu_size
4431 && host_integerp (gnu_size, 1)
4432 && integer_pow2p (gnu_size))
4433 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4435 /* See if we need to pad the type. If we did, and made a record,
4436 the name of the new type may be changed. So get it back for
4437 us when we make the new TYPE_DECL below. */
4438 if (gnu_size || align > 0)
4439 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4440 false, !gnu_decl, definition, false);
4442 if (TYPE_IS_PADDING_P (gnu_type))
4444 gnu_entity_name = TYPE_NAME (gnu_type);
4445 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4446 gnu_entity_name = DECL_NAME (gnu_entity_name);
4449 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4451 /* If we are at global level, GCC will have applied variable_size to
4452 the type, but that won't have done anything. So, if it's not
4453 a constant or self-referential, call elaborate_expression_1 to
4454 make a variable for the size rather than calculating it each time.
4455 Handle both the RM size and the actual size. */
4456 if (global_bindings_p ()
4457 && TYPE_SIZE (gnu_type)
4458 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4459 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4461 if (TREE_CODE (gnu_type) == RECORD_TYPE
4462 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4463 TYPE_SIZE (gnu_type), 0))
4465 TYPE_SIZE (gnu_type)
4466 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4467 gnat_entity, get_identifier ("SIZE"),
4469 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4473 TYPE_SIZE (gnu_type)
4474 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4475 gnat_entity, get_identifier ("SIZE"),
4478 /* ??? For now, store the size as a multiple of the alignment
4479 in bytes so that we can see the alignment from the tree. */
4480 TYPE_SIZE_UNIT (gnu_type)
4482 (MULT_EXPR, sizetype,
4483 elaborate_expression_1
4484 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4485 TYPE_SIZE_UNIT (gnu_type),
4486 size_int (TYPE_ALIGN (gnu_type)
4488 gnat_entity, get_identifier ("SIZE_A_UNIT"),
4490 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4492 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4495 elaborate_expression_1 (TYPE_ADA_SIZE (gnu_type),
4497 get_identifier ("RM_SIZE"),
4498 definition, false));
4502 /* If this is a record type or subtype, call elaborate_expression_1 on
4503 any field position. Do this for both global and local types.
4504 Skip any fields that we haven't made trees for to avoid problems with
4505 class wide types. */
4506 if (IN (kind, Record_Kind))
4507 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4508 gnat_temp = Next_Entity (gnat_temp))
4509 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4511 tree gnu_field = get_gnu_tree (gnat_temp);
4513 /* ??? Unfortunately, GCC needs to be able to prove the
4514 alignment of this offset and if it's a variable, it can't.
4515 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4516 right now, we have to put in an explicit multiply and
4517 divide by that value. */
4518 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4520 DECL_FIELD_OFFSET (gnu_field)
4522 (MULT_EXPR, sizetype,
4523 elaborate_expression_1
4524 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4525 DECL_FIELD_OFFSET (gnu_field),
4526 size_int (DECL_OFFSET_ALIGN (gnu_field)
4528 gnat_temp, get_identifier ("OFFSET"),
4530 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4532 /* ??? The context of gnu_field is not necessarily gnu_type so
4533 the MULT_EXPR node built above may not be marked by the call
4534 to create_type_decl below. */
4535 if (global_bindings_p ())
4536 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4540 if (Treat_As_Volatile (gnat_entity))
4542 = build_qualified_type (gnu_type,
4543 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4545 if (Is_Atomic (gnat_entity))
4546 check_ok_for_atomic (gnu_type, gnat_entity, false);
4548 if (Present (Alignment_Clause (gnat_entity)))
4549 TYPE_USER_ALIGN (gnu_type) = 1;
4551 if (Universal_Aliasing (gnat_entity))
4552 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4555 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4556 !Comes_From_Source (gnat_entity),
4557 debug_info_p, gnat_entity);
4560 TREE_TYPE (gnu_decl) = gnu_type;
4561 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4565 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4567 gnu_type = TREE_TYPE (gnu_decl);
4569 /* If this is a derived type, relate its alias set to that of its parent
4570 to avoid troubles when a call to an inherited primitive is inlined in
4571 a context where a derived object is accessed. The inlined code works
4572 on the parent view so the resulting code may access the same object
4573 using both the parent and the derived alias sets, which thus have to
4574 conflict. As the same issue arises with component references, the
4575 parent alias set also has to conflict with composite types enclosing
4576 derived components. For instance, if we have:
4583 we want T to conflict with both D and R, in addition to R being a
4584 superset of D by record/component construction.
4586 One way to achieve this is to perform an alias set copy from the
4587 parent to the derived type. This is not quite appropriate, though,
4588 as we don't want separate derived types to conflict with each other:
4590 type I1 is new Integer;
4591 type I2 is new Integer;
4593 We want I1 and I2 to both conflict with Integer but we do not want
4594 I1 to conflict with I2, and an alias set copy on derivation would
4597 The option chosen is to make the alias set of the derived type a
4598 superset of that of its parent type. It trivially fulfills the
4599 simple requirement for the Integer derivation example above, and
4600 the component case as well by superset transitivity:
4603 R ----------> D ----------> T
4605 The language rules ensure the parent type is already frozen here. */
4606 if (Is_Derived_Type (gnat_entity))
4608 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4609 relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET);
4612 /* Back-annotate the Alignment of the type if not already in the
4613 tree. Likewise for sizes. */
4614 if (Unknown_Alignment (gnat_entity))
4616 unsigned int double_align, align;
4617 bool is_capped_double, align_clause;
4619 /* If the default alignment of "double" or larger scalar types is
4620 specifically capped and this is not an array with an alignment
4621 clause on the component type, return the cap. */
4622 if ((double_align = double_float_alignment) > 0)
4624 = is_double_float_or_array (gnat_entity, &align_clause);
4625 else if ((double_align = double_scalar_alignment) > 0)
4627 = is_double_scalar_or_array (gnat_entity, &align_clause);
4629 is_capped_double = align_clause = false;
4631 if (is_capped_double && !align_clause)
4632 align = double_align;
4634 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4636 Set_Alignment (gnat_entity, UI_From_Int (align));
4639 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4641 /* If the size is self-referential, we annotate the maximum
4642 value of that size. */
4643 tree gnu_size = TYPE_SIZE (gnu_type);
4645 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4646 gnu_size = max_size (gnu_size, true);
4648 Set_Esize (gnat_entity, annotate_value (gnu_size));
4650 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4652 /* In this mode the tag and the parent components are not
4653 generated by the front-end, so the sizes must be adjusted
4655 int size_offset, new_size;
4657 if (Is_Derived_Type (gnat_entity))
4660 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4661 Set_Alignment (gnat_entity,
4662 Alignment (Etype (Base_Type (gnat_entity))));
4665 size_offset = POINTER_SIZE;
4667 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4668 Set_Esize (gnat_entity,
4669 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4670 / POINTER_SIZE) * POINTER_SIZE));
4671 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4675 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4676 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4679 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4680 DECL_ARTIFICIAL (gnu_decl) = 1;
4682 if (!debug_info_p && DECL_P (gnu_decl)
4683 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4684 && No (Renamed_Object (gnat_entity)))
4685 DECL_IGNORED_P (gnu_decl) = 1;
4687 /* If we haven't already, associate the ..._DECL node that we just made with
4688 the input GNAT entity node. */
4690 save_gnu_tree (gnat_entity, gnu_decl, false);
4692 /* If this is an enumeration or floating-point type, we were not able to set
4693 the bounds since they refer to the type. These are always static. */
4694 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4695 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4697 tree gnu_scalar_type = gnu_type;
4698 tree gnu_low_bound, gnu_high_bound;
4700 /* If this is a padded type, we need to use the underlying type. */
4701 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4702 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4704 /* If this is a floating point type and we haven't set a floating
4705 point type yet, use this in the evaluation of the bounds. */
4706 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4707 longest_float_type_node = gnu_scalar_type;
4709 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4710 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4712 if (kind == E_Enumeration_Type)
4714 /* Enumeration types have specific RM bounds. */
4715 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4716 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4718 /* Write full debugging information. Since this has both a
4719 typedef and a tag, avoid outputting the name twice. */
4720 DECL_ARTIFICIAL (gnu_decl) = 1;
4721 rest_of_type_decl_compilation (gnu_decl);
4726 /* Floating-point types don't have specific RM bounds. */
4727 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4728 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4732 /* If we deferred processing of incomplete types, re-enable it. If there
4733 were no other disables and we have some to process, do so. */
4734 if (this_deferred && --defer_incomplete_level == 0)
4736 if (defer_incomplete_list)
4738 struct incomplete *incp, *next;
4740 /* We are back to level 0 for the deferring of incomplete types.
4741 But processing these incomplete types below may itself require
4742 deferring, so preserve what we have and restart from scratch. */
4743 incp = defer_incomplete_list;
4744 defer_incomplete_list = NULL;
4746 /* For finalization, however, all types must be complete so we
4747 cannot do the same because deferred incomplete types may end up
4748 referencing each other. Process them all recursively first. */
4749 defer_finalize_level++;
4751 for (; incp; incp = next)
4756 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4757 gnat_to_gnu_type (incp->full_type));
4761 defer_finalize_level--;
4764 /* All the deferred incomplete types have been processed so we can
4765 now proceed with the finalization of the deferred types. */
4766 if (defer_finalize_level == 0 && defer_finalize_list)
4771 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4772 rest_of_type_decl_compilation_no_defer (t);
4774 VEC_free (tree, heap, defer_finalize_list);
4778 /* If we are not defining this type, see if it's in the incomplete list.
4779 If so, handle that list entry now. */
4780 else if (!definition)
4782 struct incomplete *incp;
4784 for (incp = defer_incomplete_list; incp; incp = incp->next)
4785 if (incp->old_type && incp->full_type == gnat_entity)
4787 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4788 TREE_TYPE (gnu_decl));
4789 incp->old_type = NULL_TREE;
4796 /* If this is a packed array type whose original array type is itself
4797 an Itype without freeze node, make sure the latter is processed. */
4798 if (Is_Packed_Array_Type (gnat_entity)
4799 && Is_Itype (Original_Array_Type (gnat_entity))
4800 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4801 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4802 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
4807 /* Similar, but if the returned value is a COMPONENT_REF, return the
4811 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4813 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4815 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4816 gnu_field = TREE_OPERAND (gnu_field, 1);
4821 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4822 the GCC type corresponding to that entity. */
4825 gnat_to_gnu_type (Entity_Id gnat_entity)
4829 /* The back end never attempts to annotate generic types. */
4830 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4831 return void_type_node;
4833 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4834 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4836 return TREE_TYPE (gnu_decl);
4839 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4840 the unpadded version of the GCC type corresponding to that entity. */
4843 get_unpadded_type (Entity_Id gnat_entity)
4845 tree type = gnat_to_gnu_type (gnat_entity);
4847 if (TYPE_IS_PADDING_P (type))
4848 type = TREE_TYPE (TYPE_FIELDS (type));
4853 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4854 Every TYPE_DECL generated for a type definition must be passed
4855 to this function once everything else has been done for it. */
4858 rest_of_type_decl_compilation (tree decl)
4860 /* We need to defer finalizing the type if incomplete types
4861 are being deferred or if they are being processed. */
4862 if (defer_incomplete_level || defer_finalize_level)
4863 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4865 rest_of_type_decl_compilation_no_defer (decl);
4868 /* Same as above but without deferring the compilation. This
4869 function should not be invoked directly on a TYPE_DECL. */
4872 rest_of_type_decl_compilation_no_defer (tree decl)
4874 const int toplev = global_bindings_p ();
4875 tree t = TREE_TYPE (decl);
4877 rest_of_decl_compilation (decl, toplev, 0);
4879 /* Now process all the variants. This is needed for STABS. */
4880 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4882 if (t == TREE_TYPE (decl))
4885 if (!TYPE_STUB_DECL (t))
4886 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
4888 rest_of_type_compilation (t, toplev);
4892 /* Finalize any From_With_Type incomplete types. We do this after processing
4893 our compilation unit and after processing its spec, if this is a body. */
4896 finalize_from_with_types (void)
4898 struct incomplete *incp = defer_limited_with;
4899 struct incomplete *next;
4901 defer_limited_with = 0;
4902 for (; incp; incp = next)
4906 if (incp->old_type != 0)
4907 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4908 gnat_to_gnu_type (incp->full_type));
4913 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4914 kind of type (such E_Task_Type) that has a different type which Gigi
4915 uses for its representation. If the type does not have a special type
4916 for its representation, return GNAT_ENTITY. If a type is supposed to
4917 exist, but does not, abort unless annotating types, in which case
4918 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4921 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4923 Entity_Id gnat_equiv = gnat_entity;
4925 if (No (gnat_entity))
4928 switch (Ekind (gnat_entity))
4930 case E_Class_Wide_Subtype:
4931 if (Present (Equivalent_Type (gnat_entity)))
4932 gnat_equiv = Equivalent_Type (gnat_entity);
4935 case E_Access_Protected_Subprogram_Type:
4936 case E_Anonymous_Access_Protected_Subprogram_Type:
4937 gnat_equiv = Equivalent_Type (gnat_entity);
4940 case E_Class_Wide_Type:
4941 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4942 ? Equivalent_Type (gnat_entity)
4943 : Root_Type (gnat_entity));
4947 case E_Task_Subtype:
4948 case E_Protected_Type:
4949 case E_Protected_Subtype:
4950 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4957 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4961 /* Return a GCC tree for a type corresponding to the component type of the
4962 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
4963 is for an array being defined. DEBUG_INFO_P is true if we need to write
4964 debug information for other types that we may create in the process. */
4967 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
4970 tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
4973 /* Try to get a smaller form of the component if needed. */
4974 if ((Is_Packed (gnat_array)
4975 || Has_Component_Size_Clause (gnat_array))
4976 && !Is_Bit_Packed_Array (gnat_array)
4977 && !Has_Aliased_Components (gnat_array)
4978 && !Strict_Alignment (Component_Type (gnat_array))
4979 && TREE_CODE (gnu_type) == RECORD_TYPE
4980 && !TYPE_FAT_POINTER_P (gnu_type)
4981 && host_integerp (TYPE_SIZE (gnu_type), 1))
4982 gnu_type = make_packable_type (gnu_type, false);
4984 if (Has_Atomic_Components (gnat_array))
4985 check_ok_for_atomic (gnu_type, gnat_array, true);
4987 /* Get and validate any specified Component_Size. */
4989 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
4990 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
4991 true, Has_Component_Size_Clause (gnat_array));
4993 /* If the array has aliased components and the component size can be zero,
4994 force at least unit size to ensure that the components have distinct
4997 && Has_Aliased_Components (gnat_array)
4998 && (integer_zerop (TYPE_SIZE (gnu_type))
4999 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5000 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5002 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5004 /* If the component type is a RECORD_TYPE that has a self-referential size,
5005 then use the maximum size for the component size. */
5007 && TREE_CODE (gnu_type) == RECORD_TYPE
5008 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5009 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5011 /* Honor the component size. This is not needed for bit-packed arrays. */
5012 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5014 tree orig_type = gnu_type;
5015 unsigned int max_align;
5017 /* If an alignment is specified, use it as a cap on the component type
5018 so that it can be honored for the whole type. But ignore it for the
5019 original type of packed array types. */
5020 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5021 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5025 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5026 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5027 gnu_type = orig_type;
5029 orig_type = gnu_type;
5031 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5032 true, false, definition, true);
5034 /* If a padding record was made, declare it now since it will never be
5035 declared otherwise. This is necessary to ensure that its subtrees
5036 are properly marked. */
5037 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5038 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5039 debug_info_p, gnat_array);
5042 if (Has_Volatile_Components (Base_Type (gnat_array)))
5044 = build_qualified_type (gnu_type,
5045 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5050 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5051 using MECH as its passing mechanism, to be placed in the parameter
5052 list built for GNAT_SUBPROG. Assume a foreign convention for the
5053 latter if FOREIGN is true. Also set CICO to true if the parameter
5054 must use the copy-in copy-out implementation mechanism.
5056 The returned tree is a PARM_DECL, except for those cases where no
5057 parameter needs to be actually passed to the subprogram; the type
5058 of this "shadow" parameter is then returned instead. */
5061 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5062 Entity_Id gnat_subprog, bool foreign, bool *cico)
5064 tree gnu_param_name = get_entity_name (gnat_param);
5065 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5066 tree gnu_param_type_alt = NULL_TREE;
5067 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5068 /* The parameter can be indirectly modified if its address is taken. */
5069 bool ro_param = in_param && !Address_Taken (gnat_param);
5070 bool by_return = false, by_component_ptr = false, by_ref = false;
5073 /* Copy-return is used only for the first parameter of a valued procedure.
5074 It's a copy mechanism for which a parameter is never allocated. */
5075 if (mech == By_Copy_Return)
5077 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5082 /* If this is either a foreign function or if the underlying type won't
5083 be passed by reference, strip off possible padding type. */
5084 if (TYPE_IS_PADDING_P (gnu_param_type))
5086 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5088 if (mech == By_Reference
5090 || (!must_pass_by_ref (unpadded_type)
5091 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5092 gnu_param_type = unpadded_type;
5095 /* If this is a read-only parameter, make a variant of the type that is
5096 read-only. ??? However, if this is an unconstrained array, that type
5097 can be very complex, so skip it for now. Likewise for any other
5098 self-referential type. */
5100 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5101 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5102 gnu_param_type = build_qualified_type (gnu_param_type,
5103 (TYPE_QUALS (gnu_param_type)
5104 | TYPE_QUAL_CONST));
5106 /* For foreign conventions, pass arrays as pointers to the element type.
5107 First check for unconstrained array and get the underlying array. */
5108 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5110 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5112 /* VMS descriptors are themselves passed by reference. */
5113 if (mech == By_Short_Descriptor ||
5114 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5116 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5117 Mechanism (gnat_param),
5119 else if (mech == By_Descriptor)
5121 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5122 chosen in fill_vms_descriptor. */
5124 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5125 Mechanism (gnat_param),
5128 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5129 Mechanism (gnat_param),
5133 /* Arrays are passed as pointers to element type for foreign conventions. */
5136 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5138 /* Strip off any multi-dimensional entries, then strip
5139 off the last array to get the component type. */
5140 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5141 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5142 gnu_param_type = TREE_TYPE (gnu_param_type);
5144 by_component_ptr = true;
5145 gnu_param_type = TREE_TYPE (gnu_param_type);
5148 gnu_param_type = build_qualified_type (gnu_param_type,
5149 (TYPE_QUALS (gnu_param_type)
5150 | TYPE_QUAL_CONST));
5152 gnu_param_type = build_pointer_type (gnu_param_type);
5155 /* Fat pointers are passed as thin pointers for foreign conventions. */
5156 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5158 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5160 /* If we must pass or were requested to pass by reference, do so.
5161 If we were requested to pass by copy, do so.
5162 Otherwise, for foreign conventions, pass In Out or Out parameters
5163 or aggregates by reference. For COBOL and Fortran, pass all
5164 integer and FP types that way too. For Convention Ada, use
5165 the standard Ada default. */
5166 else if (must_pass_by_ref (gnu_param_type)
5167 || mech == By_Reference
5170 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5172 && (Convention (gnat_subprog) == Convention_Fortran
5173 || Convention (gnat_subprog) == Convention_COBOL)
5174 && (INTEGRAL_TYPE_P (gnu_param_type)
5175 || FLOAT_TYPE_P (gnu_param_type)))
5177 && default_pass_by_ref (gnu_param_type)))))
5179 gnu_param_type = build_reference_type (gnu_param_type);
5183 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5187 if (mech == By_Copy && (by_ref || by_component_ptr))
5188 post_error ("?cannot pass & by copy", gnat_param);
5190 /* If this is an Out parameter that isn't passed by reference and isn't
5191 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5192 it will be a VAR_DECL created when we process the procedure, so just
5193 return its type. For the special parameter of a valued procedure,
5196 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5197 Out parameters with discriminants or implicit initial values to be
5198 handled like In Out parameters. These type are normally built as
5199 aggregates, hence passed by reference, except for some packed arrays
5200 which end up encoded in special integer types.
5202 The exception we need to make is then for packed arrays of records
5203 with discriminants or implicit initial values. We have no light/easy
5204 way to check for the latter case, so we merely check for packed arrays
5205 of records. This may lead to useless copy-in operations, but in very
5206 rare cases only, as these would be exceptions in a set of already
5207 exceptional situations. */
5208 if (Ekind (gnat_param) == E_Out_Parameter
5211 || (mech != By_Descriptor
5212 && mech != By_Short_Descriptor
5213 && !POINTER_TYPE_P (gnu_param_type)
5214 && !AGGREGATE_TYPE_P (gnu_param_type)))
5215 && !(Is_Array_Type (Etype (gnat_param))
5216 && Is_Packed (Etype (gnat_param))
5217 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5218 return gnu_param_type;
5220 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5221 ro_param || by_ref || by_component_ptr);
5222 DECL_BY_REF_P (gnu_param) = by_ref;
5223 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5224 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5225 mech == By_Short_Descriptor);
5226 DECL_POINTS_TO_READONLY_P (gnu_param)
5227 = (ro_param && (by_ref || by_component_ptr));
5229 /* Save the alternate descriptor type, if any. */
5230 if (gnu_param_type_alt)
5231 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5233 /* If no Mechanism was specified, indicate what we're using, then
5234 back-annotate it. */
5235 if (mech == Default)
5236 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5238 Set_Mechanism (gnat_param, mech);
5242 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5245 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5247 while (Present (Corresponding_Discriminant (discr1)))
5248 discr1 = Corresponding_Discriminant (discr1);
5250 while (Present (Corresponding_Discriminant (discr2)))
5251 discr2 = Corresponding_Discriminant (discr2);
5254 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5257 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
5258 a non-aliased component in the back-end sense. */
5261 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
5263 /* If the type below this is a multi-array type, then
5264 this does not have aliased components. */
5265 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5266 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5269 if (Has_Aliased_Components (gnat_type))
5272 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5275 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5278 compile_time_known_address_p (Node_Id gnat_address)
5280 /* Catch System'To_Address. */
5281 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5282 gnat_address = Expression (gnat_address);
5284 return Compile_Time_Known_Value (gnat_address);
5287 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e.
5288 cannot verify HB < LB-1 when LB and HB are the low and high bounds. */
5291 cannot_be_superflat_p (Node_Id gnat_range)
5293 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5294 Node_Id scalar_range;
5296 tree gnu_lb, gnu_hb;
5298 /* If the low bound is not constant, try to find an upper bound. */
5299 while (Nkind (gnat_lb) != N_Integer_Literal
5300 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5301 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5302 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5303 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5304 || Nkind (scalar_range) == N_Range))
5305 gnat_lb = High_Bound (scalar_range);
5307 /* If the high bound is not constant, try to find a lower bound. */
5308 while (Nkind (gnat_hb) != N_Integer_Literal
5309 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5310 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5311 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5312 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5313 || Nkind (scalar_range) == N_Range))
5314 gnat_hb = Low_Bound (scalar_range);
5316 if (!(Nkind (gnat_lb) == N_Integer_Literal
5317 && Nkind (gnat_hb) == N_Integer_Literal))
5320 gnu_lb = UI_To_gnu (Intval (gnat_lb), bitsizetype);
5321 gnu_hb = UI_To_gnu (Intval (gnat_hb), bitsizetype);
5323 /* If the low bound is the smallest integer, nothing can be smaller. */
5324 gnu_lb = size_binop (MINUS_EXPR, gnu_lb, bitsize_one_node);
5325 if (TREE_OVERFLOW (gnu_lb))
5328 return (tree_int_cst_lt (gnu_hb, gnu_lb) == 0);
5331 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5332 be elaborated at the point of its definition, but do nothing else. */
5335 elaborate_entity (Entity_Id gnat_entity)
5337 switch (Ekind (gnat_entity))
5339 case E_Signed_Integer_Subtype:
5340 case E_Modular_Integer_Subtype:
5341 case E_Enumeration_Subtype:
5342 case E_Ordinary_Fixed_Point_Subtype:
5343 case E_Decimal_Fixed_Point_Subtype:
5344 case E_Floating_Point_Subtype:
5346 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5347 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5349 /* ??? Tests to avoid Constraint_Error in static expressions
5350 are needed until after the front stops generating bogus
5351 conversions on bounds of real types. */
5352 if (!Raises_Constraint_Error (gnat_lb))
5353 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5354 true, false, Needs_Debug_Info (gnat_entity));
5355 if (!Raises_Constraint_Error (gnat_hb))
5356 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5357 true, false, Needs_Debug_Info (gnat_entity));
5363 Node_Id full_definition = Declaration_Node (gnat_entity);
5364 Node_Id record_definition = Type_Definition (full_definition);
5366 /* If this is a record extension, go a level further to find the
5367 record definition. */
5368 if (Nkind (record_definition) == N_Derived_Type_Definition)
5369 record_definition = Record_Extension_Part (record_definition);
5373 case E_Record_Subtype:
5374 case E_Private_Subtype:
5375 case E_Limited_Private_Subtype:
5376 case E_Record_Subtype_With_Private:
5377 if (Is_Constrained (gnat_entity)
5378 && Has_Discriminants (gnat_entity)
5379 && Present (Discriminant_Constraint (gnat_entity)))
5381 Node_Id gnat_discriminant_expr;
5382 Entity_Id gnat_field;
5385 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5386 gnat_discriminant_expr
5387 = First_Elmt (Discriminant_Constraint (gnat_entity));
5388 Present (gnat_field);
5389 gnat_field = Next_Discriminant (gnat_field),
5390 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5391 /* ??? For now, ignore access discriminants. */
5392 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5393 elaborate_expression (Node (gnat_discriminant_expr),
5394 gnat_entity, get_entity_name (gnat_field),
5395 true, false, false);
5402 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5403 any entities on its entity chain similarly. */
5406 mark_out_of_scope (Entity_Id gnat_entity)
5408 Entity_Id gnat_sub_entity;
5409 unsigned int kind = Ekind (gnat_entity);
5411 /* If this has an entity list, process all in the list. */
5412 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5413 || IN (kind, Private_Kind)
5414 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5415 || kind == E_Function || kind == E_Generic_Function
5416 || kind == E_Generic_Package || kind == E_Generic_Procedure
5417 || kind == E_Loop || kind == E_Operator || kind == E_Package
5418 || kind == E_Package_Body || kind == E_Procedure
5419 || kind == E_Record_Type || kind == E_Record_Subtype
5420 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5421 for (gnat_sub_entity = First_Entity (gnat_entity);
5422 Present (gnat_sub_entity);
5423 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5424 if (Scope (gnat_sub_entity) == gnat_entity
5425 && gnat_sub_entity != gnat_entity)
5426 mark_out_of_scope (gnat_sub_entity);
5428 /* Now clear this if it has been defined, but only do so if it isn't
5429 a subprogram or parameter. We could refine this, but it isn't
5430 worth it. If this is statically allocated, it is supposed to
5431 hang around out of cope. */
5432 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5433 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5435 save_gnu_tree (gnat_entity, NULL_TREE, true);
5436 save_gnu_tree (gnat_entity, error_mark_node, true);
5440 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5441 If this is a multi-dimensional array type, do this recursively.
5444 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5445 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5446 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5449 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5451 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5452 of a one-dimensional array, since the padding has the same alias set
5453 as the field type, but if it's a multi-dimensional array, we need to
5454 see the inner types. */
5455 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5456 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5457 || TYPE_PADDING_P (gnu_old_type)))
5458 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5460 /* Unconstrained array types are deemed incomplete and would thus be given
5461 alias set 0. Retrieve the underlying array type. */
5462 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5464 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5465 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5467 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5469 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5470 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5471 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5472 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5476 case ALIAS_SET_COPY:
5477 /* The alias set shouldn't be copied between array types with different
5478 aliasing settings because this can break the aliasing relationship
5479 between the array type and its element type. */
5480 #ifndef ENABLE_CHECKING
5481 if (flag_strict_aliasing)
5483 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5484 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5485 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5486 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5488 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5491 case ALIAS_SET_SUBSET:
5492 case ALIAS_SET_SUPERSET:
5494 alias_set_type old_set = get_alias_set (gnu_old_type);
5495 alias_set_type new_set = get_alias_set (gnu_new_type);
5497 /* Do nothing if the alias sets conflict. This ensures that we
5498 never call record_alias_subset several times for the same pair
5499 or at all for alias set 0. */
5500 if (!alias_sets_conflict_p (old_set, new_set))
5502 if (op == ALIAS_SET_SUBSET)
5503 record_alias_subset (old_set, new_set);
5505 record_alias_subset (new_set, old_set);
5514 record_component_aliases (gnu_new_type);
5517 /* Return true if the size represented by GNU_SIZE can be handled by an
5518 allocation. If STATIC_P is true, consider only what can be done with a
5519 static allocation. */
5522 allocatable_size_p (tree gnu_size, bool static_p)
5524 HOST_WIDE_INT our_size;
5526 /* If this is not a static allocation, the only case we want to forbid
5527 is an overflowing size. That will be converted into a raise a
5530 return !(TREE_CODE (gnu_size) == INTEGER_CST
5531 && TREE_OVERFLOW (gnu_size));
5533 /* Otherwise, we need to deal with both variable sizes and constant
5534 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5535 since assemblers may not like very large sizes. */
5536 if (!host_integerp (gnu_size, 1))
5539 our_size = tree_low_cst (gnu_size, 1);
5540 return (int) our_size == our_size;
5543 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5544 NAME, ARGS and ERROR_POINT. */
5547 prepend_one_attribute_to (struct attrib ** attr_list,
5548 enum attr_type attr_type,
5551 Node_Id attr_error_point)
5553 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5555 attr->type = attr_type;
5556 attr->name = attr_name;
5557 attr->args = attr_args;
5558 attr->error_point = attr_error_point;
5560 attr->next = *attr_list;
5564 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5567 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5571 /* Attributes are stored as Representation Item pragmas. */
5573 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5574 gnat_temp = Next_Rep_Item (gnat_temp))
5575 if (Nkind (gnat_temp) == N_Pragma)
5577 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5578 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5579 enum attr_type etype;
5581 /* Map the kind of pragma at hand. Skip if this is not one
5582 we know how to handle. */
5584 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5586 case Pragma_Machine_Attribute:
5587 etype = ATTR_MACHINE_ATTRIBUTE;
5590 case Pragma_Linker_Alias:
5591 etype = ATTR_LINK_ALIAS;
5594 case Pragma_Linker_Section:
5595 etype = ATTR_LINK_SECTION;
5598 case Pragma_Linker_Constructor:
5599 etype = ATTR_LINK_CONSTRUCTOR;
5602 case Pragma_Linker_Destructor:
5603 etype = ATTR_LINK_DESTRUCTOR;
5606 case Pragma_Weak_External:
5607 etype = ATTR_WEAK_EXTERNAL;
5610 case Pragma_Thread_Local_Storage:
5611 etype = ATTR_THREAD_LOCAL_STORAGE;
5618 /* See what arguments we have and turn them into GCC trees for
5619 attribute handlers. These expect identifier for strings. We
5620 handle at most two arguments, static expressions only. */
5622 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5624 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5625 Node_Id gnat_arg1 = Empty;
5627 if (Present (gnat_arg0)
5628 && Is_Static_Expression (Expression (gnat_arg0)))
5630 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5632 if (TREE_CODE (gnu_arg0) == STRING_CST)
5633 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5635 gnat_arg1 = Next (gnat_arg0);
5638 if (Present (gnat_arg1)
5639 && Is_Static_Expression (Expression (gnat_arg1)))
5641 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5643 if (TREE_CODE (gnu_arg1) == STRING_CST)
5644 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
5648 /* Prepend to the list now. Make a list of the argument we might
5649 have, as GCC expects it. */
5650 prepend_one_attribute_to
5653 (gnu_arg1 != NULL_TREE)
5654 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5655 Present (Next (First (gnat_assoc)))
5656 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5660 /* Called when we need to protect a variable object using a SAVE_EXPR. */
5663 maybe_variable (tree gnu_operand)
5665 if (TREE_CONSTANT (gnu_operand)
5666 || TREE_READONLY (gnu_operand)
5667 || TREE_CODE (gnu_operand) == SAVE_EXPR
5668 || TREE_CODE (gnu_operand) == NULL_EXPR)
5671 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5674 = build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
5675 variable_size (TREE_OPERAND (gnu_operand, 0)));
5677 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5678 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5682 return variable_size (gnu_operand);
5685 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5686 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5687 return the GCC tree to use for that expression. GNU_NAME is the suffix
5688 to use if a variable needs to be created and DEFINITION is true if this
5689 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
5690 otherwise, we are just elaborating the expression for side-effects. If
5691 NEED_DEBUG is true, we need a variable for debugging purposes even if it
5692 isn't needed for code generation. */
5695 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
5696 bool definition, bool need_value, bool need_debug)
5700 /* If we already elaborated this expression (e.g. it was involved
5701 in the definition of a private type), use the old value. */
5702 if (present_gnu_tree (gnat_expr))
5703 return get_gnu_tree (gnat_expr);
5705 /* If we don't need a value and this is static or a discriminant,
5706 we don't need to do anything. */
5708 && (Is_OK_Static_Expression (gnat_expr)
5709 || (Nkind (gnat_expr) == N_Identifier
5710 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5713 /* If it's a static expression, we don't need a variable for debugging. */
5714 if (need_debug && Is_OK_Static_Expression (gnat_expr))
5717 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
5718 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
5719 gnu_name, definition, need_debug);
5721 /* Save the expression in case we try to elaborate this entity again. Since
5722 it's not a DECL, don't check it. Don't save if it's a discriminant. */
5723 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5724 save_gnu_tree (gnat_expr, gnu_expr, true);
5726 return need_value ? gnu_expr : error_mark_node;
5729 /* Similar, but take a GNU expression and always return a result. */
5732 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
5733 bool definition, bool need_debug)
5735 /* Skip any conversions and simple arithmetics to see if the expression
5736 is a read-only variable.
5737 ??? This really should remain read-only, but we have to think about
5738 the typing of the tree here. */
5740 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5741 tree gnu_decl = NULL_TREE;
5742 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5745 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
5746 reference will have been replaced with a COMPONENT_REF when the type
5747 is being elaborated. However, there are some cases involving child
5748 types where we will. So convert it to a COMPONENT_REF. We hope it
5749 will be at the highest level of the expression in these cases. */
5750 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5751 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5752 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5753 gnu_expr, NULL_TREE);
5755 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5756 that is read-only, make a variable that is initialized to contain the
5757 bound when the package containing the definition is elaborated. If
5758 this entity is defined at top level and a bound or discriminant value
5759 isn't a constant or a reference to a discriminant, replace the bound
5760 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5761 rely here on the fact that an expression cannot contain both the
5762 discriminant and some other variable. */
5763 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5764 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5765 && (TREE_READONLY (gnu_inner_expr)
5766 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5767 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5769 /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */
5770 if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
5773 /* Now create the variable if we need it. */
5774 if (need_debug || (expr_variable && expr_global))
5776 = create_var_decl (create_concat_name (gnat_entity,
5777 IDENTIFIER_POINTER (gnu_name)),
5778 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5779 !need_debug, Is_Public (gnat_entity),
5780 !definition, false, NULL, gnat_entity);
5782 /* We only need to use this variable if we are in global context since GCC
5783 can do the right thing in the local case. */
5784 if (expr_global && expr_variable)
5787 return expr_variable ? maybe_variable (gnu_expr) : gnu_expr;
5790 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5791 starting bit position so that it is aligned to ALIGN bits, and leaving at
5792 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5793 record is guaranteed to get. */
5796 make_aligning_type (tree type, unsigned int align, tree size,
5797 unsigned int base_align, int room)
5799 /* We will be crafting a record type with one field at a position set to be
5800 the next multiple of ALIGN past record'address + room bytes. We use a
5801 record placeholder to express record'address. */
5803 tree record_type = make_node (RECORD_TYPE);
5804 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5807 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5809 /* The diagram below summarizes the shape of what we manipulate:
5811 <--------- pos ---------->
5812 { +------------+-------------+-----------------+
5813 record =>{ |############| ... | field (type) |
5814 { +------------+-------------+-----------------+
5815 |<-- room -->|<- voffset ->|<---- size ----->|
5818 record_addr vblock_addr
5820 Every length is in sizetype bytes there, except "pos" which has to be
5821 set as a bit position in the GCC tree for the record. */
5823 tree room_st = size_int (room);
5824 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5825 tree voffset_st, pos, field;
5827 tree name = TYPE_NAME (type);
5829 if (TREE_CODE (name) == TYPE_DECL)
5830 name = DECL_NAME (name);
5832 TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
5834 /* Compute VOFFSET and then POS. The next byte position multiple of some
5835 alignment after some address is obtained by "and"ing the alignment minus
5836 1 with the two's complement of the address. */
5838 voffset_st = size_binop (BIT_AND_EXPR,
5839 size_diffop (size_zero_node, vblock_addr_st),
5840 ssize_int ((align / BITS_PER_UNIT) - 1));
5842 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5844 pos = size_binop (MULT_EXPR,
5845 convert (bitsizetype,
5846 size_binop (PLUS_EXPR, room_st, voffset_st)),
5849 /* Craft the GCC record representation. We exceptionally do everything
5850 manually here because 1) our generic circuitry is not quite ready to
5851 handle the complex position/size expressions we are setting up, 2) we
5852 have a strong simplifying factor at hand: we know the maximum possible
5853 value of voffset, and 3) we have to set/reset at least the sizes in
5854 accordance with this maximum value anyway, as we need them to convey
5855 what should be "alloc"ated for this type.
5857 Use -1 as the 'addressable' indication for the field to prevent the
5858 creation of a bitfield. We don't need one, it would have damaging
5859 consequences on the alignment computation, and create_field_decl would
5860 make one without this special argument, for instance because of the
5861 complex position expression. */
5863 field = create_field_decl (get_identifier ("F"), type, record_type,
5865 TYPE_FIELDS (record_type) = field;
5867 TYPE_ALIGN (record_type) = base_align;
5868 TYPE_USER_ALIGN (record_type) = 1;
5870 TYPE_SIZE (record_type)
5871 = size_binop (PLUS_EXPR,
5872 size_binop (MULT_EXPR, convert (bitsizetype, size),
5874 bitsize_int (align + room * BITS_PER_UNIT));
5875 TYPE_SIZE_UNIT (record_type)
5876 = size_binop (PLUS_EXPR, size,
5877 size_int (room + align / BITS_PER_UNIT));
5879 SET_TYPE_MODE (record_type, BLKmode);
5881 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
5885 /* Return the result of rounding T up to ALIGN. */
5887 static inline unsigned HOST_WIDE_INT
5888 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5896 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5897 as the field type of a packed record if IN_RECORD is true, or as the
5898 component type of a packed array if IN_RECORD is false. See if we can
5899 rewrite it either as a type that has a non-BLKmode, which we can pack
5900 tighter in the packed record case, or as a smaller type. If so, return
5901 the new type. If not, return the original type. */
5904 make_packable_type (tree type, bool in_record)
5906 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5907 unsigned HOST_WIDE_INT new_size;
5908 tree new_type, old_field, field_list = NULL_TREE;
5910 /* No point in doing anything if the size is zero. */
5914 new_type = make_node (TREE_CODE (type));
5916 /* Copy the name and flags from the old type to that of the new.
5917 Note that we rely on the pointer equality created here for
5918 TYPE_NAME to look through conversions in various places. */
5919 TYPE_NAME (new_type) = TYPE_NAME (type);
5920 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5921 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5922 if (TREE_CODE (type) == RECORD_TYPE)
5923 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
5925 /* If we are in a record and have a small size, set the alignment to
5926 try for an integral mode. Otherwise set it to try for a smaller
5927 type with BLKmode. */
5928 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5930 TYPE_ALIGN (new_type) = ceil_alignment (size);
5931 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5935 unsigned HOST_WIDE_INT align;
5937 /* Do not try to shrink the size if the RM size is not constant. */
5938 if (TYPE_CONTAINS_TEMPLATE_P (type)
5939 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5942 /* Round the RM size up to a unit boundary to get the minimal size
5943 for a BLKmode record. Give up if it's already the size. */
5944 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5945 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5946 if (new_size == size)
5949 align = new_size & -new_size;
5950 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5953 TYPE_USER_ALIGN (new_type) = 1;
5955 /* Now copy the fields, keeping the position and size as we don't want
5956 to change the layout by propagating the packedness downwards. */
5957 for (old_field = TYPE_FIELDS (type); old_field;
5958 old_field = TREE_CHAIN (old_field))
5960 tree new_field_type = TREE_TYPE (old_field);
5961 tree new_field, new_size;
5963 if ((TREE_CODE (new_field_type) == RECORD_TYPE
5964 || TREE_CODE (new_field_type) == UNION_TYPE
5965 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5966 && !TYPE_FAT_POINTER_P (new_field_type)
5967 && host_integerp (TYPE_SIZE (new_field_type), 1))
5968 new_field_type = make_packable_type (new_field_type, true);
5970 /* However, for the last field in a not already packed record type
5971 that is of an aggregate type, we need to use the RM size in the
5972 packable version of the record type, see finish_record_type. */
5973 if (!TREE_CHAIN (old_field)
5974 && !TYPE_PACKED (type)
5975 && (TREE_CODE (new_field_type) == RECORD_TYPE
5976 || TREE_CODE (new_field_type) == UNION_TYPE
5977 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5978 && !TYPE_FAT_POINTER_P (new_field_type)
5979 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5980 && TYPE_ADA_SIZE (new_field_type))
5981 new_size = TYPE_ADA_SIZE (new_field_type);
5983 new_size = DECL_SIZE (old_field);
5985 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5986 new_type, TYPE_PACKED (type), new_size,
5987 bit_position (old_field),
5988 !DECL_NONADDRESSABLE_P (old_field));
5990 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5991 SET_DECL_ORIGINAL_FIELD
5992 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5993 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5995 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5996 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5998 TREE_CHAIN (new_field) = field_list;
5999 field_list = new_field;
6002 finish_record_type (new_type, nreverse (field_list), 2, true);
6003 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6005 /* If this is a padding record, we never want to make the size smaller
6006 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6007 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6009 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6010 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6014 TYPE_SIZE (new_type) = bitsize_int (new_size);
6015 TYPE_SIZE_UNIT (new_type)
6016 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6019 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6020 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6022 compute_record_mode (new_type);
6024 /* Try harder to get a packable type if necessary, for example
6025 in case the record itself contains a BLKmode field. */
6026 if (in_record && TYPE_MODE (new_type) == BLKmode)
6027 SET_TYPE_MODE (new_type,
6028 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6030 /* If neither the mode nor the size has shrunk, return the old type. */
6031 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6037 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6038 if needed. We have already verified that SIZE and TYPE are large enough.
6039 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6040 IS_COMPONENT_TYPE is true if this is being done for the component type
6041 of an array. IS_USER_TYPE is true if we must complete the original type.
6042 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6043 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6044 it's set to the RM size of the original type. */
6047 maybe_pad_type (tree type, tree size, unsigned int align,
6048 Entity_Id gnat_entity, bool is_component_type,
6049 bool is_user_type, bool definition, bool same_rm_size)
6051 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6052 tree orig_size = TYPE_SIZE (type);
6055 /* If TYPE is a padded type, see if it agrees with any size and alignment
6056 we were given. If so, return the original type. Otherwise, strip
6057 off the padding, since we will either be returning the inner type
6058 or repadding it. If no size or alignment is specified, use that of
6059 the original padded type. */
6060 if (TYPE_IS_PADDING_P (type))
6063 || operand_equal_p (round_up (size,
6064 MAX (align, TYPE_ALIGN (type))),
6065 round_up (TYPE_SIZE (type),
6066 MAX (align, TYPE_ALIGN (type))),
6068 && (align == 0 || align == TYPE_ALIGN (type)))
6072 size = TYPE_SIZE (type);
6074 align = TYPE_ALIGN (type);
6076 type = TREE_TYPE (TYPE_FIELDS (type));
6077 orig_size = TYPE_SIZE (type);
6080 /* If the size is either not being changed or is being made smaller (which
6081 is not done here and is only valid for bitfields anyway), show the size
6082 isn't changing. Likewise, clear the alignment if it isn't being
6083 changed. Then return if we aren't doing anything. */
6085 && (operand_equal_p (size, orig_size, 0)
6086 || (TREE_CODE (orig_size) == INTEGER_CST
6087 && tree_int_cst_lt (size, orig_size))))
6090 if (align == TYPE_ALIGN (type))
6093 if (align == 0 && !size)
6096 /* If requested, complete the original type and give it a name. */
6098 create_type_decl (get_entity_name (gnat_entity), type,
6099 NULL, !Comes_From_Source (gnat_entity),
6101 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6102 && DECL_IGNORED_P (TYPE_NAME (type))),
6105 /* We used to modify the record in place in some cases, but that could
6106 generate incorrect debugging information. So make a new record
6108 record = make_node (RECORD_TYPE);
6109 TYPE_PADDING_P (record) = 1;
6111 if (Present (gnat_entity))
6112 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6114 TYPE_VOLATILE (record)
6115 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6117 TYPE_ALIGN (record) = align;
6118 TYPE_SIZE (record) = size ? size : orig_size;
6119 TYPE_SIZE_UNIT (record)
6120 = convert (sizetype,
6121 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6122 bitsize_unit_node));
6124 /* If we are changing the alignment and the input type is a record with
6125 BLKmode and a small constant size, try to make a form that has an
6126 integral mode. This might allow the padding record to also have an
6127 integral mode, which will be much more efficient. There is no point
6128 in doing so if a size is specified unless it is also a small constant
6129 size and it is incorrect to do so if we cannot guarantee that the mode
6130 will be naturally aligned since the field must always be addressable.
6132 ??? This might not always be a win when done for a stand-alone object:
6133 since the nominal and the effective type of the object will now have
6134 different modes, a VIEW_CONVERT_EXPR will be required for converting
6135 between them and it might be hard to overcome afterwards, including
6136 at the RTL level when the stand-alone object is accessed as a whole. */
6138 && TREE_CODE (type) == RECORD_TYPE
6139 && TYPE_MODE (type) == BLKmode
6140 && TREE_CODE (orig_size) == INTEGER_CST
6141 && !TREE_OVERFLOW (orig_size)
6142 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6144 || (TREE_CODE (size) == INTEGER_CST
6145 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6147 tree packable_type = make_packable_type (type, true);
6148 if (TYPE_MODE (packable_type) != BLKmode
6149 && align >= TYPE_ALIGN (packable_type))
6150 type = packable_type;
6153 /* Now create the field with the original size. */
6154 field = create_field_decl (get_identifier ("F"), type, record, 0,
6155 orig_size, bitsize_zero_node, 1);
6156 DECL_INTERNAL_P (field) = 1;
6158 /* Do not finalize it until after the auxiliary record is built. */
6159 finish_record_type (record, field, 1, true);
6161 /* Set the same size for its RM size if requested; otherwise reuse
6162 the RM size of the original type. */
6163 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6165 /* Unless debugging information isn't being written for the input type,
6166 write a record that shows what we are a subtype of and also make a
6167 variable that indicates our size, if still variable. */
6168 if (TYPE_NAME (record)
6169 && AGGREGATE_TYPE_P (type)
6170 && TREE_CODE (orig_size) != INTEGER_CST
6171 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6172 && DECL_IGNORED_P (TYPE_NAME (type))))
6174 tree marker = make_node (RECORD_TYPE);
6175 tree name = TYPE_NAME (record);
6176 tree orig_name = TYPE_NAME (type);
6178 if (TREE_CODE (name) == TYPE_DECL)
6179 name = DECL_NAME (name);
6181 if (TREE_CODE (orig_name) == TYPE_DECL)
6182 orig_name = DECL_NAME (orig_name);
6184 TYPE_NAME (marker) = concat_name (name, "XVS");
6185 finish_record_type (marker,
6186 create_field_decl (orig_name,
6187 build_reference_type (type),
6188 marker, 0, NULL_TREE, NULL_TREE,
6192 add_parallel_type (TYPE_STUB_DECL (record), marker);
6194 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6195 create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6196 TYPE_SIZE_UNIT (record), false, false, false,
6197 false, NULL, gnat_entity);
6200 rest_of_record_type_compilation (record);
6202 /* If the size was widened explicitly, maybe give a warning. Take the
6203 original size as the maximum size of the input if there was an
6204 unconstrained record involved and round it up to the specified alignment,
6205 if one was specified. */
6206 if (CONTAINS_PLACEHOLDER_P (orig_size))
6207 orig_size = max_size (orig_size, true);
6210 orig_size = round_up (orig_size, align);
6212 if (Present (gnat_entity)
6214 && TREE_CODE (size) != MAX_EXPR
6215 && !operand_equal_p (size, orig_size, 0)
6216 && !(TREE_CODE (size) == INTEGER_CST
6217 && TREE_CODE (orig_size) == INTEGER_CST
6218 && tree_int_cst_lt (size, orig_size)))
6220 Node_Id gnat_error_node = Empty;
6222 if (Is_Packed_Array_Type (gnat_entity))
6223 gnat_entity = Original_Array_Type (gnat_entity);
6225 if ((Ekind (gnat_entity) == E_Component
6226 || Ekind (gnat_entity) == E_Discriminant)
6227 && Present (Component_Clause (gnat_entity)))
6228 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6229 else if (Present (Size_Clause (gnat_entity)))
6230 gnat_error_node = Expression (Size_Clause (gnat_entity));
6232 /* Generate message only for entities that come from source, since
6233 if we have an entity created by expansion, the message will be
6234 generated for some other corresponding source entity. */
6235 if (Comes_From_Source (gnat_entity))
6237 if (Present (gnat_error_node))
6238 post_error_ne_tree ("{^ }bits of & unused?",
6239 gnat_error_node, gnat_entity,
6240 size_diffop (size, orig_size));
6241 else if (is_component_type)
6242 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6243 gnat_entity, gnat_entity,
6244 size_diffop (size, orig_size));
6251 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6252 the value passed against the list of choices. */
6255 choices_to_gnu (tree operand, Node_Id choices)
6259 tree result = integer_zero_node;
6260 tree this_test, low = 0, high = 0, single = 0;
6262 for (choice = First (choices); Present (choice); choice = Next (choice))
6264 switch (Nkind (choice))
6267 low = gnat_to_gnu (Low_Bound (choice));
6268 high = gnat_to_gnu (High_Bound (choice));
6270 /* There's no good type to use here, so we might as well use
6271 integer_type_node. */
6273 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6274 build_binary_op (GE_EXPR, integer_type_node,
6276 build_binary_op (LE_EXPR, integer_type_node,
6281 case N_Subtype_Indication:
6282 gnat_temp = Range_Expression (Constraint (choice));
6283 low = gnat_to_gnu (Low_Bound (gnat_temp));
6284 high = gnat_to_gnu (High_Bound (gnat_temp));
6287 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6288 build_binary_op (GE_EXPR, integer_type_node,
6290 build_binary_op (LE_EXPR, integer_type_node,
6295 case N_Expanded_Name:
6296 /* This represents either a subtype range, an enumeration
6297 literal, or a constant Ekind says which. If an enumeration
6298 literal or constant, fall through to the next case. */
6299 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6300 && Ekind (Entity (choice)) != E_Constant)
6302 tree type = gnat_to_gnu_type (Entity (choice));
6304 low = TYPE_MIN_VALUE (type);
6305 high = TYPE_MAX_VALUE (type);
6308 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6309 build_binary_op (GE_EXPR, integer_type_node,
6311 build_binary_op (LE_EXPR, integer_type_node,
6316 /* ... fall through ... */
6318 case N_Character_Literal:
6319 case N_Integer_Literal:
6320 single = gnat_to_gnu (choice);
6321 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
6325 case N_Others_Choice:
6326 this_test = integer_one_node;
6333 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6340 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6341 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6344 adjust_packed (tree field_type, tree record_type, int packed)
6346 /* If the field contains an item of variable size, we cannot pack it
6347 because we cannot create temporaries of non-fixed size in case
6348 we need to take the address of the field. See addressable_p and
6349 the notes on the addressability issues for further details. */
6350 if (is_variable_size (field_type))
6353 /* If the alignment of the record is specified and the field type
6354 is over-aligned, request Storage_Unit alignment for the field. */
6357 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6366 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6367 placed in GNU_RECORD_TYPE.
6369 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6370 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6371 record has a specified alignment.
6373 DEFINITION is true if this field is for a record being defined.
6375 DEBUG_INFO_P is true if we need to write debug information for types
6376 that we may create in the process. */
6379 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6380 bool definition, bool debug_info_p)
6382 tree gnu_field_id = get_entity_name (gnat_field);
6383 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6384 tree gnu_field, gnu_size, gnu_pos;
6385 bool needs_strict_alignment
6386 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6387 || Treat_As_Volatile (gnat_field));
6389 /* If this field requires strict alignment, we cannot pack it because
6390 it would very likely be under-aligned in the record. */
6391 if (needs_strict_alignment)
6394 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6396 /* If a size is specified, use it. Otherwise, if the record type is packed,
6397 use the official RM size. See "Handling of Type'Size Values" in Einfo
6398 for further details. */
6399 if (Known_Static_Esize (gnat_field))
6400 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6401 gnat_field, FIELD_DECL, false, true);
6402 else if (packed == 1)
6403 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6404 gnat_field, FIELD_DECL, false, true);
6406 gnu_size = NULL_TREE;
6408 /* If we have a specified size that's smaller than that of the field type,
6409 or a position is specified, and the field type is a record, see if we can
6410 get either an integral mode form of the type or a smaller form. If we
6411 can, show a size was specified for the field if there wasn't one already,
6412 so we know to make this a bitfield and avoid making things wider.
6414 Doing this is first useful if the record is packed because we may then
6415 place the field at a non-byte-aligned position and so achieve tighter
6418 This is in addition *required* if the field shares a byte with another
6419 field and the front-end lets the back-end handle the references, because
6420 GCC does not handle BLKmode bitfields properly.
6422 We avoid the transformation if it is not required or potentially useful,
6423 as it might entail an increase of the field's alignment and have ripple
6424 effects on the outer record type. A typical case is a field known to be
6425 byte aligned and not to share a byte with another field.
6427 Besides, we don't even look the possibility of a transformation in cases
6428 known to be in error already, for instance when an invalid size results
6429 from a component clause. */
6431 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6432 && !TYPE_FAT_POINTER_P (gnu_field_type)
6433 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6436 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6437 || Present (Component_Clause (gnat_field))))))
6439 /* See what the alternate type and size would be. */
6440 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6442 bool has_byte_aligned_clause
6443 = Present (Component_Clause (gnat_field))
6444 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6445 % BITS_PER_UNIT == 0);
6447 /* Compute whether we should avoid the substitution. */
6449 /* There is no point substituting if there is no change... */
6450 = (gnu_packable_type == gnu_field_type)
6451 /* ... nor when the field is known to be byte aligned and not to
6452 share a byte with another field. */
6453 || (has_byte_aligned_clause
6454 && value_factor_p (gnu_size, BITS_PER_UNIT))
6455 /* The size of an aliased field must be an exact multiple of the
6456 type's alignment, which the substitution might increase. Reject
6457 substitutions that would so invalidate a component clause when the
6458 specified position is byte aligned, as the change would have no
6459 real benefit from the packing standpoint anyway. */
6460 || (Is_Aliased (gnat_field)
6461 && has_byte_aligned_clause
6462 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6464 /* Substitute unless told otherwise. */
6467 gnu_field_type = gnu_packable_type;
6470 gnu_size = rm_size (gnu_field_type);
6474 /* If we are packing the record and the field is BLKmode, round the
6475 size up to a byte boundary. */
6476 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6477 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6479 if (Present (Component_Clause (gnat_field)))
6481 Entity_Id gnat_parent
6482 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6484 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6485 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6486 gnat_field, FIELD_DECL, false, true);
6488 /* Ensure the position does not overlap with the parent subtype, if there
6489 is one. This test is omitted if the parent of the tagged type has a
6490 full rep clause since, in this case, component clauses are allowed to
6491 overlay the space allocated for the parent type and the front-end has
6492 checked that there are no overlapping components. */
6493 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6495 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6497 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6498 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6501 ("offset of& must be beyond parent{, minimum allowed is ^}",
6502 First_Bit (Component_Clause (gnat_field)), gnat_field,
6503 TYPE_SIZE_UNIT (gnu_parent));
6507 /* If this field needs strict alignment, ensure the record is
6508 sufficiently aligned and that that position and size are
6509 consistent with the alignment. */
6510 if (needs_strict_alignment)
6512 TYPE_ALIGN (gnu_record_type)
6513 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6516 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6518 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6520 ("atomic field& must be natural size of type{ (^)}",
6521 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6522 TYPE_SIZE (gnu_field_type));
6524 else if (Is_Aliased (gnat_field))
6526 ("size of aliased field& must be ^ bits",
6527 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6528 TYPE_SIZE (gnu_field_type));
6530 else if (Strict_Alignment (Etype (gnat_field)))
6532 ("size of & with aliased or tagged components not ^ bits",
6533 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6534 TYPE_SIZE (gnu_field_type));
6536 gnu_size = NULL_TREE;
6539 if (!integer_zerop (size_binop
6540 (TRUNC_MOD_EXPR, gnu_pos,
6541 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6543 if (Is_Aliased (gnat_field))
6545 ("position of aliased field& must be multiple of ^ bits",
6546 First_Bit (Component_Clause (gnat_field)), gnat_field,
6547 TYPE_ALIGN (gnu_field_type));
6549 else if (Treat_As_Volatile (gnat_field))
6551 ("position of volatile field& must be multiple of ^ bits",
6552 First_Bit (Component_Clause (gnat_field)), gnat_field,
6553 TYPE_ALIGN (gnu_field_type));
6555 else if (Strict_Alignment (Etype (gnat_field)))
6557 ("position of & with aliased or tagged components not multiple of ^ bits",
6558 First_Bit (Component_Clause (gnat_field)), gnat_field,
6559 TYPE_ALIGN (gnu_field_type));
6564 gnu_pos = NULL_TREE;
6568 if (Is_Atomic (gnat_field))
6569 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6572 /* If the record has rep clauses and this is the tag field, make a rep
6573 clause for it as well. */
6574 else if (Has_Specified_Layout (Scope (gnat_field))
6575 && Chars (gnat_field) == Name_uTag)
6577 gnu_pos = bitsize_zero_node;
6578 gnu_size = TYPE_SIZE (gnu_field_type);
6582 gnu_pos = NULL_TREE;
6584 /* We need to make the size the maximum for the type if it is
6585 self-referential and an unconstrained type. In that case, we can't
6586 pack the field since we can't make a copy to align it. */
6587 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6589 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6590 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6592 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6596 /* If a size is specified, adjust the field's type to it. */
6599 tree orig_field_type;
6601 /* If the field's type is justified modular, we would need to remove
6602 the wrapper to (better) meet the layout requirements. However we
6603 can do so only if the field is not aliased to preserve the unique
6604 layout and if the prescribed size is not greater than that of the
6605 packed array to preserve the justification. */
6606 if (!needs_strict_alignment
6607 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6608 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6609 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6611 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6614 = make_type_from_size (gnu_field_type, gnu_size,
6615 Has_Biased_Representation (gnat_field));
6617 orig_field_type = gnu_field_type;
6618 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6619 false, false, definition, true);
6621 /* If a padding record was made, declare it now since it will never be
6622 declared otherwise. This is necessary to ensure that its subtrees
6623 are properly marked. */
6624 if (gnu_field_type != orig_field_type
6625 && !DECL_P (TYPE_NAME (gnu_field_type)))
6626 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6627 true, debug_info_p, gnat_field);
6630 /* Otherwise (or if there was an error), don't specify a position. */
6632 gnu_pos = NULL_TREE;
6634 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6635 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6637 /* Now create the decl for the field. */
6638 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6639 packed, gnu_size, gnu_pos,
6640 Is_Aliased (gnat_field));
6641 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6642 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6644 if (Ekind (gnat_field) == E_Discriminant)
6645 DECL_DISCRIMINANT_NUMBER (gnu_field)
6646 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6651 /* Return true if TYPE is a type with variable size, a padding type with a
6652 field of variable size or is a record that has a field such a field. */
6655 is_variable_size (tree type)
6659 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6662 if (TYPE_IS_PADDING_P (type)
6663 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6666 if (TREE_CODE (type) != RECORD_TYPE
6667 && TREE_CODE (type) != UNION_TYPE
6668 && TREE_CODE (type) != QUAL_UNION_TYPE)
6671 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6672 if (is_variable_size (TREE_TYPE (field)))
6678 /* qsort comparer for the bit positions of two record components. */
6681 compare_field_bitpos (const PTR rt1, const PTR rt2)
6683 const_tree const field1 = * (const_tree const *) rt1;
6684 const_tree const field2 = * (const_tree const *) rt2;
6686 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6688 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6691 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
6692 the result as the field list of GNU_RECORD_TYPE and finish it up. When
6693 called from gnat_to_gnu_entity during the processing of a record type
6694 definition, the GCC node for the parent, if any, will be the single field
6695 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6696 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6697 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6699 PACKED is 1 if this is for a packed record, -1 if this is for a record
6700 with Component_Alignment of Storage_Unit, -2 if this is for a record
6701 with a specified alignment.
6703 DEFINITION is true if we are defining this record.
6705 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6706 with a rep clause is to be added; in this case, that is all that should
6707 be done with such fields.
6709 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6710 laying out the record. This means the alignment only serves to force
6711 fields to be bitfields, but not require the record to be that aligned.
6712 This is used for variants.
6714 ALL_REP, if true, means a rep clause was found for all the fields. This
6715 simplifies the logic since we know we're not in the mixed case.
6717 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6718 modified afterwards so it will not be finalized here.
6720 UNCHECKED_UNION, if true, means that we are building a type for a record
6721 with a Pragma Unchecked_Union.
6723 DEBUG_INFO_P, if true, means that we need to write debug information for
6724 types that we may create in the process. */
6727 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
6728 tree gnu_field_list, int packed, bool definition,
6729 tree *p_gnu_rep_list, bool cancel_alignment,
6730 bool all_rep, bool do_not_finalize,
6731 bool unchecked_union, bool debug_info_p)
6733 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6734 bool layout_with_rep = false;
6735 Node_Id component_decl, variant_part;
6736 tree gnu_our_rep_list = NULL_TREE;
6737 tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
6739 /* For each component referenced in a component declaration create a GCC
6740 field and add it to the list, skipping pragmas in the GNAT list. */
6741 if (Present (Component_Items (gnat_component_list)))
6743 = First_Non_Pragma (Component_Items (gnat_component_list));
6744 Present (component_decl);
6745 component_decl = Next_Non_Pragma (component_decl))
6747 Entity_Id gnat_field = Defining_Entity (component_decl);
6748 Name_Id gnat_name = Chars (gnat_field);
6750 /* If present, the _Parent field must have been created as the single
6751 field of the record type. Put it before any other fields. */
6752 if (gnat_name == Name_uParent)
6754 gnu_field = TYPE_FIELDS (gnu_record_type);
6755 gnu_field_list = chainon (gnu_field_list, gnu_field);
6759 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
6760 definition, debug_info_p);
6762 /* If this is the _Tag field, put it before any other fields. */
6763 if (gnat_name == Name_uTag)
6764 gnu_field_list = chainon (gnu_field_list, gnu_field);
6766 /* If this is the _Controller field, put it before the other
6767 fields except for the _Tag or _Parent field. */
6768 else if (gnat_name == Name_uController && gnu_last)
6770 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
6771 TREE_CHAIN (gnu_last) = gnu_field;
6774 /* If this is a regular field, put it after the other fields. */
6777 TREE_CHAIN (gnu_field) = gnu_field_list;
6778 gnu_field_list = gnu_field;
6780 gnu_last = gnu_field;
6784 save_gnu_tree (gnat_field, gnu_field, false);
6787 /* At the end of the component list there may be a variant part. */
6788 variant_part = Variant_Part (gnat_component_list);
6790 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6791 mutually exclusive and should go in the same memory. To do this we need
6792 to treat each variant as a record whose elements are created from the
6793 component list for the variant. So here we create the records from the
6794 lists for the variants and put them all into the QUAL_UNION_TYPE.
6795 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6796 use GNU_RECORD_TYPE if there are no fields so far. */
6797 if (Present (variant_part))
6799 Node_Id gnat_discr = Name (variant_part), variant;
6800 tree gnu_discr = gnat_to_gnu (gnat_discr);
6801 tree gnu_name = TYPE_NAME (gnu_record_type);
6803 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
6805 tree gnu_union_type, gnu_union_name, gnu_union_field;
6806 tree gnu_variant_list = NULL_TREE;
6808 if (TREE_CODE (gnu_name) == TYPE_DECL)
6809 gnu_name = DECL_NAME (gnu_name);
6812 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
6814 /* Reuse an enclosing union if all fields are in the variant part
6815 and there is no representation clause on the record, to match
6816 the layout of C unions. There is an associated check below. */
6818 && TREE_CODE (gnu_record_type) == UNION_TYPE
6819 && !TYPE_PACKED (gnu_record_type))
6820 gnu_union_type = gnu_record_type;
6824 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6826 TYPE_NAME (gnu_union_type) = gnu_union_name;
6827 TYPE_ALIGN (gnu_union_type) = 0;
6828 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6831 for (variant = First_Non_Pragma (Variants (variant_part));
6833 variant = Next_Non_Pragma (variant))
6835 tree gnu_variant_type = make_node (RECORD_TYPE);
6836 tree gnu_inner_name;
6839 Get_Variant_Encoding (variant);
6840 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
6841 TYPE_NAME (gnu_variant_type)
6842 = concat_name (gnu_union_name,
6843 IDENTIFIER_POINTER (gnu_inner_name));
6845 /* Set the alignment of the inner type in case we need to make
6846 inner objects into bitfields, but then clear it out so the
6847 record actually gets only the alignment required. */
6848 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6849 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6851 /* Similarly, if the outer record has a size specified and all
6852 fields have record rep clauses, we can propagate the size
6853 into the variant part. */
6854 if (all_rep_and_size)
6856 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6857 TYPE_SIZE_UNIT (gnu_variant_type)
6858 = TYPE_SIZE_UNIT (gnu_record_type);
6861 /* Add the fields into the record type for the variant. Note that we
6862 defer finalizing it until after we are sure to really use it. */
6863 components_to_record (gnu_variant_type, Component_List (variant),
6864 NULL_TREE, packed, definition,
6865 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6866 true, unchecked_union, debug_info_p);
6868 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
6870 Set_Present_Expr (variant, annotate_value (gnu_qual));
6872 /* If this is an Unchecked_Union and we have exactly one field,
6873 use this field directly to match the layout of C unions. */
6875 && TYPE_FIELDS (gnu_variant_type)
6876 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6877 gnu_field = TYPE_FIELDS (gnu_variant_type);
6880 /* Deal with packedness like in gnat_to_gnu_field. */
6882 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6884 /* Finalize the record type now. We used to throw away
6885 empty records but we no longer do that because we need
6886 them to generate complete debug info for the variant;
6887 otherwise, the union type definition will be lacking
6888 the fields associated with these empty variants. */
6889 rest_of_record_type_compilation (gnu_variant_type);
6890 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
6891 NULL, true, debug_info_p, gnat_component_list);
6893 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6894 gnu_union_type, field_packed,
6896 ? TYPE_SIZE (gnu_variant_type)
6899 ? bitsize_zero_node : 0),
6902 DECL_INTERNAL_P (gnu_field) = 1;
6904 if (!unchecked_union)
6905 DECL_QUALIFIER (gnu_field) = gnu_qual;
6908 TREE_CHAIN (gnu_field) = gnu_variant_list;
6909 gnu_variant_list = gnu_field;
6912 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
6913 if (gnu_variant_list)
6915 int union_field_packed;
6917 if (all_rep_and_size)
6919 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6920 TYPE_SIZE_UNIT (gnu_union_type)
6921 = TYPE_SIZE_UNIT (gnu_record_type);
6924 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6925 all_rep_and_size ? 1 : 0, false);
6927 /* If GNU_UNION_TYPE is our record type, it means we must have an
6928 Unchecked_Union with no fields. Verify that and, if so, just
6930 if (gnu_union_type == gnu_record_type)
6932 gcc_assert (unchecked_union
6934 && !gnu_our_rep_list);
6938 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
6939 NULL, true, debug_info_p, gnat_component_list);
6941 /* Deal with packedness like in gnat_to_gnu_field. */
6943 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6946 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6948 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6949 all_rep ? bitsize_zero_node : 0, 0);
6951 DECL_INTERNAL_P (gnu_union_field) = 1;
6952 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6953 gnu_field_list = gnu_union_field;
6957 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6958 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do
6959 this in a separate pass since we want to handle the discriminants but
6960 can't play with them until we've used them in debugging data above.
6962 ??? If we then reorder them, debugging information will be wrong but
6963 there's nothing that can be done about this at the moment. */
6964 gnu_last = NULL_TREE;
6965 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
6967 gnu_next = TREE_CHAIN (gnu_field);
6969 if (DECL_FIELD_OFFSET (gnu_field))
6972 gnu_field_list = gnu_next;
6974 TREE_CHAIN (gnu_last) = gnu_next;
6976 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6977 gnu_our_rep_list = gnu_field;
6980 gnu_last = gnu_field;
6983 /* If we have any fields in our rep'ed field list and it is not the case that
6984 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
6985 set it and ignore these fields. */
6986 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6987 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6989 /* Otherwise, sort the fields by bit position and put them into their own
6990 record, before the others, if we also have fields without rep clauses. */
6991 else if (gnu_our_rep_list)
6994 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6995 int i, len = list_length (gnu_our_rep_list);
6996 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6998 for (gnu_field = gnu_our_rep_list, i = 0;
7000 gnu_field = TREE_CHAIN (gnu_field), i++)
7001 gnu_arr[i] = gnu_field;
7003 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7005 /* Put the fields in the list in order of increasing position, which
7006 means we start from the end. */
7007 gnu_our_rep_list = NULL_TREE;
7008 for (i = len - 1; i >= 0; i--)
7010 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
7011 gnu_our_rep_list = gnu_arr[i];
7012 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7017 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
7019 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7020 gnu_record_type, 0, NULL_TREE, NULL_TREE, 1);
7021 DECL_INTERNAL_P (gnu_field) = 1;
7022 gnu_field_list = chainon (gnu_field_list, gnu_field);
7026 layout_with_rep = true;
7027 gnu_field_list = nreverse (gnu_our_rep_list);
7031 if (cancel_alignment)
7032 TYPE_ALIGN (gnu_record_type) = 0;
7034 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7035 layout_with_rep ? 1 : 0, do_not_finalize);
7038 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7039 placed into an Esize, Component_Bit_Offset, or Component_Size value
7040 in the GNAT tree. */
7043 annotate_value (tree gnu_size)
7045 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
7047 Node_Ref_Or_Val ops[3], ret;
7050 struct tree_int_map **h = NULL;
7052 /* See if we've already saved the value for this node. */
7053 if (EXPR_P (gnu_size))
7055 struct tree_int_map in;
7056 if (!annotate_value_cache)
7057 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7058 tree_int_map_eq, 0);
7059 in.base.from = gnu_size;
7060 h = (struct tree_int_map **)
7061 htab_find_slot (annotate_value_cache, &in, INSERT);
7064 return (Node_Ref_Or_Val) (*h)->to;
7067 /* If we do not return inside this switch, TCODE will be set to the
7068 code to use for a Create_Node operand and LEN (set above) will be
7069 the number of recursive calls for us to make. */
7071 switch (TREE_CODE (gnu_size))
7074 if (TREE_OVERFLOW (gnu_size))
7077 /* This may have come from a conversion from some smaller type,
7078 so ensure this is in bitsizetype. */
7079 gnu_size = convert (bitsizetype, gnu_size);
7081 /* For negative values, use NEGATE_EXPR of the supplied value. */
7082 if (tree_int_cst_sgn (gnu_size) < 0)
7084 /* The ridiculous code below is to handle the case of the largest
7085 negative integer. */
7086 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
7087 bool adjust = false;
7090 if (TREE_OVERFLOW (negative_size))
7093 = size_binop (MINUS_EXPR, bitsize_zero_node,
7094 size_binop (PLUS_EXPR, gnu_size,
7099 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
7101 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
7103 return annotate_value (temp);
7106 if (!host_integerp (gnu_size, 1))
7109 size = tree_low_cst (gnu_size, 1);
7111 /* This peculiar test is to make sure that the size fits in an int
7112 on machines where HOST_WIDE_INT is not "int". */
7113 if (tree_low_cst (gnu_size, 1) == size)
7114 return UI_From_Int (size);
7119 /* The only case we handle here is a simple discriminant reference. */
7120 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7121 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7122 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7123 return Create_Node (Discrim_Val,
7124 annotate_value (DECL_DISCRIMINANT_NUMBER
7125 (TREE_OPERAND (gnu_size, 1))),
7130 CASE_CONVERT: case NON_LVALUE_EXPR:
7131 return annotate_value (TREE_OPERAND (gnu_size, 0));
7133 /* Now just list the operations we handle. */
7134 case COND_EXPR: tcode = Cond_Expr; break;
7135 case PLUS_EXPR: tcode = Plus_Expr; break;
7136 case MINUS_EXPR: tcode = Minus_Expr; break;
7137 case MULT_EXPR: tcode = Mult_Expr; break;
7138 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7139 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7140 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7141 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7142 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7143 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7144 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7145 case NEGATE_EXPR: tcode = Negate_Expr; break;
7146 case MIN_EXPR: tcode = Min_Expr; break;
7147 case MAX_EXPR: tcode = Max_Expr; break;
7148 case ABS_EXPR: tcode = Abs_Expr; break;
7149 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7150 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7151 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7152 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7153 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7154 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7155 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7156 case LT_EXPR: tcode = Lt_Expr; break;
7157 case LE_EXPR: tcode = Le_Expr; break;
7158 case GT_EXPR: tcode = Gt_Expr; break;
7159 case GE_EXPR: tcode = Ge_Expr; break;
7160 case EQ_EXPR: tcode = Eq_Expr; break;
7161 case NE_EXPR: tcode = Ne_Expr; break;
7165 tree t = maybe_inline_call_in_expr (gnu_size);
7167 return annotate_value (t);
7170 /* Fall through... */
7176 /* Now get each of the operands that's relevant for this code. If any
7177 cannot be expressed as a repinfo node, say we can't. */
7178 for (i = 0; i < 3; i++)
7181 for (i = 0; i < len; i++)
7183 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7184 if (ops[i] == No_Uint)
7188 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7190 /* Save the result in the cache. */
7193 *h = GGC_NEW (struct tree_int_map);
7194 (*h)->base.from = gnu_size;
7201 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7202 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7203 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7204 BY_REF is true if the object is used by reference. */
7207 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7211 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7212 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7214 gnu_type = TREE_TYPE (gnu_type);
7217 if (Unknown_Esize (gnat_entity))
7219 if (TREE_CODE (gnu_type) == RECORD_TYPE
7220 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7221 size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
7223 size = TYPE_SIZE (gnu_type);
7226 Set_Esize (gnat_entity, annotate_value (size));
7229 if (Unknown_Alignment (gnat_entity))
7230 Set_Alignment (gnat_entity,
7231 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7234 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7235 set Component_Bit_Offset and Esize of the components to the position and
7236 size used by Gigi. */
7239 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7241 Entity_Id gnat_field;
7244 /* We operate by first making a list of all fields and their position (we
7245 can get the size easily) and then update all the sizes in the tree. */
7247 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7248 BIGGEST_ALIGNMENT, NULL_TREE);
7250 for (gnat_field = First_Entity (gnat_entity);
7251 Present (gnat_field);
7252 gnat_field = Next_Entity (gnat_field))
7253 if (Ekind (gnat_field) == E_Component
7254 || (Ekind (gnat_field) == E_Discriminant
7255 && !Is_Unchecked_Union (Scope (gnat_field))))
7257 tree parent_offset, t;
7259 t = purpose_member (gnat_to_gnu_field_decl (gnat_field), gnu_list);
7262 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7264 /* In this mode the tag and parent components are not
7265 generated, so we add the appropriate offset to each
7266 component. For a component appearing in the current
7267 extension, the offset is the size of the parent. */
7268 if (Is_Derived_Type (gnat_entity)
7269 && Original_Record_Component (gnat_field) == gnat_field)
7271 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7274 parent_offset = bitsize_int (POINTER_SIZE);
7277 parent_offset = bitsize_zero_node;
7279 Set_Component_Bit_Offset
7282 (size_binop (PLUS_EXPR,
7283 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7284 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7287 Set_Esize (gnat_field,
7288 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7290 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7292 /* If there is no entry, this is an inherited component whose
7293 position is the same as in the parent type. */
7294 Set_Component_Bit_Offset
7296 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7298 Set_Esize (gnat_field,
7299 Esize (Original_Record_Component (gnat_field)));
7304 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7305 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7306 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7307 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7308 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7309 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7310 pre-existing list to be chained to the newly created entries. */
7313 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7314 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7318 for (gnu_field = TYPE_FIELDS (gnu_type);
7320 gnu_field = TREE_CHAIN (gnu_field))
7322 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7323 DECL_FIELD_BIT_OFFSET (gnu_field));
7324 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7325 DECL_FIELD_OFFSET (gnu_field));
7326 unsigned int our_offset_align
7327 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7328 tree v = make_tree_vec (3);
7330 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7331 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7332 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7333 gnu_list = tree_cons (gnu_field, v, gnu_list);
7335 /* Recurse on internal fields, flattening the nested fields except for
7336 those in the variant part, if requested. */
7337 if (DECL_INTERNAL_P (gnu_field))
7339 tree gnu_field_type = TREE_TYPE (gnu_field);
7340 if (do_not_flatten_variant
7341 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7343 = build_position_list (gnu_field_type, do_not_flatten_variant,
7344 size_zero_node, bitsize_zero_node,
7345 BIGGEST_ALIGNMENT, gnu_list);
7348 = build_position_list (gnu_field_type, do_not_flatten_variant,
7349 gnu_our_offset, gnu_our_bitpos,
7350 our_offset_align, gnu_list);
7357 /* Return a TREE_LIST describing the substitutions needed to reflect the
7358 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7359 be in any order. TREE_PURPOSE gives the tree for the discriminant and
7360 TREE_VALUE is the replacement value. They are in the form of operands
7361 to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
7365 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7367 tree gnu_list = NULL_TREE;
7368 Entity_Id gnat_discrim;
7371 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7372 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7373 Present (gnat_discrim);
7374 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7375 gnat_value = Next_Elmt (gnat_value))
7376 /* Ignore access discriminants. */
7377 if (!Is_Access_Type (Etype (Node (gnat_value))))
7379 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7380 gnu_list = tree_cons (gnu_field,
7381 convert (TREE_TYPE (gnu_field),
7382 elaborate_expression
7383 (Node (gnat_value), gnat_subtype,
7384 get_entity_name (gnat_discrim),
7385 definition, true, false)),
7392 /* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
7393 variants of QUAL_UNION_TYPE that are still relevant after applying the
7394 substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
7395 variant and TREE_VALUE is a TREE_VEC containing the field, the new value
7396 of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
7397 list to be chained to the newly created entries. */
7400 build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
7404 for (gnu_field = TYPE_FIELDS (qual_union_type);
7406 gnu_field = TREE_CHAIN (gnu_field))
7408 tree t, qual = DECL_QUALIFIER (gnu_field);
7410 for (t = subst_list; t; t = TREE_CHAIN (t))
7411 qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
7413 /* If the new qualifier is not unconditionally false, its variant may
7414 still be accessed. */
7415 if (!integer_zerop (qual))
7417 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7418 tree v = make_tree_vec (3);
7419 TREE_VEC_ELT (v, 0) = gnu_field;
7420 TREE_VEC_ELT (v, 1) = qual;
7421 TREE_VEC_ELT (v, 2) = NULL_TREE;
7422 gnu_list = tree_cons (variant_type, v, gnu_list);
7424 /* Recurse on the variant subpart of the variant, if any. */
7425 variant_subpart = get_variant_part (variant_type);
7426 if (variant_subpart)
7427 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
7428 subst_list, gnu_list);
7430 /* If the new qualifier is unconditionally true, the subsequent
7431 variants cannot be accessed. */
7432 if (integer_onep (qual))
7440 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7441 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
7442 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
7443 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7444 for the size of a field. COMPONENT_P is true if we are being called
7445 to process the Component_Size of GNAT_OBJECT. This is used for error
7446 message handling and to indicate to use the object size of GNU_TYPE.
7447 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7448 it means that a size of zero should be treated as an unspecified size. */
7451 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7452 enum tree_code kind, bool component_p, bool zero_ok)
7454 Node_Id gnat_error_node;
7455 tree type_size, size;
7457 if (kind == VAR_DECL
7458 /* If a type needs strict alignment, a component of this type in
7459 a packed record cannot be packed and thus uses the type size. */
7460 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7461 type_size = TYPE_SIZE (gnu_type);
7463 type_size = rm_size (gnu_type);
7465 /* Find the node to use for errors. */
7466 if ((Ekind (gnat_object) == E_Component
7467 || Ekind (gnat_object) == E_Discriminant)
7468 && Present (Component_Clause (gnat_object)))
7469 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7470 else if (Present (Size_Clause (gnat_object)))
7471 gnat_error_node = Expression (Size_Clause (gnat_object));
7473 gnat_error_node = gnat_object;
7475 /* Return 0 if no size was specified, either because Esize was not Present
7476 or the specified size was zero. */
7477 if (No (uint_size) || uint_size == No_Uint)
7480 /* Get the size as a tree. Issue an error if a size was specified but
7481 cannot be represented in sizetype. */
7482 size = UI_To_gnu (uint_size, bitsizetype);
7483 if (TREE_OVERFLOW (size))
7485 post_error_ne (component_p ? "component size of & is too large"
7486 : "size of & is too large",
7487 gnat_error_node, gnat_object);
7491 /* Ignore a negative size since that corresponds to our back-annotation.
7492 Also ignore a zero size if it is not permitted. */
7493 if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
7496 /* The size of objects is always a multiple of a byte. */
7497 if (kind == VAR_DECL
7498 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7501 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7502 gnat_error_node, gnat_object);
7504 post_error_ne ("size for& is not a multiple of Storage_Unit",
7505 gnat_error_node, gnat_object);
7509 /* If this is an integral type or a packed array type, the front-end has
7510 verified the size, so we need not do it here (which would entail
7511 checking against the bounds). However, if this is an aliased object,
7512 it may not be smaller than the type of the object. */
7513 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7514 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7517 /* If the object is a record that contains a template, add the size of
7518 the template to the specified size. */
7519 if (TREE_CODE (gnu_type) == RECORD_TYPE
7520 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7521 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7523 /* Modify the size of the type to be that of the maximum size if it has a
7525 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7526 type_size = max_size (type_size, true);
7528 /* If this is an access type or a fat pointer, the minimum size is that given
7529 by the smallest integral mode that's valid for pointers. */
7530 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7532 enum machine_mode p_mode;
7534 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7535 !targetm.valid_pointer_mode (p_mode);
7536 p_mode = GET_MODE_WIDER_MODE (p_mode))
7539 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7542 /* If the size of the object is a constant, the new size must not be
7544 if (TREE_CODE (type_size) != INTEGER_CST
7545 || TREE_OVERFLOW (type_size)
7546 || tree_int_cst_lt (size, type_size))
7550 ("component size for& too small{, minimum allowed is ^}",
7551 gnat_error_node, gnat_object, type_size);
7553 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7554 gnat_error_node, gnat_object, type_size);
7556 if (kind == VAR_DECL && !component_p
7557 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7558 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7559 post_error_ne_tree_2
7560 ("\\size of ^ is not a multiple of alignment (^ bits)",
7561 gnat_error_node, gnat_object, rm_size (gnu_type),
7562 TYPE_ALIGN (gnu_type));
7564 else if (INTEGRAL_TYPE_P (gnu_type))
7565 post_error_ne ("\\size would be legal if & were not aliased!",
7566 gnat_error_node, gnat_object);
7574 /* Similarly, but both validate and process a value of RM size. This
7575 routine is only called for types. */
7578 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7580 /* Only issue an error if a Value_Size clause was explicitly given.
7581 Otherwise, we'd be duplicating an error on the Size clause. */
7582 Node_Id gnat_attr_node
7583 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7584 tree old_size = rm_size (gnu_type), size;
7586 /* Do nothing if no size was specified, either because RM size was not
7587 Present or if the specified size was zero. */
7588 if (No (uint_size) || uint_size == No_Uint)
7591 /* Get the size as a tree. Issue an error if a size was specified but
7592 cannot be represented in sizetype. */
7593 size = UI_To_gnu (uint_size, bitsizetype);
7594 if (TREE_OVERFLOW (size))
7596 if (Present (gnat_attr_node))
7597 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7602 /* Ignore a negative size since that corresponds to our back-annotation.
7603 Also ignore a zero size unless a Value_Size clause exists, or a size
7604 clause exists, or this is an integer type, in which case the front-end
7605 will have always set it. */
7606 if (tree_int_cst_sgn (size) < 0
7607 || (integer_zerop (size)
7608 && No (gnat_attr_node)
7609 && !Has_Size_Clause (gnat_entity)
7610 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7613 /* If the old size is self-referential, get the maximum size. */
7614 if (CONTAINS_PLACEHOLDER_P (old_size))
7615 old_size = max_size (old_size, true);
7617 /* If the size of the object is a constant, the new size must not be smaller
7618 (the front-end has verified this for scalar and packed array types). */
7619 if (TREE_CODE (old_size) != INTEGER_CST
7620 || TREE_OVERFLOW (old_size)
7621 || (AGGREGATE_TYPE_P (gnu_type)
7622 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
7623 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
7624 && !(TYPE_IS_PADDING_P (gnu_type)
7625 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
7626 && TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
7627 && tree_int_cst_lt (size, old_size)))
7629 if (Present (gnat_attr_node))
7631 ("Value_Size for& too small{, minimum allowed is ^}",
7632 gnat_attr_node, gnat_entity, old_size);
7636 /* Otherwise, set the RM size proper for integral types... */
7637 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
7638 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7639 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7640 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
7641 SET_TYPE_RM_SIZE (gnu_type, size);
7643 /* ...or the Ada size for record and union types. */
7644 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7645 || TREE_CODE (gnu_type) == UNION_TYPE
7646 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7647 && !TYPE_FAT_POINTER_P (gnu_type))
7648 SET_TYPE_ADA_SIZE (gnu_type, size);
7651 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7652 If TYPE is the best type, return it. Otherwise, make a new type. We
7653 only support new integral and pointer types. FOR_BIASED is true if
7654 we are making a biased type. */
7657 make_type_from_size (tree type, tree size_tree, bool for_biased)
7659 unsigned HOST_WIDE_INT size;
7663 /* If size indicates an error, just return TYPE to avoid propagating
7664 the error. Likewise if it's too large to represent. */
7665 if (!size_tree || !host_integerp (size_tree, 1))
7668 size = tree_low_cst (size_tree, 1);
7670 switch (TREE_CODE (type))
7675 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7676 && TYPE_BIASED_REPRESENTATION_P (type));
7678 /* Only do something if the type is not a packed array type and
7679 doesn't already have the proper size. */
7680 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7681 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7684 biased_p |= for_biased;
7685 if (size > LONG_LONG_TYPE_SIZE)
7686 size = LONG_LONG_TYPE_SIZE;
7688 if (TYPE_UNSIGNED (type) || biased_p)
7689 new_type = make_unsigned_type (size);
7691 new_type = make_signed_type (size);
7692 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7693 SET_TYPE_RM_MIN_VALUE (new_type,
7694 convert (TREE_TYPE (new_type),
7695 TYPE_MIN_VALUE (type)));
7696 SET_TYPE_RM_MAX_VALUE (new_type,
7697 convert (TREE_TYPE (new_type),
7698 TYPE_MAX_VALUE (type)));
7699 /* Propagate the name to avoid creating a fake subrange type. */
7700 if (TYPE_NAME (type))
7702 if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL)
7703 TYPE_NAME (new_type) = DECL_NAME (TYPE_NAME (type));
7705 TYPE_NAME (new_type) = TYPE_NAME (type);
7707 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7708 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
7712 /* Do something if this is a fat pointer, in which case we
7713 may need to return the thin pointer. */
7714 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7716 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7717 if (!targetm.valid_pointer_mode (p_mode))
7720 build_pointer_type_for_mode
7721 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7727 /* Only do something if this is a thin pointer, in which case we
7728 may need to return the fat pointer. */
7729 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7731 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7741 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7742 a type or object whose present alignment is ALIGN. If this alignment is
7743 valid, return it. Otherwise, give an error and return ALIGN. */
7746 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7748 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7749 unsigned int new_align;
7750 Node_Id gnat_error_node;
7752 /* Don't worry about checking alignment if alignment was not specified
7753 by the source program and we already posted an error for this entity. */
7754 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7757 /* Post the error on the alignment clause if any. Note, for the implicit
7758 base type of an array type, the alignment clause is on the first
7760 if (Present (Alignment_Clause (gnat_entity)))
7761 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7763 else if (Is_Itype (gnat_entity)
7764 && Is_Array_Type (gnat_entity)
7765 && Etype (gnat_entity) == gnat_entity
7766 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
7768 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
7771 gnat_error_node = gnat_entity;
7773 /* Within GCC, an alignment is an integer, so we must make sure a value is
7774 specified that fits in that range. Also, there is an upper bound to
7775 alignments we can support/allow. */
7776 if (!UI_Is_In_Int_Range (alignment)
7777 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7778 post_error_ne_num ("largest supported alignment for& is ^",
7779 gnat_error_node, gnat_entity, max_allowed_alignment);
7780 else if (!(Present (Alignment_Clause (gnat_entity))
7781 && From_At_Mod (Alignment_Clause (gnat_entity)))
7782 && new_align * BITS_PER_UNIT < align)
7784 unsigned int double_align;
7785 bool is_capped_double, align_clause;
7787 /* If the default alignment of "double" or larger scalar types is
7788 specifically capped and the new alignment is above the cap, do
7789 not post an error and change the alignment only if there is an
7790 alignment clause; this makes it possible to have the associated
7791 GCC type overaligned by default for performance reasons. */
7792 if ((double_align = double_float_alignment) > 0)
7795 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7797 = is_double_float_or_array (gnat_type, &align_clause);
7799 else if ((double_align = double_scalar_alignment) > 0)
7802 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7804 = is_double_scalar_or_array (gnat_type, &align_clause);
7807 is_capped_double = align_clause = false;
7809 if (is_capped_double && new_align >= double_align)
7812 align = new_align * BITS_PER_UNIT;
7816 if (is_capped_double)
7817 align = double_align * BITS_PER_UNIT;
7819 post_error_ne_num ("alignment for& must be at least ^",
7820 gnat_error_node, gnat_entity,
7821 align / BITS_PER_UNIT);
7826 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7827 if (new_align > align)
7834 /* Return the smallest alignment not less than SIZE. */
7837 ceil_alignment (unsigned HOST_WIDE_INT size)
7839 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7842 /* Verify that OBJECT, a type or decl, is something we can implement
7843 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7844 if we require atomic components. */
7847 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7849 Node_Id gnat_error_point = gnat_entity;
7851 enum machine_mode mode;
7855 /* There are three case of what OBJECT can be. It can be a type, in which
7856 case we take the size, alignment and mode from the type. It can be a
7857 declaration that was indirect, in which case the relevant values are
7858 that of the type being pointed to, or it can be a normal declaration,
7859 in which case the values are of the decl. The code below assumes that
7860 OBJECT is either a type or a decl. */
7861 if (TYPE_P (object))
7863 /* If this is an anonymous base type, nothing to check. Error will be
7864 reported on the source type. */
7865 if (!Comes_From_Source (gnat_entity))
7868 mode = TYPE_MODE (object);
7869 align = TYPE_ALIGN (object);
7870 size = TYPE_SIZE (object);
7872 else if (DECL_BY_REF_P (object))
7874 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7875 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7876 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7880 mode = DECL_MODE (object);
7881 align = DECL_ALIGN (object);
7882 size = DECL_SIZE (object);
7885 /* Consider all floating-point types atomic and any types that that are
7886 represented by integers no wider than a machine word. */
7887 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7888 || ((GET_MODE_CLASS (mode) == MODE_INT
7889 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7890 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7893 /* For the moment, also allow anything that has an alignment equal
7894 to its size and which is smaller than a word. */
7895 if (size && TREE_CODE (size) == INTEGER_CST
7896 && compare_tree_int (size, align) == 0
7897 && align <= BITS_PER_WORD)
7900 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7901 gnat_node = Next_Rep_Item (gnat_node))
7903 if (!comp_p && Nkind (gnat_node) == N_Pragma
7904 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7906 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7907 else if (comp_p && Nkind (gnat_node) == N_Pragma
7908 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7909 == Pragma_Atomic_Components))
7910 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7914 post_error_ne ("atomic access to component of & cannot be guaranteed",
7915 gnat_error_point, gnat_entity);
7917 post_error_ne ("atomic access to & cannot be guaranteed",
7918 gnat_error_point, gnat_entity);
7921 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7922 have compatible signatures so that a call using one type may be safely
7923 issued if the actual target function type is the other. Return 1 if it is
7924 the case, 0 otherwise, and post errors on the incompatibilities.
7926 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7927 that calls to the subprogram will have arguments suitable for the later
7928 underlying builtin expansion. */
7931 compatible_signatures_p (tree ftype1, tree ftype2)
7933 /* As of now, we only perform very trivial tests and consider it's the
7934 programmer's responsibility to ensure the type correctness in the Ada
7935 declaration, as in the regular Import cases.
7937 Mismatches typically result in either error messages from the builtin
7938 expander, internal compiler errors, or in a real call sequence. This
7939 should be refined to issue diagnostics helping error detection and
7942 /* Almost fake test, ensuring a use of each argument. */
7943 if (ftype1 == ftype2)
7949 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
7950 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
7951 specified size for this field. POS_LIST is a position list describing
7952 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
7956 create_field_decl_from (tree old_field, tree field_type, tree record_type,
7957 tree size, tree pos_list, tree subst_list)
7959 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
7960 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
7961 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
7962 tree new_pos, new_field;
7964 if (CONTAINS_PLACEHOLDER_P (pos))
7965 for (t = subst_list; t; t = TREE_CHAIN (t))
7966 pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
7968 /* If the position is now a constant, we can set it as the position of the
7969 field when we make it. Otherwise, we need to deal with it specially. */
7970 if (TREE_CONSTANT (pos))
7971 new_pos = bit_from_pos (pos, bitpos);
7973 new_pos = NULL_TREE;
7976 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
7977 DECL_PACKED (old_field), size, new_pos,
7978 !DECL_NONADDRESSABLE_P (old_field));
7982 normalize_offset (&pos, &bitpos, offset_align);
7983 DECL_FIELD_OFFSET (new_field) = pos;
7984 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
7985 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
7986 DECL_SIZE (new_field) = size;
7987 DECL_SIZE_UNIT (new_field)
7988 = convert (sizetype,
7989 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
7990 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
7993 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
7994 t = DECL_ORIGINAL_FIELD (old_field);
7995 SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
7996 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
7997 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8002 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8005 get_rep_part (tree record_type)
8007 tree field = TYPE_FIELDS (record_type);
8009 /* The REP part is the first field, internal, another record, and its name
8010 doesn't start with an underscore (i.e. is not generated by the FE). */
8011 if (DECL_INTERNAL_P (field)
8012 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8013 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8019 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8022 get_variant_part (tree record_type)
8026 /* The variant part is the only internal field that is a qualified union. */
8027 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
8028 if (DECL_INTERNAL_P (field)
8029 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8035 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8036 the list of variants to be used and RECORD_TYPE is the type of the parent.
8037 POS_LIST is a position list describing the layout of fields present in
8038 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8042 create_variant_part_from (tree old_variant_part, tree variant_list,
8043 tree record_type, tree pos_list, tree subst_list)
8045 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8046 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8047 tree old_union_type = TREE_TYPE (old_variant_part);
8048 tree new_union_type, new_variant_part, t;
8049 tree union_field_list = NULL_TREE;
8051 /* First create the type of the variant part from that of the old one. */
8052 new_union_type = make_node (QUAL_UNION_TYPE);
8053 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8055 /* If the position of the variant part is constant, subtract it from the
8056 size of the type of the parent to get the new size. This manual CSE
8057 reduces the code size when not optimizing. */
8058 if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
8060 tree first_bit = bit_from_pos (offset, bitpos);
8061 TYPE_SIZE (new_union_type)
8062 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8063 TYPE_SIZE_UNIT (new_union_type)
8064 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8065 byte_from_pos (offset, bitpos));
8066 SET_TYPE_ADA_SIZE (new_union_type,
8067 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8069 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8070 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8073 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8075 /* Now finish up the new variants and populate the union type. */
8076 for (t = variant_list; t; t = TREE_CHAIN (t))
8078 tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
8079 tree old_variant, old_variant_subpart, new_variant, field_list;
8081 /* Skip variants that don't belong to this nesting level. */
8082 if (DECL_CONTEXT (old_field) != old_union_type)
8085 /* Retrieve the list of fields already added to the new variant. */
8086 new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
8087 field_list = TYPE_FIELDS (new_variant);
8089 /* If the old variant had a variant subpart, we need to create a new
8090 variant subpart and add it to the field list. */
8091 old_variant = TREE_PURPOSE (t);
8092 old_variant_subpart = get_variant_part (old_variant);
8093 if (old_variant_subpart)
8095 tree new_variant_subpart
8096 = create_variant_part_from (old_variant_subpart, variant_list,
8097 new_variant, pos_list, subst_list);
8098 TREE_CHAIN (new_variant_subpart) = field_list;
8099 field_list = new_variant_subpart;
8102 /* Finish up the new variant and create the field. */
8103 finish_record_type (new_variant, nreverse (field_list), 2, true);
8104 compute_record_mode (new_variant);
8105 rest_of_record_type_compilation (new_variant);
8107 /* No need for debug info thanks to the XVS type. */
8108 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8109 true, false, Empty);
8112 = create_field_decl_from (old_field, new_variant, new_union_type,
8113 TYPE_SIZE (new_variant),
8114 pos_list, subst_list);
8115 DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
8116 DECL_INTERNAL_P (new_field) = 1;
8117 TREE_CHAIN (new_field) = union_field_list;
8118 union_field_list = new_field;
8121 /* Finish up the union type and create the variant part. */
8122 finish_record_type (new_union_type, union_field_list, 2, true);
8123 compute_record_mode (new_union_type);
8124 rest_of_record_type_compilation (new_union_type);
8126 /* No need for debug info thanks to the XVS type. */
8127 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8128 true, false, Empty);
8131 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8132 TYPE_SIZE (new_union_type),
8133 pos_list, subst_list);
8134 DECL_INTERNAL_P (new_variant_part) = 1;
8136 /* With multiple discriminants it is possible for an inner variant to be
8137 statically selected while outer ones are not; in this case, the list
8138 of fields of the inner variant is not flattened and we end up with a
8139 qualified union with a single member. Drop the useless container. */
8140 if (!TREE_CHAIN (union_field_list))
8142 DECL_CONTEXT (union_field_list) = record_type;
8143 DECL_FIELD_OFFSET (union_field_list)
8144 = DECL_FIELD_OFFSET (new_variant_part);
8145 DECL_FIELD_BIT_OFFSET (union_field_list)
8146 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8147 SET_DECL_OFFSET_ALIGN (union_field_list,
8148 DECL_OFFSET_ALIGN (new_variant_part));
8149 new_variant_part = union_field_list;
8152 return new_variant_part;
8155 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8156 which are both RECORD_TYPE, after applying the substitutions described
8160 copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
8164 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8165 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8166 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8167 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8168 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8170 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8171 for (t = subst_list; t; t = TREE_CHAIN (t))
8172 TYPE_SIZE (new_type)
8173 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8177 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8178 for (t = subst_list; t; t = TREE_CHAIN (t))
8179 TYPE_SIZE_UNIT (new_type)
8180 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8184 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8185 for (t = subst_list; t; t = TREE_CHAIN (t))
8187 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8191 /* Finalize the size. */
8192 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8193 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8196 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8197 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8198 updated by replacing F with R.
8200 The function doesn't update the layout of the type, i.e. it assumes
8201 that the substitution is purely formal. That's why the replacement
8202 value R must itself contain a PLACEHOLDER_EXPR. */
8205 substitute_in_type (tree t, tree f, tree r)
8209 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8211 switch (TREE_CODE (t))
8218 /* First the domain types of arrays. */
8219 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8220 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8222 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8223 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8225 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8229 TYPE_GCC_MIN_VALUE (nt) = low;
8230 TYPE_GCC_MAX_VALUE (nt) = high;
8232 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8234 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8239 /* Then the subtypes. */
8240 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8241 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8243 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8244 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8246 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8250 SET_TYPE_RM_MIN_VALUE (nt, low);
8251 SET_TYPE_RM_MAX_VALUE (nt, high);
8259 nt = substitute_in_type (TREE_TYPE (t), f, r);
8260 if (nt == TREE_TYPE (t))
8263 return build_complex_type (nt);
8269 /* These should never show up here. */
8274 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8275 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8277 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8280 nt = build_array_type (component, domain);
8281 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8282 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8283 SET_TYPE_MODE (nt, TYPE_MODE (t));
8284 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8285 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8286 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8287 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8288 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8294 case QUAL_UNION_TYPE:
8296 bool changed_field = false;
8299 /* Start out with no fields, make new fields, and chain them
8300 in. If we haven't actually changed the type of any field,
8301 discard everything we've done and return the old type. */
8303 TYPE_FIELDS (nt) = NULL_TREE;
8305 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
8307 tree new_field = copy_node (field), new_n;
8309 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8310 if (new_n != TREE_TYPE (field))
8312 TREE_TYPE (new_field) = new_n;
8313 changed_field = true;
8316 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8317 if (new_n != DECL_FIELD_OFFSET (field))
8319 DECL_FIELD_OFFSET (new_field) = new_n;
8320 changed_field = true;
8323 /* Do the substitution inside the qualifier, if any. */
8324 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8326 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8327 if (new_n != DECL_QUALIFIER (field))
8329 DECL_QUALIFIER (new_field) = new_n;
8330 changed_field = true;
8334 DECL_CONTEXT (new_field) = nt;
8335 SET_DECL_ORIGINAL_FIELD (new_field,
8336 (DECL_ORIGINAL_FIELD (field)
8337 ? DECL_ORIGINAL_FIELD (field) : field));
8339 TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
8340 TYPE_FIELDS (nt) = new_field;
8346 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8347 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8348 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8349 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8358 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8359 needed to represent the object. */
8362 rm_size (tree gnu_type)
8364 /* For integral types, we store the RM size explicitly. */
8365 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8366 return TYPE_RM_SIZE (gnu_type);
8368 /* Return the RM size of the actual data plus the size of the template. */
8369 if (TREE_CODE (gnu_type) == RECORD_TYPE
8370 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8372 size_binop (PLUS_EXPR,
8373 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
8374 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8376 /* For record types, we store the size explicitly. */
8377 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8378 || TREE_CODE (gnu_type) == UNION_TYPE
8379 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8380 && !TYPE_FAT_POINTER_P (gnu_type)
8381 && TYPE_ADA_SIZE (gnu_type))
8382 return TYPE_ADA_SIZE (gnu_type);
8384 /* For other types, this is just the size. */
8385 return TYPE_SIZE (gnu_type);
8388 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8389 fully-qualified name, possibly with type information encoding.
8390 Otherwise, return the name. */
8393 get_entity_name (Entity_Id gnat_entity)
8395 Get_Encoded_Name (gnat_entity);
8396 return get_identifier_with_length (Name_Buffer, Name_Len);
8399 /* Return an identifier representing the external name to be used for
8400 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8401 and the specified suffix. */
8404 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8406 Entity_Kind kind = Ekind (gnat_entity);
8410 String_Template temp = {1, strlen (suffix)};
8411 Fat_Pointer fp = {suffix, &temp};
8412 Get_External_Name_With_Suffix (gnat_entity, fp);
8415 Get_External_Name (gnat_entity, 0);
8417 /* A variable using the Stdcall convention lives in a DLL. We adjust
8418 its name to use the jump table, the _imp__NAME contains the address
8419 for the NAME variable. */
8420 if ((kind == E_Variable || kind == E_Constant)
8421 && Has_Stdcall_Convention (gnat_entity))
8423 const int len = 6 + Name_Len;
8424 char *new_name = (char *) alloca (len + 1);
8425 strcpy (new_name, "_imp__");
8426 strcat (new_name, Name_Buffer);
8427 return get_identifier_with_length (new_name, len);
8430 return get_identifier_with_length (Name_Buffer, Name_Len);
8433 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8434 string, return a new IDENTIFIER_NODE that is the concatenation of
8435 the name followed by "___" and the specified suffix. */
8438 concat_name (tree gnu_name, const char *suffix)
8440 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8441 char *new_name = (char *) alloca (len + 1);
8442 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8443 strcat (new_name, "___");
8444 strcat (new_name, suffix);
8445 return get_identifier_with_length (new_name, len);
8448 #include "gt-ada-decl.h"