1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2010, 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 (tree, Entity_Id);
139 static bool compile_time_known_address_p (Node_Id);
140 static bool cannot_be_superflat_p (Node_Id);
141 static bool constructor_address_p (tree);
142 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
143 bool, bool, bool, bool, bool);
144 static Uint annotate_value (tree);
145 static void annotate_rep (Entity_Id, tree);
146 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
147 static tree build_subst_list (Entity_Id, Entity_Id, bool);
148 static tree build_variant_list (tree, tree, tree);
149 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
150 static void set_rm_size (Uint, tree, Entity_Id);
151 static tree make_type_from_size (tree, tree, bool);
152 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
153 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
154 static void check_ok_for_atomic (tree, Entity_Id, bool);
155 static int compatible_signatures_p (tree, tree);
156 static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
157 static tree get_rep_part (tree);
158 static tree get_variant_part (tree);
159 static tree create_variant_part_from (tree, tree, tree, tree, tree);
160 static void copy_and_substitute_in_size (tree, tree, tree);
161 static void rest_of_type_decl_compilation_no_defer (tree);
163 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
164 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
165 and associate the ..._DECL node with the input GNAT defining identifier.
167 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
168 initial value (in GCC tree form). This is optional for a variable. For
169 a renamed entity, GNU_EXPR gives the object being renamed.
171 DEFINITION is nonzero if this call is intended for a definition. This is
172 used for separate compilation where it is necessary to know whether an
173 external declaration or a definition must be created if the GCC equivalent
174 was not created previously. The value of 1 is normally used for a nonzero
175 DEFINITION, but a value of 2 is used in special circumstances, defined in
179 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
181 /* Contains the kind of the input GNAT node. */
182 const Entity_Kind kind = Ekind (gnat_entity);
183 /* True if this is a type. */
184 const bool is_type = IN (kind, Type_Kind);
185 /* For a type, contains the equivalent GNAT node to be used in gigi. */
186 Entity_Id gnat_equiv_type = Empty;
187 /* Temporary used to walk the GNAT tree. */
189 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
190 This node will be associated with the GNAT node by calling at the end
191 of the `switch' statement. */
192 tree gnu_decl = NULL_TREE;
193 /* Contains the GCC type to be used for the GCC node. */
194 tree gnu_type = NULL_TREE;
195 /* Contains the GCC size tree to be used for the GCC node. */
196 tree gnu_size = NULL_TREE;
197 /* Contains the GCC name to be used for the GCC node. */
198 tree gnu_entity_name;
199 /* True if we have already saved gnu_decl as a GNAT association. */
201 /* True if we incremented defer_incomplete_level. */
202 bool this_deferred = false;
203 /* True if we incremented force_global. */
204 bool this_global = false;
205 /* True if we should check to see if elaborated during processing. */
206 bool maybe_present = false;
207 /* True if we made GNU_DECL and its type here. */
208 bool this_made_decl = false;
209 /* True if debug info is requested for this entity. */
210 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
211 || debug_info_level == DINFO_LEVEL_VERBOSE);
212 /* True if this entity is to be considered as imported. */
213 bool imported_p = (Is_Imported (gnat_entity)
214 && No (Address_Clause (gnat_entity)));
215 /* Size and alignment of the GCC node, if meaningful. */
216 unsigned int esize = 0, align = 0;
217 /* Contains the list of attributes directly attached to the entity. */
218 struct attrib *attr_list = NULL;
220 /* Since a use of an Itype is a definition, process it as such if it
221 is not in a with'ed unit. */
224 && Is_Itype (gnat_entity)
225 && !present_gnu_tree (gnat_entity)
226 && In_Extended_Main_Code_Unit (gnat_entity))
228 /* Ensure that we are in a subprogram mentioned in the Scope chain of
229 this entity, our current scope is global, or we encountered a task
230 or entry (where we can't currently accurately check scoping). */
231 if (!current_function_decl
232 || DECL_ELABORATION_PROC_P (current_function_decl))
234 process_type (gnat_entity);
235 return get_gnu_tree (gnat_entity);
238 for (gnat_temp = Scope (gnat_entity);
240 gnat_temp = Scope (gnat_temp))
242 if (Is_Type (gnat_temp))
243 gnat_temp = Underlying_Type (gnat_temp);
245 if (Ekind (gnat_temp) == E_Subprogram_Body)
247 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
249 if (IN (Ekind (gnat_temp), Subprogram_Kind)
250 && Present (Protected_Body_Subprogram (gnat_temp)))
251 gnat_temp = Protected_Body_Subprogram (gnat_temp);
253 if (Ekind (gnat_temp) == E_Entry
254 || Ekind (gnat_temp) == E_Entry_Family
255 || Ekind (gnat_temp) == E_Task_Type
256 || (IN (Ekind (gnat_temp), Subprogram_Kind)
257 && present_gnu_tree (gnat_temp)
258 && (current_function_decl
259 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
261 process_type (gnat_entity);
262 return get_gnu_tree (gnat_entity);
266 /* This abort means the Itype has an incorrect scope, i.e. that its
267 scope does not correspond to the subprogram it is declared in. */
271 /* If we've already processed this entity, return what we got last time.
272 If we are defining the node, we should not have already processed it.
273 In that case, we will abort below when we try to save a new GCC tree
274 for this object. We also need to handle the case of getting a dummy
275 type when a Full_View exists. */
276 if ((!definition || (is_type && imported_p))
277 && present_gnu_tree (gnat_entity))
279 gnu_decl = get_gnu_tree (gnat_entity);
281 if (TREE_CODE (gnu_decl) == TYPE_DECL
282 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
283 && IN (kind, Incomplete_Or_Private_Kind)
284 && Present (Full_View (gnat_entity)))
287 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
288 save_gnu_tree (gnat_entity, NULL_TREE, false);
289 save_gnu_tree (gnat_entity, gnu_decl, false);
295 /* If this is a numeric or enumeral type, or an access type, a nonzero
296 Esize must be specified unless it was specified by the programmer. */
297 gcc_assert (!Unknown_Esize (gnat_entity)
298 || Has_Size_Clause (gnat_entity)
299 || (!IN (kind, Numeric_Kind)
300 && !IN (kind, Enumeration_Kind)
301 && (!IN (kind, Access_Kind)
302 || kind == E_Access_Protected_Subprogram_Type
303 || kind == E_Anonymous_Access_Protected_Subprogram_Type
304 || kind == E_Access_Subtype)));
306 /* The RM size must be specified for all discrete and fixed-point types. */
307 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
308 && Unknown_RM_Size (gnat_entity)));
310 /* If we get here, it means we have not yet done anything with this entity.
311 If we are not defining it, it must be a type or an entity that is defined
312 elsewhere or externally, otherwise we should have defined it already. */
313 gcc_assert (definition
314 || type_annotate_only
316 || kind == E_Discriminant
317 || kind == E_Component
319 || (kind == E_Constant && Present (Full_View (gnat_entity)))
320 || Is_Public (gnat_entity));
322 /* Get the name of the entity and set up the line number and filename of
323 the original definition for use in any decl we make. */
324 gnu_entity_name = get_entity_name (gnat_entity);
325 Sloc_to_locus (Sloc (gnat_entity), &input_location);
327 /* For cases when we are not defining (i.e., we are referencing from
328 another compilation unit) public entities, show we are at global level
329 for the purpose of computing scopes. Don't do this for components or
330 discriminants since the relevant test is whether or not the record is
333 && kind != E_Component
334 && kind != E_Discriminant
335 && Is_Public (gnat_entity)
336 && !Is_Statically_Allocated (gnat_entity))
337 force_global++, this_global = true;
339 /* Handle any attributes directly attached to the entity. */
340 if (Has_Gigi_Rep_Item (gnat_entity))
341 prepend_attributes (gnat_entity, &attr_list);
343 /* Do some common processing for types. */
346 /* Compute the equivalent type to be used in gigi. */
347 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
349 /* Machine_Attributes on types are expected to be propagated to
350 subtypes. The corresponding Gigi_Rep_Items are only attached
351 to the first subtype though, so we handle the propagation here. */
352 if (Base_Type (gnat_entity) != gnat_entity
353 && !Is_First_Subtype (gnat_entity)
354 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
355 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
358 /* Compute a default value for the size of the type. */
359 if (Known_Esize (gnat_entity)
360 && UI_Is_In_Int_Range (Esize (gnat_entity)))
362 unsigned int max_esize;
363 esize = UI_To_Int (Esize (gnat_entity));
365 if (IN (kind, Float_Kind))
366 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
367 else if (IN (kind, Access_Kind))
368 max_esize = POINTER_SIZE * 2;
370 max_esize = LONG_LONG_TYPE_SIZE;
372 if (esize > max_esize)
376 esize = LONG_LONG_TYPE_SIZE;
382 /* If this is a use of a deferred constant without address clause,
383 get its full definition. */
385 && No (Address_Clause (gnat_entity))
386 && Present (Full_View (gnat_entity)))
389 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
394 /* If we have an external constant that we are not defining, get the
395 expression that is was defined to represent. We may throw that
396 expression away later if it is not a constant. Do not retrieve the
397 expression if it is an aggregate or allocator, because in complex
398 instantiation contexts it may not be expanded */
400 && Present (Expression (Declaration_Node (gnat_entity)))
401 && !No_Initialization (Declaration_Node (gnat_entity))
402 && (Nkind (Expression (Declaration_Node (gnat_entity)))
404 && (Nkind (Expression (Declaration_Node (gnat_entity)))
406 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
408 /* Ignore deferred constant definitions without address clause since
409 they are processed fully in the front-end. If No_Initialization
410 is set, this is not a deferred constant but a constant whose value
411 is built manually. And constants that are renamings are handled
415 && No (Address_Clause (gnat_entity))
416 && !No_Initialization (Declaration_Node (gnat_entity))
417 && No (Renamed_Object (gnat_entity)))
419 gnu_decl = error_mark_node;
424 /* Ignore constant definitions already marked with the error node. See
425 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
428 && present_gnu_tree (gnat_entity)
429 && get_gnu_tree (gnat_entity) == error_mark_node)
431 maybe_present = true;
438 /* We used to special case VMS exceptions here to directly map them to
439 their associated condition code. Since this code had to be masked
440 dynamically to strip off the severity bits, this caused trouble in
441 the GCC/ZCX case because the "type" pointers we store in the tables
442 have to be static. We now don't special case here anymore, and let
443 the regular processing take place, which leaves us with a regular
444 exception data object for VMS exceptions too. The condition code
445 mapping is taken care of by the front end and the bitmasking by the
452 /* The GNAT record where the component was defined. */
453 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
455 /* If the variable is an inherited record component (in the case of
456 extended record types), just return the inherited entity, which
457 must be a FIELD_DECL. Likewise for discriminants.
458 For discriminants of untagged records which have explicit
459 stored discriminants, return the entity for the corresponding
460 stored discriminant. Also use Original_Record_Component
461 if the record has a private extension. */
462 if (Present (Original_Record_Component (gnat_entity))
463 && Original_Record_Component (gnat_entity) != gnat_entity)
466 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
467 gnu_expr, definition);
472 /* If the enclosing record has explicit stored discriminants,
473 then it is an untagged record. If the Corresponding_Discriminant
474 is not empty then this must be a renamed discriminant and its
475 Original_Record_Component must point to the corresponding explicit
476 stored discriminant (i.e. we should have taken the previous
478 else if (Present (Corresponding_Discriminant (gnat_entity))
479 && Is_Tagged_Type (gnat_record))
481 /* A tagged record has no explicit stored discriminants. */
482 gcc_assert (First_Discriminant (gnat_record)
483 == First_Stored_Discriminant (gnat_record));
485 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
486 gnu_expr, definition);
491 else if (Present (CR_Discriminant (gnat_entity))
492 && type_annotate_only)
494 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
495 gnu_expr, definition);
500 /* If the enclosing record has explicit stored discriminants, then
501 it is an untagged record. If the Corresponding_Discriminant
502 is not empty then this must be a renamed discriminant and its
503 Original_Record_Component must point to the corresponding explicit
504 stored discriminant (i.e. we should have taken the first
506 else if (Present (Corresponding_Discriminant (gnat_entity))
507 && (First_Discriminant (gnat_record)
508 != First_Stored_Discriminant (gnat_record)))
511 /* Otherwise, if we are not defining this and we have no GCC type
512 for the containing record, make one for it. Then we should
513 have made our own equivalent. */
514 else if (!definition && !present_gnu_tree (gnat_record))
516 /* ??? If this is in a record whose scope is a protected
517 type and we have an Original_Record_Component, use it.
518 This is a workaround for major problems in protected type
520 Entity_Id Scop = Scope (Scope (gnat_entity));
521 if ((Is_Protected_Type (Scop)
522 || (Is_Private_Type (Scop)
523 && Present (Full_View (Scop))
524 && Is_Protected_Type (Full_View (Scop))))
525 && Present (Original_Record_Component (gnat_entity)))
528 = gnat_to_gnu_entity (Original_Record_Component
535 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
536 gnu_decl = get_gnu_tree (gnat_entity);
542 /* Here we have no GCC type and this is a reference rather than a
543 definition. This should never happen. Most likely the cause is
544 reference before declaration in the gnat tree for gnat_entity. */
548 case E_Loop_Parameter:
549 case E_Out_Parameter:
552 /* Simple variables, loop variables, Out parameters, and exceptions. */
555 bool used_by_ref = false;
557 = ((kind == E_Constant || kind == E_Variable)
558 && Is_True_Constant (gnat_entity)
559 && !Treat_As_Volatile (gnat_entity)
560 && (((Nkind (Declaration_Node (gnat_entity))
561 == N_Object_Declaration)
562 && Present (Expression (Declaration_Node (gnat_entity))))
563 || Present (Renamed_Object (gnat_entity))));
564 bool inner_const_flag = const_flag;
565 bool static_p = Is_Statically_Allocated (gnat_entity);
566 bool mutable_p = false;
567 tree gnu_ext_name = NULL_TREE;
568 tree renamed_obj = NULL_TREE;
569 tree gnu_object_size;
571 if (Present (Renamed_Object (gnat_entity)) && !definition)
573 if (kind == E_Exception)
574 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
577 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
580 /* Get the type after elaborating the renamed object. */
581 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
583 /* For a debug renaming declaration, build a pure debug entity. */
584 if (Present (Debug_Renaming_Link (gnat_entity)))
587 gnu_decl = build_decl (input_location,
588 VAR_DECL, gnu_entity_name, gnu_type);
589 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
590 if (global_bindings_p ())
591 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
593 addr = stack_pointer_rtx;
594 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
595 gnat_pushdecl (gnu_decl, gnat_entity);
599 /* If this is a loop variable, its type should be the base type.
600 This is because the code for processing a loop determines whether
601 a normal loop end test can be done by comparing the bounds of the
602 loop against those of the base type, which is presumed to be the
603 size used for computation. But this is not correct when the size
604 of the subtype is smaller than the type. */
605 if (kind == E_Loop_Parameter)
606 gnu_type = get_base_type (gnu_type);
608 /* Reject non-renamed objects whose types are unconstrained arrays or
609 any object whose type is a dummy type or VOID_TYPE. */
611 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
612 && No (Renamed_Object (gnat_entity)))
613 || TYPE_IS_DUMMY_P (gnu_type)
614 || TREE_CODE (gnu_type) == VOID_TYPE)
616 gcc_assert (type_annotate_only);
619 return error_mark_node;
622 /* If an alignment is specified, use it if valid. Note that exceptions
623 are objects but don't have an alignment. We must do this before we
624 validate the size, since the alignment can affect the size. */
625 if (kind != E_Exception && Known_Alignment (gnat_entity))
627 gcc_assert (Present (Alignment (gnat_entity)));
628 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
629 TYPE_ALIGN (gnu_type));
630 /* No point in changing the type if there is an address clause
631 as the final type of the object will be a reference type. */
632 if (Present (Address_Clause (gnat_entity)))
636 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
637 false, false, definition, true);
640 /* If we are defining the object, see if it has a Size value and
641 validate it if so. If we are not defining the object and a Size
642 clause applies, simply retrieve the value. We don't want to ignore
643 the clause and it is expected to have been validated already. Then
644 get the new type, if any. */
646 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
647 gnat_entity, VAR_DECL, false,
648 Has_Size_Clause (gnat_entity));
649 else if (Has_Size_Clause (gnat_entity))
650 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
655 = make_type_from_size (gnu_type, gnu_size,
656 Has_Biased_Representation (gnat_entity));
658 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
659 gnu_size = NULL_TREE;
662 /* If this object has self-referential size, it must be a record with
663 a default value. We are supposed to allocate an object of the
664 maximum size in this case unless it is a constant with an
665 initializing expression, in which case we can get the size from
666 that. Note that the resulting size may still be a variable, so
667 this may end up with an indirect allocation. */
668 if (No (Renamed_Object (gnat_entity))
669 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
671 if (gnu_expr && kind == E_Constant)
673 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
674 if (CONTAINS_PLACEHOLDER_P (size))
676 /* If the initializing expression is itself a constant,
677 despite having a nominal type with self-referential
678 size, we can get the size directly from it. */
679 if (TREE_CODE (gnu_expr) == COMPONENT_REF
681 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
682 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
683 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
684 || DECL_READONLY_ONCE_ELAB
685 (TREE_OPERAND (gnu_expr, 0))))
686 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
689 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
694 /* We may have no GNU_EXPR because No_Initialization is
695 set even though there's an Expression. */
696 else if (kind == E_Constant
697 && (Nkind (Declaration_Node (gnat_entity))
698 == N_Object_Declaration)
699 && Present (Expression (Declaration_Node (gnat_entity))))
701 = TYPE_SIZE (gnat_to_gnu_type
703 (Expression (Declaration_Node (gnat_entity)))));
706 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
711 /* If the size is zero bytes, make it one byte since some linkers have
712 trouble with zero-sized objects. If the object will have a
713 template, that will make it nonzero so don't bother. Also avoid
714 doing that for an object renaming or an object with an address
715 clause, as we would lose useful information on the view size
716 (e.g. for null array slices) and we are not allocating the object
719 && integer_zerop (gnu_size)
720 && !TREE_OVERFLOW (gnu_size))
721 || (TYPE_SIZE (gnu_type)
722 && integer_zerop (TYPE_SIZE (gnu_type))
723 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
724 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
725 || !Is_Array_Type (Etype (gnat_entity)))
726 && No (Renamed_Object (gnat_entity))
727 && No (Address_Clause (gnat_entity)))
728 gnu_size = bitsize_unit_node;
730 /* If this is an object with no specified size and alignment, and
731 if either it is atomic or we are not optimizing alignment for
732 space and it is composite and not an exception, an Out parameter
733 or a reference to another object, and the size of its type is a
734 constant, set the alignment to the smallest one which is not
735 smaller than the size, with an appropriate cap. */
736 if (!gnu_size && align == 0
737 && (Is_Atomic (gnat_entity)
738 || (!Optimize_Alignment_Space (gnat_entity)
739 && kind != E_Exception
740 && kind != E_Out_Parameter
741 && Is_Composite_Type (Etype (gnat_entity))
742 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
744 && No (Renamed_Object (gnat_entity))
745 && No (Address_Clause (gnat_entity))))
746 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
748 /* No point in jumping through all the hoops needed in order
749 to support BIGGEST_ALIGNMENT if we don't really have to.
750 So we cap to the smallest alignment that corresponds to
751 a known efficient memory access pattern of the target. */
752 unsigned int align_cap = Is_Atomic (gnat_entity)
754 : get_mode_alignment (ptr_mode);
756 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
757 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
760 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
762 /* But make sure not to under-align the object. */
763 if (align <= TYPE_ALIGN (gnu_type))
766 /* And honor the minimum valid atomic alignment, if any. */
767 #ifdef MINIMUM_ATOMIC_ALIGNMENT
768 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
769 align = MINIMUM_ATOMIC_ALIGNMENT;
773 /* If the object is set to have atomic components, find the component
774 type and validate it.
776 ??? Note that we ignore Has_Volatile_Components on objects; it's
777 not at all clear what to do in that case. */
779 if (Has_Atomic_Components (gnat_entity))
781 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
782 ? TREE_TYPE (gnu_type) : gnu_type);
784 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
785 && TYPE_MULTI_ARRAY_P (gnu_inner))
786 gnu_inner = TREE_TYPE (gnu_inner);
788 check_ok_for_atomic (gnu_inner, gnat_entity, true);
791 /* Now check if the type of the object allows atomic access. Note
792 that we must test the type, even if this object has size and
793 alignment to allow such access, because we will be going
794 inside the padded record to assign to the object. We could fix
795 this by always copying via an intermediate value, but it's not
796 clear it's worth the effort. */
797 if (Is_Atomic (gnat_entity))
798 check_ok_for_atomic (gnu_type, gnat_entity, false);
800 /* If this is an aliased object with an unconstrained nominal subtype,
801 make a type that includes the template. */
802 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
803 && Is_Array_Type (Etype (gnat_entity))
804 && !type_annotate_only)
807 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
810 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
811 concat_name (gnu_entity_name,
815 #ifdef MINIMUM_ATOMIC_ALIGNMENT
816 /* If the size is a constant and no alignment is specified, force
817 the alignment to be the minimum valid atomic alignment. The
818 restriction on constant size avoids problems with variable-size
819 temporaries; if the size is variable, there's no issue with
820 atomic access. Also don't do this for a constant, since it isn't
821 necessary and can interfere with constant replacement. Finally,
822 do not do it for Out parameters since that creates an
823 size inconsistency with In parameters. */
824 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
825 && !FLOAT_TYPE_P (gnu_type)
826 && !const_flag && No (Renamed_Object (gnat_entity))
827 && !imported_p && No (Address_Clause (gnat_entity))
828 && kind != E_Out_Parameter
829 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
830 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
831 align = MINIMUM_ATOMIC_ALIGNMENT;
834 /* Make a new type with the desired size and alignment, if needed.
835 But do not take into account alignment promotions to compute the
836 size of the object. */
837 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
838 if (gnu_size || align > 0)
839 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
840 false, false, definition,
841 gnu_size ? true : false);
843 /* If this is a renaming, avoid as much as possible to create a new
844 object. However, in several cases, creating it is required.
845 This processing needs to be applied to the raw expression so
846 as to make it more likely to rename the underlying object. */
847 if (Present (Renamed_Object (gnat_entity)))
849 bool create_normal_object = false;
851 /* If the renamed object had padding, strip off the reference
852 to the inner object and reset our type. */
853 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
854 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
855 /* Strip useless conversions around the object. */
856 || (TREE_CODE (gnu_expr) == NOP_EXPR
857 && gnat_types_compatible_p
858 (TREE_TYPE (gnu_expr),
859 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
861 gnu_expr = TREE_OPERAND (gnu_expr, 0);
862 gnu_type = TREE_TYPE (gnu_expr);
865 /* Case 1: If this is a constant renaming stemming from a function
866 call, treat it as a normal object whose initial value is what
867 is being renamed. RM 3.3 says that the result of evaluating a
868 function call is a constant object. As a consequence, it can
869 be the inner object of a constant renaming. In this case, the
870 renaming must be fully instantiated, i.e. it cannot be a mere
871 reference to (part of) an existing object. */
874 tree inner_object = gnu_expr;
875 while (handled_component_p (inner_object))
876 inner_object = TREE_OPERAND (inner_object, 0);
877 if (TREE_CODE (inner_object) == CALL_EXPR)
878 create_normal_object = true;
881 /* Otherwise, see if we can proceed with a stabilized version of
882 the renamed entity or if we need to make a new object. */
883 if (!create_normal_object)
885 tree maybe_stable_expr = NULL_TREE;
888 /* Case 2: If the renaming entity need not be materialized and
889 the renamed expression is something we can stabilize, use
890 that for the renaming. At the global level, we can only do
891 this if we know no SAVE_EXPRs need be made, because the
892 expression we return might be used in arbitrary conditional
893 branches so we must force the SAVE_EXPRs evaluation
894 immediately and this requires a function context. */
895 if (!Materialize_Entity (gnat_entity)
896 && (!global_bindings_p ()
897 || (staticp (gnu_expr)
898 && !TREE_SIDE_EFFECTS (gnu_expr))))
901 = gnat_stabilize_reference (gnu_expr, true, &stable);
905 /* ??? No DECL_EXPR is created so we need to mark
906 the expression manually lest it is shared. */
907 if (global_bindings_p ())
908 MARK_VISITED (maybe_stable_expr);
909 gnu_decl = maybe_stable_expr;
910 save_gnu_tree (gnat_entity, gnu_decl, true);
912 annotate_object (gnat_entity, gnu_type, NULL_TREE,
917 /* The stabilization failed. Keep maybe_stable_expr
918 untouched here to let the pointer case below know
919 about that failure. */
922 /* Case 3: If this is a constant renaming and creating a
923 new object is allowed and cheap, treat it as a normal
924 object whose initial value is what is being renamed. */
926 && !Is_Composite_Type
927 (Underlying_Type (Etype (gnat_entity))))
930 /* Case 4: Make this into a constant pointer to the object we
931 are to rename and attach the object to the pointer if it is
932 something we can stabilize.
934 From the proper scope, attached objects will be referenced
935 directly instead of indirectly via the pointer to avoid
936 subtle aliasing problems with non-addressable entities.
937 They have to be stable because we must not evaluate the
938 variables in the expression every time the renaming is used.
939 The pointer is called a "renaming" pointer in this case.
941 In the rare cases where we cannot stabilize the renamed
942 object, we just make a "bare" pointer, and the renamed
943 entity is always accessed indirectly through it. */
946 gnu_type = build_reference_type (gnu_type);
947 inner_const_flag = TREE_READONLY (gnu_expr);
950 /* If the previous attempt at stabilizing failed, there
951 is no point in trying again and we reuse the result
952 without attaching it to the pointer. In this case it
953 will only be used as the initializing expression of
954 the pointer and thus needs no special treatment with
955 regard to multiple evaluations. */
956 if (maybe_stable_expr)
959 /* Otherwise, try to stabilize and attach the expression
960 to the pointer if the stabilization succeeds.
962 Note that this might introduce SAVE_EXPRs and we don't
963 check whether we're at the global level or not. This
964 is fine since we are building a pointer initializer and
965 neither the pointer nor the initializing expression can
966 be accessed before the pointer elaboration has taken
967 place in a correct program.
969 These SAVE_EXPRs will be evaluated at the right place
970 by either the evaluation of the initializer for the
971 non-global case or the elaboration code for the global
972 case, and will be attached to the elaboration procedure
973 in the latter case. */
977 = gnat_stabilize_reference (gnu_expr, true, &stable);
980 renamed_obj = maybe_stable_expr;
982 /* Attaching is actually performed downstream, as soon
983 as we have a VAR_DECL for the pointer we make. */
987 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
989 gnu_size = NULL_TREE;
995 /* Make a volatile version of this object's type if we are to make
996 the object volatile. We also interpret 13.3(19) conservatively
997 and disallow any optimizations for such a non-constant object. */
998 if ((Treat_As_Volatile (gnat_entity)
1000 && (Is_Exported (gnat_entity)
1001 || Is_Imported (gnat_entity)
1002 || Present (Address_Clause (gnat_entity)))))
1003 && !TYPE_VOLATILE (gnu_type))
1004 gnu_type = build_qualified_type (gnu_type,
1005 (TYPE_QUALS (gnu_type)
1006 | TYPE_QUAL_VOLATILE));
1008 /* If we are defining an aliased object whose nominal subtype is
1009 unconstrained, the object is a record that contains both the
1010 template and the object. If there is an initializer, it will
1011 have already been converted to the right type, but we need to
1012 create the template if there is no initializer. */
1015 && TREE_CODE (gnu_type) == RECORD_TYPE
1016 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1017 /* Beware that padding might have been introduced above. */
1018 || (TYPE_PADDING_P (gnu_type)
1019 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1021 && TYPE_CONTAINS_TEMPLATE_P
1022 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1025 = TYPE_PADDING_P (gnu_type)
1026 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1027 : TYPE_FIELDS (gnu_type);
1030 = gnat_build_constructor
1034 build_template (TREE_TYPE (template_field),
1035 TREE_TYPE (TREE_CHAIN (template_field)),
1040 /* Convert the expression to the type of the object except in the
1041 case where the object's type is unconstrained or the object's type
1042 is a padded record whose field is of self-referential size. In
1043 the former case, converting will generate unnecessary evaluations
1044 of the CONSTRUCTOR to compute the size and in the latter case, we
1045 want to only copy the actual data. */
1047 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1048 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1049 && !(TYPE_IS_PADDING_P (gnu_type)
1050 && CONTAINS_PLACEHOLDER_P
1051 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1052 gnu_expr = convert (gnu_type, gnu_expr);
1054 /* If this is a pointer and it does not have an initializing
1055 expression, initialize it to NULL, unless the object is
1058 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1059 && !Is_Imported (gnat_entity) && !gnu_expr)
1060 gnu_expr = integer_zero_node;
1062 /* If we are defining the object and it has an Address clause, we must
1063 either get the address expression from the saved GCC tree for the
1064 object if it has a Freeze node, or elaborate the address expression
1065 here since the front-end has guaranteed that the elaboration has no
1066 effects in this case. */
1067 if (definition && Present (Address_Clause (gnat_entity)))
1070 = present_gnu_tree (gnat_entity)
1071 ? get_gnu_tree (gnat_entity)
1072 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)));
1074 save_gnu_tree (gnat_entity, NULL_TREE, false);
1076 /* Ignore the size. It's either meaningless or was handled
1078 gnu_size = NULL_TREE;
1079 /* Convert the type of the object to a reference type that can
1080 alias everything as per 13.3(19). */
1082 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1083 gnu_address = convert (gnu_type, gnu_address);
1085 const_flag = !Is_Public (gnat_entity)
1086 || compile_time_known_address_p (Expression (Address_Clause
1089 /* If this is a deferred constant, the initializer is attached to
1091 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1094 (Expression (Declaration_Node (Full_View (gnat_entity))));
1096 /* If we don't have an initializing expression for the underlying
1097 variable, the initializing expression for the pointer is the
1098 specified address. Otherwise, we have to make a COMPOUND_EXPR
1099 to assign both the address and the initial value. */
1101 gnu_expr = gnu_address;
1104 = build2 (COMPOUND_EXPR, gnu_type,
1106 (MODIFY_EXPR, NULL_TREE,
1107 build_unary_op (INDIRECT_REF, NULL_TREE,
1113 /* If it has an address clause and we are not defining it, mark it
1114 as an indirect object. Likewise for Stdcall objects that are
1116 if ((!definition && Present (Address_Clause (gnat_entity)))
1117 || (Is_Imported (gnat_entity)
1118 && Has_Stdcall_Convention (gnat_entity)))
1120 /* Convert the type of the object to a reference type that can
1121 alias everything as per 13.3(19). */
1123 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1124 gnu_size = NULL_TREE;
1126 /* No point in taking the address of an initializing expression
1127 that isn't going to be used. */
1128 gnu_expr = NULL_TREE;
1130 /* If it has an address clause whose value is known at compile
1131 time, make the object a CONST_DECL. This will avoid a
1132 useless dereference. */
1133 if (Present (Address_Clause (gnat_entity)))
1135 Node_Id gnat_address
1136 = Expression (Address_Clause (gnat_entity));
1138 if (compile_time_known_address_p (gnat_address))
1140 gnu_expr = gnat_to_gnu (gnat_address);
1148 /* If we are at top level and this object is of variable size,
1149 make the actual type a hidden pointer to the real type and
1150 make the initializer be a memory allocation and initialization.
1151 Likewise for objects we aren't defining (presumed to be
1152 external references from other packages), but there we do
1153 not set up an initialization.
1155 If the object's size overflows, make an allocator too, so that
1156 Storage_Error gets raised. Note that we will never free
1157 such memory, so we presume it never will get allocated. */
1159 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1160 global_bindings_p () || !definition
1163 && ! allocatable_size_p (gnu_size,
1164 global_bindings_p () || !definition
1167 gnu_type = build_reference_type (gnu_type);
1168 gnu_size = NULL_TREE;
1172 /* In case this was a aliased object whose nominal subtype is
1173 unconstrained, the pointer above will be a thin pointer and
1174 build_allocator will automatically make the template.
1176 If we have a template initializer only (that we made above),
1177 pretend there is none and rely on what build_allocator creates
1178 again anyway. Otherwise (if we have a full initializer), get
1179 the data part and feed that to build_allocator.
1181 If we are elaborating a mutable object, tell build_allocator to
1182 ignore a possibly simpler size from the initializer, if any, as
1183 we must allocate the maximum possible size in this case. */
1187 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1189 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1190 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1193 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1195 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1196 && 1 == VEC_length (constructor_elt,
1197 CONSTRUCTOR_ELTS (gnu_expr)))
1201 = build_component_ref
1202 (gnu_expr, NULL_TREE,
1203 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1207 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1208 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1209 && !Is_Imported (gnat_entity))
1210 post_error ("?Storage_Error will be raised at run-time!",
1214 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1215 Empty, Empty, gnat_entity, mutable_p);
1219 gnu_expr = NULL_TREE;
1224 /* If this object would go into the stack and has an alignment larger
1225 than the largest stack alignment the back-end can honor, resort to
1226 a variable of "aligning type". */
1227 if (!global_bindings_p () && !static_p && definition
1228 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1230 /* Create the new variable. No need for extra room before the
1231 aligned field as this is in automatic storage. */
1233 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1234 TYPE_SIZE_UNIT (gnu_type),
1235 BIGGEST_ALIGNMENT, 0);
1237 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1238 NULL_TREE, gnu_new_type, NULL_TREE, false,
1239 false, false, false, NULL, gnat_entity);
1241 /* Initialize the aligned field if we have an initializer. */
1244 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1246 (gnu_new_var, NULL_TREE,
1247 TYPE_FIELDS (gnu_new_type), false),
1251 /* And setup this entity as a reference to the aligned field. */
1252 gnu_type = build_reference_type (gnu_type);
1255 (ADDR_EXPR, gnu_type,
1256 build_component_ref (gnu_new_var, NULL_TREE,
1257 TYPE_FIELDS (gnu_new_type), false));
1259 gnu_size = NULL_TREE;
1265 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1266 | TYPE_QUAL_CONST));
1268 /* Convert the expression to the type of the object except in the
1269 case where the object's type is unconstrained or the object's type
1270 is a padded record whose field is of self-referential size. In
1271 the former case, converting will generate unnecessary evaluations
1272 of the CONSTRUCTOR to compute the size and in the latter case, we
1273 want to only copy the actual data. */
1275 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1276 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1277 && !(TYPE_IS_PADDING_P (gnu_type)
1278 && CONTAINS_PLACEHOLDER_P
1279 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1280 gnu_expr = convert (gnu_type, gnu_expr);
1282 /* If this name is external or there was a name specified, use it,
1283 unless this is a VMS exception object since this would conflict
1284 with the symbol we need to export in addition. Don't use the
1285 Interface_Name if there is an address clause (see CD30005). */
1286 if (!Is_VMS_Exception (gnat_entity)
1287 && ((Present (Interface_Name (gnat_entity))
1288 && No (Address_Clause (gnat_entity)))
1289 || (Is_Public (gnat_entity)
1290 && (!Is_Imported (gnat_entity)
1291 || Is_Exported (gnat_entity)))))
1292 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1294 /* If this is constant initialized to a static constant and the
1295 object has an aggregate type, force it to be statically
1296 allocated. This will avoid an initialization copy. */
1297 if (!static_p && const_flag
1298 && gnu_expr && TREE_CONSTANT (gnu_expr)
1299 && AGGREGATE_TYPE_P (gnu_type)
1300 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1301 && !(TYPE_IS_PADDING_P (gnu_type)
1302 && !host_integerp (TYPE_SIZE_UNIT
1303 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1306 gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1307 gnu_expr, const_flag,
1308 Is_Public (gnat_entity),
1309 imported_p || !definition,
1310 static_p, attr_list, gnat_entity);
1311 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1312 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1313 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1315 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1316 if (global_bindings_p ())
1318 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1319 record_global_renaming_pointer (gnu_decl);
1323 if (definition && DECL_SIZE_UNIT (gnu_decl)
1324 && get_block_jmpbuf_decl ()
1325 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1326 || (flag_stack_check == GENERIC_STACK_CHECK
1327 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1328 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1329 add_stmt_with_node (build_call_1_expr
1330 (update_setjmp_buf_decl,
1331 build_unary_op (ADDR_EXPR, NULL_TREE,
1332 get_block_jmpbuf_decl ())),
1335 /* If we are defining an Out parameter and we're not optimizing,
1336 create a fake PARM_DECL for debugging purposes and make it
1337 point to the VAR_DECL. Suppress debug info for the latter
1338 but make sure it will still live on the stack so it can be
1339 accessed from within the debugger through the PARM_DECL. */
1340 if (kind == E_Out_Parameter && definition && !optimize)
1342 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1343 gnat_pushdecl (param, gnat_entity);
1344 SET_DECL_VALUE_EXPR (param, gnu_decl);
1345 DECL_HAS_VALUE_EXPR_P (param) = 1;
1347 debug_info_p = false;
1349 DECL_IGNORED_P (param) = 1;
1350 TREE_ADDRESSABLE (gnu_decl) = 1;
1353 /* If this is a public constant or we're not optimizing and we're not
1354 making a VAR_DECL for it, make one just for export or debugger use.
1355 Likewise if the address is taken or if either the object or type is
1356 aliased. Make an external declaration for a reference, unless this
1357 is a Standard entity since there no real symbol at the object level
1359 if (TREE_CODE (gnu_decl) == CONST_DECL
1360 && (definition || Sloc (gnat_entity) > Standard_Location)
1361 && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
1363 || Address_Taken (gnat_entity)
1364 || Is_Aliased (gnat_entity)
1365 || Is_Aliased (Etype (gnat_entity))))
1368 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1369 gnu_expr, true, Is_Public (gnat_entity),
1370 !definition, static_p, attr_list,
1373 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1375 /* As debugging information will be generated for the variable,
1376 do not generate information for the constant. */
1377 DECL_IGNORED_P (gnu_decl) = 1;
1380 /* If this is a constant, even if we don't need a true variable, we
1381 may need to avoid returning the initializer in every case. That
1382 can happen for the address of a (constant) constructor because,
1383 upon dereferencing it, the constructor will be reinjected in the
1384 tree, which may not be valid in every case; see lvalue_required_p
1385 for more details. */
1386 if (TREE_CODE (gnu_decl) == CONST_DECL)
1387 DECL_CONST_ADDRESS_P (gnu_decl) = constructor_address_p (gnu_expr);
1389 /* If this is declared in a block that contains a block with an
1390 exception handler, we must force this variable in memory to
1391 suppress an invalid optimization. */
1392 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1393 && Exception_Mechanism != Back_End_Exceptions)
1394 TREE_ADDRESSABLE (gnu_decl) = 1;
1396 /* Back-annotate Esize and Alignment of the object if not already
1397 known. Note that we pick the values of the type, not those of
1398 the object, to shield ourselves from low-level platform-dependent
1399 adjustments like alignment promotion. This is both consistent with
1400 all the treatment above, where alignment and size are set on the
1401 type of the object and not on the object directly, and makes it
1402 possible to support all confirming representation clauses. */
1403 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1409 /* Return a TYPE_DECL for "void" that we previously made. */
1410 gnu_decl = TYPE_NAME (void_type_node);
1413 case E_Enumeration_Type:
1414 /* A special case: for the types Character and Wide_Character in
1415 Standard, we do not list all the literals. So if the literals
1416 are not specified, make this an unsigned type. */
1417 if (No (First_Literal (gnat_entity)))
1419 gnu_type = make_unsigned_type (esize);
1420 TYPE_NAME (gnu_type) = gnu_entity_name;
1422 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1423 This is needed by the DWARF-2 back-end to distinguish between
1424 unsigned integer types and character types. */
1425 TYPE_STRING_FLAG (gnu_type) = 1;
1430 /* We have a list of enumeral constants in First_Literal. We make a
1431 CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
1432 be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
1433 whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
1434 value of the literal. But when we have a regular boolean type, we
1435 simplify this a little by using a BOOLEAN_TYPE. */
1436 bool is_boolean = Is_Boolean_Type (gnat_entity)
1437 && !Has_Non_Standard_Rep (gnat_entity);
1438 tree gnu_literal_list = NULL_TREE;
1439 Entity_Id gnat_literal;
1441 if (Is_Unsigned_Type (gnat_entity))
1442 gnu_type = make_unsigned_type (esize);
1444 gnu_type = make_signed_type (esize);
1446 TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
1448 for (gnat_literal = First_Literal (gnat_entity);
1449 Present (gnat_literal);
1450 gnat_literal = Next_Literal (gnat_literal))
1453 = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
1455 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1456 gnu_type, gnu_value, true, false, false,
1457 false, NULL, gnat_literal);
1459 save_gnu_tree (gnat_literal, gnu_literal, false);
1460 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1461 gnu_value, gnu_literal_list);
1465 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1467 /* Note that the bounds are updated at the end of this function
1468 to avoid an infinite recursion since they refer to the type. */
1472 case E_Signed_Integer_Type:
1473 case E_Ordinary_Fixed_Point_Type:
1474 case E_Decimal_Fixed_Point_Type:
1475 /* For integer types, just make a signed type the appropriate number
1477 gnu_type = make_signed_type (esize);
1480 case E_Modular_Integer_Type:
1482 /* For modular types, make the unsigned type of the proper number
1483 of bits and then set up the modulus, if required. */
1484 tree gnu_modulus, gnu_high = NULL_TREE;
1486 /* Packed array types are supposed to be subtypes only. */
1487 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1489 gnu_type = make_unsigned_type (esize);
1491 /* Get the modulus in this type. If it overflows, assume it is because
1492 it is equal to 2**Esize. Note that there is no overflow checking
1493 done on unsigned type, so we detect the overflow by looking for
1494 a modulus of zero, which is otherwise invalid. */
1495 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1497 if (!integer_zerop (gnu_modulus))
1499 TYPE_MODULAR_P (gnu_type) = 1;
1500 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1501 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1502 convert (gnu_type, integer_one_node));
1505 /* If the upper bound is not maximal, make an extra subtype. */
1507 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1509 tree gnu_subtype = make_unsigned_type (esize);
1510 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1511 TREE_TYPE (gnu_subtype) = gnu_type;
1512 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1513 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1514 gnu_type = gnu_subtype;
1519 case E_Signed_Integer_Subtype:
1520 case E_Enumeration_Subtype:
1521 case E_Modular_Integer_Subtype:
1522 case E_Ordinary_Fixed_Point_Subtype:
1523 case E_Decimal_Fixed_Point_Subtype:
1525 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1526 not want to call create_range_type since we would like each subtype
1527 node to be distinct. ??? Historically this was in preparation for
1528 when memory aliasing is implemented, but that's obsolete now given
1529 the call to relate_alias_sets below.
1531 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1532 this fact is used by the arithmetic conversion functions.
1534 We elaborate the Ancestor_Subtype if it is not in the current unit
1535 and one of our bounds is non-static. We do this to ensure consistent
1536 naming in the case where several subtypes share the same bounds, by
1537 elaborating the first such subtype first, thus using its name. */
1540 && Present (Ancestor_Subtype (gnat_entity))
1541 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1542 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1543 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1544 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1546 /* Set the precision to the Esize except for bit-packed arrays. */
1547 if (Is_Packed_Array_Type (gnat_entity)
1548 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1549 esize = UI_To_Int (RM_Size (gnat_entity));
1551 /* This should be an unsigned type if the base type is unsigned or
1552 if the lower bound is constant and non-negative or if the type
1554 if (Is_Unsigned_Type (Etype (gnat_entity))
1555 || Is_Unsigned_Type (gnat_entity)
1556 || Has_Biased_Representation (gnat_entity))
1557 gnu_type = make_unsigned_type (esize);
1559 gnu_type = make_signed_type (esize);
1560 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1562 SET_TYPE_RM_MIN_VALUE
1564 convert (TREE_TYPE (gnu_type),
1565 elaborate_expression (Type_Low_Bound (gnat_entity),
1566 gnat_entity, get_identifier ("L"),
1568 Needs_Debug_Info (gnat_entity))));
1570 SET_TYPE_RM_MAX_VALUE
1572 convert (TREE_TYPE (gnu_type),
1573 elaborate_expression (Type_High_Bound (gnat_entity),
1574 gnat_entity, get_identifier ("U"),
1576 Needs_Debug_Info (gnat_entity))));
1578 /* One of the above calls might have caused us to be elaborated,
1579 so don't blow up if so. */
1580 if (present_gnu_tree (gnat_entity))
1582 maybe_present = true;
1586 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1587 = Has_Biased_Representation (gnat_entity);
1589 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1590 TYPE_STUB_DECL (gnu_type)
1591 = create_type_stub_decl (gnu_entity_name, gnu_type);
1593 /* Inherit our alias set from what we're a subtype of. Subtypes
1594 are not different types and a pointer can designate any instance
1595 within a subtype hierarchy. */
1596 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1598 /* For a packed array, make the original array type a parallel type. */
1600 && Is_Packed_Array_Type (gnat_entity)
1601 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1602 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1604 (Original_Array_Type (gnat_entity)));
1606 /* We have to handle clauses that under-align the type specially. */
1607 if ((Present (Alignment_Clause (gnat_entity))
1608 || (Is_Packed_Array_Type (gnat_entity)
1610 (Alignment_Clause (Original_Array_Type (gnat_entity)))))
1611 && UI_Is_In_Int_Range (Alignment (gnat_entity)))
1613 align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
1614 if (align >= TYPE_ALIGN (gnu_type))
1618 /* If the type we are dealing with represents a bit-packed array,
1619 we need to have the bits left justified on big-endian targets
1620 and right justified on little-endian targets. We also need to
1621 ensure that when the value is read (e.g. for comparison of two
1622 such values), we only get the good bits, since the unused bits
1623 are uninitialized. Both goals are accomplished by wrapping up
1624 the modular type in an enclosing record type. */
1625 if (Is_Packed_Array_Type (gnat_entity)
1626 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1628 tree gnu_field_type, gnu_field;
1630 /* Set the RM size before wrapping up the original type. */
1631 SET_TYPE_RM_SIZE (gnu_type,
1632 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1633 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1635 /* Create a stripped-down declaration, mainly for debugging. */
1636 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1637 debug_info_p, gnat_entity);
1639 /* Now save it and build the enclosing record type. */
1640 gnu_field_type = gnu_type;
1642 gnu_type = make_node (RECORD_TYPE);
1643 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1644 TYPE_PACKED (gnu_type) = 1;
1645 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1646 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1647 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1649 /* Propagate the alignment of the modular type to the record type,
1650 unless there is an alignment clause that under-aligns the type.
1651 This means that bit-packed arrays are given "ceil" alignment for
1652 their size by default, which may seem counter-intuitive but makes
1653 it possible to overlay them on modular types easily. */
1654 TYPE_ALIGN (gnu_type)
1655 = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
1657 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1659 /* Don't notify the field as "addressable", since we won't be taking
1660 it's address and it would prevent create_field_decl from making a
1662 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1663 gnu_field_type, gnu_type, 1,
1664 NULL_TREE, bitsize_zero_node, 0);
1666 /* Do not emit debug info until after the parallel type is added. */
1667 finish_record_type (gnu_type, gnu_field, 2, false);
1668 compute_record_mode (gnu_type);
1669 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1673 /* Make the original array type a parallel type. */
1674 if (present_gnu_tree (Original_Array_Type (gnat_entity)))
1675 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1677 (Original_Array_Type (gnat_entity)));
1679 rest_of_record_type_compilation (gnu_type);
1683 /* If the type we are dealing with has got a smaller alignment than the
1684 natural one, we need to wrap it up in a record type and under-align
1685 the latter. We reuse the padding machinery for this purpose. */
1688 tree gnu_field_type, gnu_field;
1690 /* Set the RM size before wrapping up the type. */
1691 SET_TYPE_RM_SIZE (gnu_type,
1692 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1694 /* Create a stripped-down declaration, mainly for debugging. */
1695 create_type_decl (gnu_entity_name, gnu_type, NULL, true,
1696 debug_info_p, gnat_entity);
1698 /* Now save it and build the enclosing record type. */
1699 gnu_field_type = gnu_type;
1701 gnu_type = make_node (RECORD_TYPE);
1702 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1703 TYPE_PACKED (gnu_type) = 1;
1704 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
1705 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
1706 SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
1707 TYPE_ALIGN (gnu_type) = align;
1708 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1710 /* Don't notify the field as "addressable", since we won't be taking
1711 it's address and it would prevent create_field_decl from making a
1713 gnu_field = create_field_decl (get_identifier ("F"),
1714 gnu_field_type, gnu_type, 1,
1715 NULL_TREE, bitsize_zero_node, 0);
1717 finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
1718 compute_record_mode (gnu_type);
1719 TYPE_PADDING_P (gnu_type) = 1;
1724 case E_Floating_Point_Type:
1725 /* If this is a VAX floating-point type, use an integer of the proper
1726 size. All the operations will be handled with ASM statements. */
1727 if (Vax_Float (gnat_entity))
1729 gnu_type = make_signed_type (esize);
1730 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1731 SET_TYPE_DIGITS_VALUE (gnu_type,
1732 UI_To_gnu (Digits_Value (gnat_entity),
1737 /* The type of the Low and High bounds can be our type if this is
1738 a type from Standard, so set them at the end of the function. */
1739 gnu_type = make_node (REAL_TYPE);
1740 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1741 layout_type (gnu_type);
1744 case E_Floating_Point_Subtype:
1745 if (Vax_Float (gnat_entity))
1747 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1753 && Present (Ancestor_Subtype (gnat_entity))
1754 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1755 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1756 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1757 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1760 gnu_type = make_node (REAL_TYPE);
1761 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1762 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1763 TYPE_GCC_MIN_VALUE (gnu_type)
1764 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1765 TYPE_GCC_MAX_VALUE (gnu_type)
1766 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1767 layout_type (gnu_type);
1769 SET_TYPE_RM_MIN_VALUE
1771 convert (TREE_TYPE (gnu_type),
1772 elaborate_expression (Type_Low_Bound (gnat_entity),
1773 gnat_entity, get_identifier ("L"),
1775 Needs_Debug_Info (gnat_entity))));
1777 SET_TYPE_RM_MAX_VALUE
1779 convert (TREE_TYPE (gnu_type),
1780 elaborate_expression (Type_High_Bound (gnat_entity),
1781 gnat_entity, get_identifier ("U"),
1783 Needs_Debug_Info (gnat_entity))));
1785 /* One of the above calls might have caused us to be elaborated,
1786 so don't blow up if so. */
1787 if (present_gnu_tree (gnat_entity))
1789 maybe_present = true;
1793 /* Inherit our alias set from what we're a subtype of, as for
1794 integer subtypes. */
1795 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1799 /* Array and String Types and Subtypes
1801 Unconstrained array types are represented by E_Array_Type and
1802 constrained array types are represented by E_Array_Subtype. There
1803 are no actual objects of an unconstrained array type; all we have
1804 are pointers to that type.
1806 The following fields are defined on array types and subtypes:
1808 Component_Type Component type of the array.
1809 Number_Dimensions Number of dimensions (an int).
1810 First_Index Type of first index. */
1815 Entity_Id gnat_index, gnat_name;
1816 const bool convention_fortran_p
1817 = (Convention (gnat_entity) == Convention_Fortran);
1818 const int ndim = Number_Dimensions (gnat_entity);
1819 tree gnu_template_fields = NULL_TREE;
1820 tree gnu_template_type = make_node (RECORD_TYPE);
1821 tree gnu_template_reference;
1822 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1823 tree gnu_fat_type = make_node (RECORD_TYPE);
1824 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
1825 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
1826 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
1829 TYPE_NAME (gnu_template_type)
1830 = create_concat_name (gnat_entity, "XUB");
1832 /* Make a node for the array. If we are not defining the array
1833 suppress expanding incomplete types. */
1834 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1838 defer_incomplete_level++;
1839 this_deferred = true;
1842 /* Build the fat pointer type. Use a "void *" object instead of
1843 a pointer to the array type since we don't have the array type
1844 yet (it will reference the fat pointer via the bounds). */
1845 tem = chainon (chainon (NULL_TREE,
1846 create_field_decl (get_identifier ("P_ARRAY"),
1849 NULL_TREE, NULL_TREE, 0)),
1850 create_field_decl (get_identifier ("P_BOUNDS"),
1853 NULL_TREE, NULL_TREE, 0));
1855 /* Make sure we can put this into a register. */
1856 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1858 /* Do not emit debug info for this record type since the types of its
1859 fields are still incomplete at this point. */
1860 finish_record_type (gnu_fat_type, tem, 0, false);
1861 TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
1863 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1864 is the fat pointer. This will be used to access the individual
1865 fields once we build them. */
1866 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1867 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1868 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1869 gnu_template_reference
1870 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1871 TREE_READONLY (gnu_template_reference) = 1;
1873 /* Now create the GCC type for each index and add the fields for that
1874 index to the template. */
1875 for (index = (convention_fortran_p ? ndim - 1 : 0),
1876 gnat_index = First_Index (gnat_entity);
1877 0 <= index && index < ndim;
1878 index += (convention_fortran_p ? - 1 : 1),
1879 gnat_index = Next_Index (gnat_index))
1881 char field_name[16];
1882 tree gnu_index_base_type
1883 = get_unpadded_type (Base_Type (Etype (gnat_index)));
1884 tree gnu_low_field, gnu_high_field, gnu_low, gnu_high, gnu_max;
1886 /* Make the FIELD_DECLs for the low and high bounds of this
1887 type and then make extractions of these fields from the
1889 sprintf (field_name, "LB%d", index);
1890 gnu_low_field = create_field_decl (get_identifier (field_name),
1891 gnu_index_base_type,
1892 gnu_template_type, 0,
1893 NULL_TREE, NULL_TREE, 0);
1894 Sloc_to_locus (Sloc (gnat_entity),
1895 &DECL_SOURCE_LOCATION (gnu_low_field));
1897 field_name[0] = 'U';
1898 gnu_high_field = create_field_decl (get_identifier (field_name),
1899 gnu_index_base_type,
1900 gnu_template_type, 0,
1901 NULL_TREE, NULL_TREE, 0);
1902 Sloc_to_locus (Sloc (gnat_entity),
1903 &DECL_SOURCE_LOCATION (gnu_high_field));
1905 gnu_temp_fields[index] = chainon (gnu_low_field, gnu_high_field);
1907 /* We can't use build_component_ref here since the template type
1908 isn't complete yet. */
1909 gnu_low = build3 (COMPONENT_REF, gnu_index_base_type,
1910 gnu_template_reference, gnu_low_field,
1912 gnu_high = build3 (COMPONENT_REF, gnu_index_base_type,
1913 gnu_template_reference, gnu_high_field,
1915 TREE_READONLY (gnu_low) = TREE_READONLY (gnu_high) = 1;
1917 /* Compute the size of this dimension. */
1919 = build3 (COND_EXPR, gnu_index_base_type,
1920 build2 (GE_EXPR, integer_type_node, gnu_high, gnu_low),
1922 build2 (MINUS_EXPR, gnu_index_base_type,
1923 gnu_low, fold_convert (gnu_index_base_type,
1924 integer_one_node)));
1926 /* Make a range type with the new range in the Ada base type.
1927 Then make an index type with the size range in sizetype. */
1928 gnu_index_types[index]
1929 = create_index_type (convert (sizetype, gnu_low),
1930 convert (sizetype, gnu_max),
1931 create_range_type (gnu_index_base_type,
1935 /* Update the maximum size of the array in elements. */
1938 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
1940 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
1942 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
1944 = size_binop (MAX_EXPR,
1945 size_binop (PLUS_EXPR, size_one_node,
1946 size_binop (MINUS_EXPR,
1950 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1951 && TREE_OVERFLOW (gnu_this_max))
1952 gnu_max_size = NULL_TREE;
1955 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1958 TYPE_NAME (gnu_index_types[index])
1959 = create_concat_name (gnat_entity, field_name);
1962 for (index = 0; index < ndim; index++)
1964 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1966 /* Install all the fields into the template. */
1967 finish_record_type (gnu_template_type, gnu_template_fields, 0,
1969 TYPE_READONLY (gnu_template_type) = 1;
1971 /* Now make the array of arrays and update the pointer to the array
1972 in the fat pointer. Note that it is the first field. */
1973 tem = gnat_to_gnu_component_type (gnat_entity, definition,
1976 /* If Component_Size is not already specified, annotate it with the
1977 size of the component. */
1978 if (Unknown_Component_Size (gnat_entity))
1979 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1981 /* Compute the maximum size of the array in units and bits. */
1984 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1985 TYPE_SIZE_UNIT (tem));
1986 gnu_max_size = size_binop (MULT_EXPR,
1987 convert (bitsizetype, gnu_max_size),
1991 gnu_max_size_unit = NULL_TREE;
1993 /* Now build the array type. */
1994 for (index = ndim - 1; index >= 0; index--)
1996 tem = build_array_type (tem, gnu_index_types[index]);
1997 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1998 if (array_type_has_nonaliased_component (tem, gnat_entity))
1999 TYPE_NONALIASED_COMPONENT (tem) = 1;
2002 /* If an alignment is specified, use it if valid. But ignore it
2003 for the original type of packed array types. If the alignment
2004 was requested with an explicit alignment clause, state so. */
2005 if (No (Packed_Array_Type (gnat_entity))
2006 && Known_Alignment (gnat_entity))
2009 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2011 if (Present (Alignment_Clause (gnat_entity)))
2012 TYPE_USER_ALIGN (tem) = 1;
2015 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
2016 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2018 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2019 corresponding fat pointer. */
2020 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
2021 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2022 SET_TYPE_MODE (gnu_type, BLKmode);
2023 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2024 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2026 /* If the maximum size doesn't overflow, use it. */
2028 && TREE_CODE (gnu_max_size) == INTEGER_CST
2029 && !TREE_OVERFLOW (gnu_max_size)
2030 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2031 && !TREE_OVERFLOW (gnu_max_size_unit))
2033 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2035 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2036 TYPE_SIZE_UNIT (tem));
2039 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2040 tem, NULL, !Comes_From_Source (gnat_entity),
2041 debug_info_p, gnat_entity);
2043 /* Give the fat pointer type a name. If this is a packed type, tell
2044 the debugger how to interpret the underlying bits. */
2045 if (Present (Packed_Array_Type (gnat_entity)))
2046 gnat_name = Packed_Array_Type (gnat_entity);
2048 gnat_name = gnat_entity;
2049 create_type_decl (create_concat_name (gnat_name, "XUP"),
2050 gnu_fat_type, NULL, true,
2051 debug_info_p, gnat_entity);
2053 /* Create the type to be used as what a thin pointer designates: an
2054 record type for the object and its template with the field offsets
2055 shifted to have the template at a negative offset. */
2056 tem = build_unc_object_type (gnu_template_type, tem,
2057 create_concat_name (gnat_name, "XUT"));
2058 shift_unc_components_for_thin_pointers (tem);
2060 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2061 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2065 case E_String_Subtype:
2066 case E_Array_Subtype:
2068 /* This is the actual data type for array variables. Multidimensional
2069 arrays are implemented as arrays of arrays. Note that arrays which
2070 have sparse enumeration subtypes as index components create sparse
2071 arrays, which is obviously space inefficient but so much easier to
2074 Also note that the subtype never refers to the unconstrained array
2075 type, which is somewhat at variance with Ada semantics.
2077 First check to see if this is simply a renaming of the array type.
2078 If so, the result is the array type. */
2080 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2081 if (!Is_Constrained (gnat_entity))
2085 Entity_Id gnat_index, gnat_base_index;
2086 const bool convention_fortran_p
2087 = (Convention (gnat_entity) == Convention_Fortran);
2088 const int ndim = Number_Dimensions (gnat_entity);
2089 tree gnu_base_type = gnu_type;
2090 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
2091 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2092 bool need_index_type_struct = false;
2095 /* First create the GCC type for each index and find out whether
2096 special types are needed for debugging information. */
2097 for (index = (convention_fortran_p ? ndim - 1 : 0),
2098 gnat_index = First_Index (gnat_entity),
2100 = First_Index (Implementation_Base_Type (gnat_entity));
2101 0 <= index && index < ndim;
2102 index += (convention_fortran_p ? - 1 : 1),
2103 gnat_index = Next_Index (gnat_index),
2104 gnat_base_index = Next_Index (gnat_base_index))
2106 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2108 = compare_tree_int (TYPE_RM_SIZE (gnu_index_type),
2109 TYPE_PRECISION (sizetype));
2110 const bool subrange_p = (prec_comp < 0)
2112 && TYPE_UNSIGNED (gnu_index_type)
2113 == TYPE_UNSIGNED (sizetype));
2114 const bool wider_p = (prec_comp > 0);
2115 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2116 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2117 tree gnu_min = convert (sizetype, gnu_orig_min);
2118 tree gnu_max = convert (sizetype, gnu_orig_max);
2119 tree gnu_base_index_type
2120 = get_unpadded_type (Etype (gnat_base_index));
2121 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2122 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2123 tree gnu_high, gnu_low;
2125 /* See if the base array type is already flat. If it is, we
2126 are probably compiling an ACATS test but it will cause the
2127 code below to malfunction if we don't handle it specially. */
2128 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2129 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2130 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2132 gnu_min = size_one_node;
2133 gnu_max = size_zero_node;
2137 /* Similarly, if one of the values overflows in sizetype and the
2138 range is null, use 1..0 for the sizetype bounds. */
2139 else if (!subrange_p
2140 && TREE_CODE (gnu_min) == INTEGER_CST
2141 && TREE_CODE (gnu_max) == INTEGER_CST
2142 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2143 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2145 gnu_min = size_one_node;
2146 gnu_max = size_zero_node;
2150 /* If the minimum and maximum values both overflow in sizetype,
2151 but the difference in the original type does not overflow in
2152 sizetype, ignore the overflow indication. */
2153 else if (!subrange_p
2154 && TREE_CODE (gnu_min) == INTEGER_CST
2155 && TREE_CODE (gnu_max) == INTEGER_CST
2156 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2159 fold_build2 (MINUS_EXPR, gnu_index_type,
2163 TREE_OVERFLOW (gnu_min) = 0;
2164 TREE_OVERFLOW (gnu_max) = 0;
2168 /* Compute the size of this dimension in the general case. We
2169 need to provide GCC with an upper bound to use but have to
2170 deal with the "superflat" case. There are three ways to do
2171 this. If we can prove that the array can never be superflat,
2172 we can just use the high bound of the index type. */
2173 else if (Nkind (gnat_index) == N_Range
2174 && cannot_be_superflat_p (gnat_index))
2177 /* Otherwise, if we can prove that the low bound minus one and
2178 the high bound cannot overflow, we can just use the expression
2179 MAX (hb, lb - 1). Similarly, if we can prove that the high
2180 bound plus one and the low bound cannot overflow, we can use
2181 the high bound as-is and MIN (hb + 1, lb) for the low bound.
2182 Otherwise, we have to fall back to the most general expression
2183 (hb >= lb) ? hb : lb - 1. Note that the comparison must be
2184 done in the original index type, to avoid any overflow during
2188 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2189 gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node);
2191 /* If gnu_high is a constant that has overflowed, the low
2192 bound is the smallest integer so cannot be the maximum.
2193 If gnu_low is a constant that has overflowed, the high
2194 bound is the highest integer so cannot be the minimum. */
2195 if ((TREE_CODE (gnu_high) == INTEGER_CST
2196 && TREE_OVERFLOW (gnu_high))
2197 || (TREE_CODE (gnu_low) == INTEGER_CST
2198 && TREE_OVERFLOW (gnu_low)))
2201 /* If the index type is a subrange and gnu_high a constant
2202 that hasn't overflowed, we can use the maximum. */
2203 else if (subrange_p && TREE_CODE (gnu_high) == INTEGER_CST)
2204 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2206 /* If the index type is a subrange and gnu_low a constant
2207 that hasn't overflowed, we can use the minimum. */
2208 else if (subrange_p && TREE_CODE (gnu_low) == INTEGER_CST)
2211 gnu_min = size_binop (MIN_EXPR, gnu_min, gnu_low);
2216 = build_cond_expr (sizetype,
2217 build_binary_op (GE_EXPR,
2224 gnu_index_types[index]
2225 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2228 /* Update the maximum size of the array in elements. Here we
2229 see if any constraint on the index type of the base type
2230 can be used in the case of self-referential bound on the
2231 index type of the subtype. We look for a non-"infinite"
2232 and non-self-referential bound from any type involved and
2233 handle each bound separately. */
2236 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2237 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2238 tree gnu_base_index_base_type
2239 = get_base_type (gnu_base_index_type);
2240 tree gnu_base_base_min
2241 = convert (sizetype,
2242 TYPE_MIN_VALUE (gnu_base_index_base_type));
2243 tree gnu_base_base_max
2244 = convert (sizetype,
2245 TYPE_MAX_VALUE (gnu_base_index_base_type));
2247 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2248 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2249 && !TREE_OVERFLOW (gnu_base_min)))
2250 gnu_base_min = gnu_min;
2252 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2253 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2254 && !TREE_OVERFLOW (gnu_base_max)))
2255 gnu_base_max = gnu_max;
2257 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2258 && TREE_OVERFLOW (gnu_base_min))
2259 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2260 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2261 && TREE_OVERFLOW (gnu_base_max))
2262 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2263 gnu_max_size = NULL_TREE;
2267 = size_binop (MAX_EXPR,
2268 size_binop (PLUS_EXPR, size_one_node,
2269 size_binop (MINUS_EXPR,
2274 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2275 && TREE_OVERFLOW (gnu_this_max))
2276 gnu_max_size = NULL_TREE;
2279 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2283 /* We need special types for debugging information to point to
2284 the index types if they have variable bounds, are not integer
2285 types, are biased or are wider than sizetype. */
2286 if (!integer_onep (gnu_orig_min)
2287 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2288 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2289 || (TREE_TYPE (gnu_index_type)
2290 && TREE_CODE (TREE_TYPE (gnu_index_type))
2292 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2294 need_index_type_struct = true;
2297 /* Then flatten: create the array of arrays. For an array type
2298 used to implement a packed array, get the component type from
2299 the original array type since the representation clauses that
2300 can affect it are on the latter. */
2301 if (Is_Packed_Array_Type (gnat_entity)
2302 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2304 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2305 for (index = ndim - 1; index >= 0; index--)
2306 gnu_type = TREE_TYPE (gnu_type);
2308 /* One of the above calls might have caused us to be elaborated,
2309 so don't blow up if so. */
2310 if (present_gnu_tree (gnat_entity))
2312 maybe_present = true;
2318 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2321 /* One of the above calls might have caused us to be elaborated,
2322 so don't blow up if so. */
2323 if (present_gnu_tree (gnat_entity))
2325 maybe_present = true;
2330 /* Compute the maximum size of the array in units and bits. */
2333 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2334 TYPE_SIZE_UNIT (gnu_type));
2335 gnu_max_size = size_binop (MULT_EXPR,
2336 convert (bitsizetype, gnu_max_size),
2337 TYPE_SIZE (gnu_type));
2340 gnu_max_size_unit = NULL_TREE;
2342 /* Now build the array type. */
2343 for (index = ndim - 1; index >= 0; index --)
2345 gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
2346 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2347 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2348 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2351 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2352 TYPE_STUB_DECL (gnu_type)
2353 = create_type_stub_decl (gnu_entity_name, gnu_type);
2355 /* If we are at file level and this is a multi-dimensional array,
2356 we need to make a variable corresponding to the stride of the
2357 inner dimensions. */
2358 if (global_bindings_p () && ndim > 1)
2360 tree gnu_str_name = get_identifier ("ST");
2363 for (gnu_arr_type = TREE_TYPE (gnu_type);
2364 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2365 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2366 gnu_str_name = concat_name (gnu_str_name, "ST"))
2368 tree eltype = TREE_TYPE (gnu_arr_type);
2370 TYPE_SIZE (gnu_arr_type)
2371 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2372 gnat_entity, gnu_str_name,
2375 /* ??? For now, store the size as a multiple of the
2376 alignment of the element type in bytes so that we
2377 can see the alignment from the tree. */
2378 TYPE_SIZE_UNIT (gnu_arr_type)
2380 (MULT_EXPR, sizetype,
2381 elaborate_expression_1
2382 (build_binary_op (EXACT_DIV_EXPR, sizetype,
2383 TYPE_SIZE_UNIT (gnu_arr_type),
2384 size_int (TYPE_ALIGN (eltype)
2386 gnat_entity, concat_name (gnu_str_name, "A_U"),
2388 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2390 /* ??? create_type_decl is not invoked on the inner types so
2391 the MULT_EXPR node built above will never be marked. */
2392 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2396 /* If we need to write out a record type giving the names of the
2397 bounds for debugging purposes, do it now and make the record
2398 type a parallel type. This is not needed for a packed array
2399 since the bounds are conveyed by the original array type. */
2400 if (need_index_type_struct
2402 && !Is_Packed_Array_Type (gnat_entity))
2404 tree gnu_bound_rec = make_node (RECORD_TYPE);
2405 tree gnu_field_list = NULL_TREE;
2408 TYPE_NAME (gnu_bound_rec)
2409 = create_concat_name (gnat_entity, "XA");
2411 for (index = ndim - 1; index >= 0; index--)
2413 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2414 tree gnu_index_name = TYPE_NAME (gnu_index);
2416 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2417 gnu_index_name = DECL_NAME (gnu_index_name);
2419 /* Make sure to reference the types themselves, and not just
2420 their names, as the debugger may fall back on them. */
2421 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2423 0, NULL_TREE, NULL_TREE, 0);
2424 TREE_CHAIN (gnu_field) = gnu_field_list;
2425 gnu_field_list = gnu_field;
2428 finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
2429 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2432 /* Otherwise, for a packed array, make the original array type a
2434 else if (debug_info_p
2435 && Is_Packed_Array_Type (gnat_entity)
2436 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2437 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2439 (Original_Array_Type (gnat_entity)));
2441 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2442 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2443 = (Is_Packed_Array_Type (gnat_entity)
2444 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2446 /* If the size is self-referential and the maximum size doesn't
2447 overflow, use it. */
2448 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2450 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2451 && TREE_OVERFLOW (gnu_max_size))
2452 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2453 && TREE_OVERFLOW (gnu_max_size_unit)))
2455 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2456 TYPE_SIZE (gnu_type));
2457 TYPE_SIZE_UNIT (gnu_type)
2458 = size_binop (MIN_EXPR, gnu_max_size_unit,
2459 TYPE_SIZE_UNIT (gnu_type));
2462 /* Set our alias set to that of our base type. This gives all
2463 array subtypes the same alias set. */
2464 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2466 /* If this is a packed type, make this type the same as the packed
2467 array type, but do some adjusting in the type first. */
2468 if (Present (Packed_Array_Type (gnat_entity)))
2470 Entity_Id gnat_index;
2473 /* First finish the type we had been making so that we output
2474 debugging information for it. */
2475 if (Treat_As_Volatile (gnat_entity))
2477 = build_qualified_type (gnu_type,
2478 TYPE_QUALS (gnu_type)
2479 | TYPE_QUAL_VOLATILE);
2481 /* Make it artificial only if the base type was artificial too.
2482 That's sort of "morally" true and will make it possible for
2483 the debugger to look it up by name in DWARF, which is needed
2484 in order to decode the packed array type. */
2486 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2487 !Comes_From_Source (Etype (gnat_entity))
2488 && !Comes_From_Source (gnat_entity),
2489 debug_info_p, gnat_entity);
2491 /* Save it as our equivalent in case the call below elaborates
2493 save_gnu_tree (gnat_entity, gnu_decl, false);
2495 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2497 this_made_decl = true;
2498 gnu_type = TREE_TYPE (gnu_decl);
2499 save_gnu_tree (gnat_entity, NULL_TREE, false);
2501 gnu_inner = gnu_type;
2502 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2503 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2504 || TYPE_PADDING_P (gnu_inner)))
2505 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2507 /* We need to attach the index type to the type we just made so
2508 that the actual bounds can later be put into a template. */
2509 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2510 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2511 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2512 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2514 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2516 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2517 TYPE_MODULUS for modular types so we make an extra
2518 subtype if necessary. */
2519 if (TYPE_MODULAR_P (gnu_inner))
2522 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2523 TREE_TYPE (gnu_subtype) = gnu_inner;
2524 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2525 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2526 TYPE_MIN_VALUE (gnu_inner));
2527 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2528 TYPE_MAX_VALUE (gnu_inner));
2529 gnu_inner = gnu_subtype;
2532 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2534 #ifdef ENABLE_CHECKING
2535 /* Check for other cases of overloading. */
2536 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2540 for (gnat_index = First_Index (gnat_entity);
2541 Present (gnat_index);
2542 gnat_index = Next_Index (gnat_index))
2543 SET_TYPE_ACTUAL_BOUNDS
2545 tree_cons (NULL_TREE,
2546 get_unpadded_type (Etype (gnat_index)),
2547 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2549 if (Convention (gnat_entity) != Convention_Fortran)
2550 SET_TYPE_ACTUAL_BOUNDS
2551 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2553 if (TREE_CODE (gnu_type) == RECORD_TYPE
2554 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2555 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2560 /* Abort if packed array with no Packed_Array_Type field set. */
2561 gcc_assert (!Is_Packed (gnat_entity));
2565 case E_String_Literal_Subtype:
2566 /* Create the type for a string literal. */
2568 Entity_Id gnat_full_type
2569 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2570 && Present (Full_View (Etype (gnat_entity)))
2571 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2572 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2573 tree gnu_string_array_type
2574 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2575 tree gnu_string_index_type
2576 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2577 (TYPE_DOMAIN (gnu_string_array_type))));
2578 tree gnu_lower_bound
2579 = convert (gnu_string_index_type,
2580 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2581 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2582 tree gnu_length = ssize_int (length - 1);
2583 tree gnu_upper_bound
2584 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2586 convert (gnu_string_index_type, gnu_length));
2588 = create_index_type (convert (sizetype, gnu_lower_bound),
2589 convert (sizetype, gnu_upper_bound),
2590 create_range_type (gnu_string_index_type,
2596 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2598 if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
2599 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2600 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2604 /* Record Types and Subtypes
2606 The following fields are defined on record types:
2608 Has_Discriminants True if the record has discriminants
2609 First_Discriminant Points to head of list of discriminants
2610 First_Entity Points to head of list of fields
2611 Is_Tagged_Type True if the record is tagged
2613 Implementation of Ada records and discriminated records:
2615 A record type definition is transformed into the equivalent of a C
2616 struct definition. The fields that are the discriminants which are
2617 found in the Full_Type_Declaration node and the elements of the
2618 Component_List found in the Record_Type_Definition node. The
2619 Component_List can be a recursive structure since each Variant of
2620 the Variant_Part of the Component_List has a Component_List.
2622 Processing of a record type definition comprises starting the list of
2623 field declarations here from the discriminants and the calling the
2624 function components_to_record to add the rest of the fields from the
2625 component list and return the gnu type node. The function
2626 components_to_record will call itself recursively as it traverses
2630 if (Has_Complex_Representation (gnat_entity))
2633 = build_complex_type
2635 (Etype (Defining_Entity
2636 (First (Component_Items
2639 (Declaration_Node (gnat_entity)))))))));
2645 Node_Id full_definition = Declaration_Node (gnat_entity);
2646 Node_Id record_definition = Type_Definition (full_definition);
2647 Entity_Id gnat_field;
2648 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2649 /* Set PACKED in keeping with gnat_to_gnu_field. */
2651 = Is_Packed (gnat_entity)
2653 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2655 : (Known_Alignment (gnat_entity)
2656 || (Strict_Alignment (gnat_entity)
2657 && Known_Static_Esize (gnat_entity)))
2660 bool has_discr = Has_Discriminants (gnat_entity);
2661 bool has_rep = Has_Specified_Layout (gnat_entity);
2662 bool all_rep = has_rep;
2664 = (Is_Tagged_Type (gnat_entity)
2665 && Nkind (record_definition) == N_Derived_Type_Definition);
2666 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2668 /* See if all fields have a rep clause. Stop when we find one
2671 for (gnat_field = First_Entity (gnat_entity);
2672 Present (gnat_field);
2673 gnat_field = Next_Entity (gnat_field))
2674 if ((Ekind (gnat_field) == E_Component
2675 || Ekind (gnat_field) == E_Discriminant)
2676 && No (Component_Clause (gnat_field)))
2682 /* If this is a record extension, go a level further to find the
2683 record definition. Also, verify we have a Parent_Subtype. */
2686 if (!type_annotate_only
2687 || Present (Record_Extension_Part (record_definition)))
2688 record_definition = Record_Extension_Part (record_definition);
2690 gcc_assert (type_annotate_only
2691 || Present (Parent_Subtype (gnat_entity)));
2694 /* Make a node for the record. If we are not defining the record,
2695 suppress expanding incomplete types. */
2696 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2697 TYPE_NAME (gnu_type) = gnu_entity_name;
2698 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2702 defer_incomplete_level++;
2703 this_deferred = true;
2706 /* If both a size and rep clause was specified, put the size in
2707 the record type now so that it can get the proper mode. */
2708 if (has_rep && Known_Esize (gnat_entity))
2709 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2711 /* Always set the alignment here so that it can be used to
2712 set the mode, if it is making the alignment stricter. If
2713 it is invalid, it will be checked again below. If this is to
2714 be Atomic, choose a default alignment of a word unless we know
2715 the size and it's smaller. */
2716 if (Known_Alignment (gnat_entity))
2717 TYPE_ALIGN (gnu_type)
2718 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2719 else if (Is_Atomic (gnat_entity))
2720 TYPE_ALIGN (gnu_type)
2721 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2722 /* If a type needs strict alignment, the minimum size will be the
2723 type size instead of the RM size (see validate_size). Cap the
2724 alignment, lest it causes this type size to become too large. */
2725 else if (Strict_Alignment (gnat_entity)
2726 && Known_Static_Esize (gnat_entity))
2728 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2729 unsigned int raw_align = raw_size & -raw_size;
2730 if (raw_align < BIGGEST_ALIGNMENT)
2731 TYPE_ALIGN (gnu_type) = raw_align;
2734 TYPE_ALIGN (gnu_type) = 0;
2736 /* If we have a Parent_Subtype, make a field for the parent. If
2737 this record has rep clauses, force the position to zero. */
2738 if (Present (Parent_Subtype (gnat_entity)))
2740 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2743 /* A major complexity here is that the parent subtype will
2744 reference our discriminants in its Discriminant_Constraint
2745 list. But those must reference the parent component of this
2746 record which is of the parent subtype we have not built yet!
2747 To break the circle we first build a dummy COMPONENT_REF which
2748 represents the "get to the parent" operation and initialize
2749 each of those discriminants to a COMPONENT_REF of the above
2750 dummy parent referencing the corresponding discriminant of the
2751 base type of the parent subtype. */
2752 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2753 build0 (PLACEHOLDER_EXPR, gnu_type),
2754 build_decl (input_location,
2755 FIELD_DECL, NULL_TREE,
2760 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2761 Present (gnat_field);
2762 gnat_field = Next_Stored_Discriminant (gnat_field))
2763 if (Present (Corresponding_Discriminant (gnat_field)))
2766 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2770 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2771 gnu_get_parent, gnu_field, NULL_TREE),
2775 /* Then we build the parent subtype. If it has discriminants but
2776 the type itself has unknown discriminants, this means that it
2777 doesn't contain information about how the discriminants are
2778 derived from those of the ancestor type, so it cannot be used
2779 directly. Instead it is built by cloning the parent subtype
2780 of the underlying record view of the type, for which the above
2781 derivation of discriminants has been made explicit. */
2782 if (Has_Discriminants (gnat_parent)
2783 && Has_Unknown_Discriminants (gnat_entity))
2785 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2787 /* If we are defining the type, the underlying record
2788 view must already have been elaborated at this point.
2789 Otherwise do it now as its parent subtype cannot be
2790 technically elaborated on its own. */
2792 gcc_assert (present_gnu_tree (gnat_uview));
2794 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2796 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2798 /* Substitute the "get to the parent" of the type for that
2799 of its underlying record view in the cloned type. */
2800 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2801 Present (gnat_field);
2802 gnat_field = Next_Stored_Discriminant (gnat_field))
2803 if (Present (Corresponding_Discriminant (gnat_field)))
2805 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2807 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2808 gnu_get_parent, gnu_field, NULL_TREE);
2810 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2814 gnu_parent = gnat_to_gnu_type (gnat_parent);
2816 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2817 initially built. The discriminants must reference the fields
2818 of the parent subtype and not those of its base type for the
2819 placeholder machinery to properly work. */
2822 /* The actual parent subtype is the full view. */
2823 if (IN (Ekind (gnat_parent), Private_Kind))
2825 if (Present (Full_View (gnat_parent)))
2826 gnat_parent = Full_View (gnat_parent);
2828 gnat_parent = Underlying_Full_View (gnat_parent);
2831 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2832 Present (gnat_field);
2833 gnat_field = Next_Stored_Discriminant (gnat_field))
2834 if (Present (Corresponding_Discriminant (gnat_field)))
2836 Entity_Id field = Empty;
2837 for (field = First_Stored_Discriminant (gnat_parent);
2839 field = Next_Stored_Discriminant (field))
2840 if (same_discriminant_p (gnat_field, field))
2842 gcc_assert (Present (field));
2843 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2844 = gnat_to_gnu_field_decl (field);
2848 /* The "get to the parent" COMPONENT_REF must be given its
2850 TREE_TYPE (gnu_get_parent) = gnu_parent;
2852 /* ...and reference the _Parent field of this record. */
2854 = create_field_decl (parent_name_id,
2855 gnu_parent, gnu_type, 0,
2857 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2859 ? bitsize_zero_node : NULL_TREE, 1);
2860 DECL_INTERNAL_P (gnu_field) = 1;
2861 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2862 TYPE_FIELDS (gnu_type) = gnu_field;
2865 /* Make the fields for the discriminants and put them into the record
2866 unless it's an Unchecked_Union. */
2868 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2869 Present (gnat_field);
2870 gnat_field = Next_Stored_Discriminant (gnat_field))
2872 /* If this is a record extension and this discriminant is the
2873 renaming of another discriminant, we've handled it above. */
2874 if (Present (Parent_Subtype (gnat_entity))
2875 && Present (Corresponding_Discriminant (gnat_field)))
2879 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
2882 /* Make an expression using a PLACEHOLDER_EXPR from the
OSDN Git Service
