1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2009, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License along with GCC; see the file COPYING3. If not see *
19 * <http://www.gnu.org/licenses/>. *
21 * GNAT was originally developed by the GNAT team at New York University. *
22 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 ****************************************************************************/
28 #include "coretypes.h"
36 #include "tree-inline.h"
54 #ifndef MAX_FIXED_MODE_SIZE
55 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
58 /* Convention_Stdcall should be processed in a specific way on Windows targets
59 only. The macro below is a helper to avoid having to check for a Windows
60 specific attribute throughout this unit. */
62 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
63 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
65 #define Has_Stdcall_Convention(E) (0)
68 /* Stack realignment for functions with foreign conventions is provided on a
69 per back-end basis now, as it is handled by the prologue expanders and not
70 as part of the function's body any more. It might be requested by way of a
71 dedicated function type attribute on the targets that support it.
73 We need a way to avoid setting the attribute on the targets that don't
74 support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
76 It is defined on targets where the circuitry is available, and indicates
77 whether the realignment is needed for 'main'. We use this to decide for
78 foreign subprograms as well.
80 It is not defined on targets where the circuitry is not implemented, and
81 we just never set the attribute in these cases.
83 Whether it is defined on all targets that would need it in theory is
84 not entirely clear. We currently trust the base GCC settings for this
87 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
88 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
93 struct incomplete *next;
98 /* These variables are used to defer recursively expanding incomplete types
99 while we are processing an array, a record or a subprogram type. */
100 static int defer_incomplete_level = 0;
101 static struct incomplete *defer_incomplete_list;
103 /* This variable is used to delay expanding From_With_Type types until the
105 static struct incomplete *defer_limited_with;
107 /* These variables are used to defer finalizing types. The element of the
108 list is the TYPE_DECL associated with the type. */
109 static int defer_finalize_level = 0;
110 static VEC (tree,heap) *defer_finalize_list;
112 /* A hash table used to cache the result of annotate_value. */
113 static GTY ((if_marked ("tree_int_map_marked_p"),
114 param_is (struct tree_int_map))) htab_t annotate_value_cache;
123 static void relate_alias_sets (tree, tree, enum alias_set_op);
125 static bool allocatable_size_p (tree, bool);
126 static void prepend_one_attribute_to (struct attrib **,
127 enum attr_type, tree, tree, Node_Id);
128 static void prepend_attributes (Entity_Id, struct attrib **);
129 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
130 static bool is_variable_size (tree);
131 static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
132 static tree make_packable_type (tree, bool);
133 static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
134 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
136 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
137 static bool same_discriminant_p (Entity_Id, Entity_Id);
138 static bool array_type_has_nonaliased_component (Entity_Id, tree);
139 static bool compile_time_known_address_p (Node_Id);
140 static bool cannot_be_superflat_p (Node_Id);
141 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
142 bool, bool, bool, bool, bool);
143 static Uint annotate_value (tree);
144 static void annotate_rep (Entity_Id, tree);
145 static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
146 static tree build_subst_list (Entity_Id, Entity_Id, bool);
147 static tree build_variant_list (tree, tree, tree);
148 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
149 static void set_rm_size (Uint, tree, Entity_Id);
150 static tree make_type_from_size (tree, tree, bool);
151 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
152 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
153 static void check_ok_for_atomic (tree, Entity_Id, bool);
154 static int compatible_signatures_p (tree, tree);
155 static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
156 static tree get_rep_part (tree);
157 static tree get_variant_part (tree);
158 static tree create_variant_part_from (tree, tree, tree, tree, tree);
159 static void copy_and_substitute_in_size (tree, tree, tree);
160 static void rest_of_type_decl_compilation_no_defer (tree);
162 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
163 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
164 and associate the ..._DECL node with the input GNAT defining identifier.
166 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
167 initial value (in GCC tree form). This is optional for a variable. For
168 a renamed entity, GNU_EXPR gives the object being renamed.
170 DEFINITION is nonzero if this call is intended for a definition. This is
171 used for separate compilation where it is necessary to know whether an
172 external declaration or a definition must be created if the GCC equivalent
173 was not created previously. The value of 1 is normally used for a nonzero
174 DEFINITION, but a value of 2 is used in special circumstances, defined in
178 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
180 /* Contains the kind of the input GNAT node. */
181 const Entity_Kind kind = Ekind (gnat_entity);
182 /* True if this is a type. */
183 const bool is_type = IN (kind, Type_Kind);
184 /* For a type, contains the equivalent GNAT node to be used in gigi. */
185 Entity_Id gnat_equiv_type = Empty;
186 /* Temporary used to walk the GNAT tree. */
188 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
189 This node will be associated with the GNAT node by calling at the end
190 of the `switch' statement. */
191 tree gnu_decl = NULL_TREE;
192 /* Contains the GCC type to be used for the GCC node. */
193 tree gnu_type = NULL_TREE;
194 /* Contains the GCC size tree to be used for the GCC node. */
195 tree gnu_size = NULL_TREE;
196 /* Contains the GCC name to be used for the GCC node. */
197 tree gnu_entity_name;
198 /* True if we have already saved gnu_decl as a GNAT association. */
200 /* True if we incremented defer_incomplete_level. */
201 bool this_deferred = false;
202 /* True if we incremented force_global. */
203 bool this_global = false;
204 /* True if we should check to see if elaborated during processing. */
205 bool maybe_present = false;
206 /* True if we made GNU_DECL and its type here. */
207 bool this_made_decl = false;
208 /* True if debug info is requested for this entity. */
209 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
210 || debug_info_level == DINFO_LEVEL_VERBOSE);
211 /* True if this entity is to be considered as imported. */
212 bool imported_p = (Is_Imported (gnat_entity)
213 && No (Address_Clause (gnat_entity)));
214 /* Size and alignment of the GCC node, if meaningful. */
215 unsigned int esize = 0, align = 0;
216 /* Contains the list of attributes directly attached to the entity. */
217 struct attrib *attr_list = NULL;
219 /* Since a use of an Itype is a definition, process it as such if it
220 is not in a with'ed unit. */
223 && Is_Itype (gnat_entity)
224 && !present_gnu_tree (gnat_entity)
225 && In_Extended_Main_Code_Unit (gnat_entity))
227 /* Ensure that we are in a subprogram mentioned in the Scope chain of
228 this entity, our current scope is global, or we encountered a task
229 or entry (where we can't currently accurately check scoping). */
230 if (!current_function_decl
231 || DECL_ELABORATION_PROC_P (current_function_decl))
233 process_type (gnat_entity);
234 return get_gnu_tree (gnat_entity);
237 for (gnat_temp = Scope (gnat_entity);
239 gnat_temp = Scope (gnat_temp))
241 if (Is_Type (gnat_temp))
242 gnat_temp = Underlying_Type (gnat_temp);
244 if (Ekind (gnat_temp) == E_Subprogram_Body)
246 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
248 if (IN (Ekind (gnat_temp), Subprogram_Kind)
249 && Present (Protected_Body_Subprogram (gnat_temp)))
250 gnat_temp = Protected_Body_Subprogram (gnat_temp);
252 if (Ekind (gnat_temp) == E_Entry
253 || Ekind (gnat_temp) == E_Entry_Family
254 || Ekind (gnat_temp) == E_Task_Type
255 || (IN (Ekind (gnat_temp), Subprogram_Kind)
256 && present_gnu_tree (gnat_temp)
257 && (current_function_decl
258 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
260 process_type (gnat_entity);
261 return get_gnu_tree (gnat_entity);
265 /* This abort means the Itype has an incorrect scope, i.e. that its
266 scope does not correspond to the subprogram it is declared in. */
270 /* If we've already processed this entity, return what we got last time.
271 If we are defining the node, we should not have already processed it.
272 In that case, we will abort below when we try to save a new GCC tree
273 for this object. We also need to handle the case of getting a dummy
274 type when a Full_View exists. */
275 if ((!definition || (is_type && imported_p))
276 && present_gnu_tree (gnat_entity))
278 gnu_decl = get_gnu_tree (gnat_entity);
280 if (TREE_CODE (gnu_decl) == TYPE_DECL
281 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
282 && IN (kind, Incomplete_Or_Private_Kind)
283 && Present (Full_View (gnat_entity)))
286 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
287 save_gnu_tree (gnat_entity, NULL_TREE, false);
288 save_gnu_tree (gnat_entity, gnu_decl, false);
294 /* If this is a numeric or enumeral type, or an access type, a nonzero
295 Esize must be specified unless it was specified by the programmer. */
296 gcc_assert (!Unknown_Esize (gnat_entity)
297 || Has_Size_Clause (gnat_entity)
298 || (!IN (kind, Numeric_Kind)
299 && !IN (kind, Enumeration_Kind)
300 && (!IN (kind, Access_Kind)
301 || kind == E_Access_Protected_Subprogram_Type
302 || kind == E_Anonymous_Access_Protected_Subprogram_Type
303 || kind == E_Access_Subtype)));
305 /* The RM size must be specified for all discrete and fixed-point types. */
306 gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
307 && Unknown_RM_Size (gnat_entity)));
309 /* If we get here, it means we have not yet done anything with this entity.
310 If we are not defining it, it must be a type or an entity that is defined
311 elsewhere or externally, otherwise we should have defined it already. */
312 gcc_assert (definition
313 || type_annotate_only
315 || kind == E_Discriminant
316 || kind == E_Component
318 || (kind == E_Constant && Present (Full_View (gnat_entity)))
319 || Is_Public (gnat_entity));
321 /* Get the name of the entity and set up the line number and filename of
322 the original definition for use in any decl we make. */
323 gnu_entity_name = get_entity_name (gnat_entity);
324 Sloc_to_locus (Sloc (gnat_entity), &input_location);
326 /* For cases when we are not defining (i.e., we are referencing from
327 another compilation unit) public entities, show we are at global level
328 for the purpose of computing scopes. Don't do this for components or
329 discriminants since the relevant test is whether or not the record is
332 && kind != E_Component
333 && kind != E_Discriminant
334 && Is_Public (gnat_entity)
335 && !Is_Statically_Allocated (gnat_entity))
336 force_global++, this_global = true;
338 /* Handle any attributes directly attached to the entity. */
339 if (Has_Gigi_Rep_Item (gnat_entity))
340 prepend_attributes (gnat_entity, &attr_list);
342 /* Do some common processing for types. */
345 /* Compute the equivalent type to be used in gigi. */
346 gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
348 /* Machine_Attributes on types are expected to be propagated to
349 subtypes. The corresponding Gigi_Rep_Items are only attached
350 to the first subtype though, so we handle the propagation here. */
351 if (Base_Type (gnat_entity) != gnat_entity
352 && !Is_First_Subtype (gnat_entity)
353 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
354 prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
357 /* Compute a default value for the size of the type. */
358 if (Known_Esize (gnat_entity)
359 && UI_Is_In_Int_Range (Esize (gnat_entity)))
361 unsigned int max_esize;
362 esize = UI_To_Int (Esize (gnat_entity));
364 if (IN (kind, Float_Kind))
365 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
366 else if (IN (kind, Access_Kind))
367 max_esize = POINTER_SIZE * 2;
369 max_esize = LONG_LONG_TYPE_SIZE;
371 if (esize > max_esize)
375 esize = LONG_LONG_TYPE_SIZE;
381 /* If this is a use of a deferred constant without address clause,
382 get its full definition. */
384 && No (Address_Clause (gnat_entity))
385 && Present (Full_View (gnat_entity)))
388 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
393 /* If we have an external constant that we are not defining, get the
394 expression that is was defined to represent. We may throw that
395 expression away later if it is not a constant. Do not retrieve the
396 expression if it is an aggregate or allocator, because in complex
397 instantiation contexts it may not be expanded */
399 && Present (Expression (Declaration_Node (gnat_entity)))
400 && !No_Initialization (Declaration_Node (gnat_entity))
401 && (Nkind (Expression (Declaration_Node (gnat_entity)))
403 && (Nkind (Expression (Declaration_Node (gnat_entity)))
405 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
407 /* Ignore deferred constant definitions without address clause since
408 they are processed fully in the front-end. If No_Initialization
409 is set, this is not a deferred constant but a constant whose value
410 is built manually. And constants that are renamings are handled
414 && No (Address_Clause (gnat_entity))
415 && !No_Initialization (Declaration_Node (gnat_entity))
416 && No (Renamed_Object (gnat_entity)))
418 gnu_decl = error_mark_node;
423 /* Ignore constant definitions already marked with the error node. See
424 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
427 && present_gnu_tree (gnat_entity)
428 && get_gnu_tree (gnat_entity) == error_mark_node)
430 maybe_present = true;
437 /* We used to special case VMS exceptions here to directly map them to
438 their associated condition code. Since this code had to be masked
439 dynamically to strip off the severity bits, this caused trouble in
440 the GCC/ZCX case because the "type" pointers we store in the tables
441 have to be static. We now don't special case here anymore, and let
442 the regular processing take place, which leaves us with a regular
443 exception data object for VMS exceptions too. The condition code
444 mapping is taken care of by the front end and the bitmasking by the
451 /* The GNAT record where the component was defined. */
452 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
454 /* If the variable is an inherited record component (in the case of
455 extended record types), just return the inherited entity, which
456 must be a FIELD_DECL. Likewise for discriminants.
457 For discriminants of untagged records which have explicit
458 stored discriminants, return the entity for the corresponding
459 stored discriminant. Also use Original_Record_Component
460 if the record has a private extension. */
461 if (Present (Original_Record_Component (gnat_entity))
462 && Original_Record_Component (gnat_entity) != gnat_entity)
465 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
466 gnu_expr, definition);
471 /* If the enclosing record has explicit stored discriminants,
472 then it is an untagged record. If the Corresponding_Discriminant
473 is not empty then this must be a renamed discriminant and its
474 Original_Record_Component must point to the corresponding explicit
475 stored discriminant (i.e. we should have taken the previous
477 else if (Present (Corresponding_Discriminant (gnat_entity))
478 && Is_Tagged_Type (gnat_record))
480 /* A tagged record has no explicit stored discriminants. */
481 gcc_assert (First_Discriminant (gnat_record)
482 == First_Stored_Discriminant (gnat_record));
484 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
485 gnu_expr, definition);
490 else if (Present (CR_Discriminant (gnat_entity))
491 && type_annotate_only)
493 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
494 gnu_expr, definition);
499 /* If the enclosing record has explicit stored discriminants, then
500 it is an untagged record. If the Corresponding_Discriminant
501 is not empty then this must be a renamed discriminant and its
502 Original_Record_Component must point to the corresponding explicit
503 stored discriminant (i.e. we should have taken the first
505 else if (Present (Corresponding_Discriminant (gnat_entity))
506 && (First_Discriminant (gnat_record)
507 != First_Stored_Discriminant (gnat_record)))
510 /* Otherwise, if we are not defining this and we have no GCC type
511 for the containing record, make one for it. Then we should
512 have made our own equivalent. */
513 else if (!definition && !present_gnu_tree (gnat_record))
515 /* ??? If this is in a record whose scope is a protected
516 type and we have an Original_Record_Component, use it.
517 This is a workaround for major problems in protected type
519 Entity_Id Scop = Scope (Scope (gnat_entity));
520 if ((Is_Protected_Type (Scop)
521 || (Is_Private_Type (Scop)
522 && Present (Full_View (Scop))
523 && Is_Protected_Type (Full_View (Scop))))
524 && Present (Original_Record_Component (gnat_entity)))
527 = gnat_to_gnu_entity (Original_Record_Component
534 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
535 gnu_decl = get_gnu_tree (gnat_entity);
541 /* Here we have no GCC type and this is a reference rather than a
542 definition. This should never happen. Most likely the cause is
543 reference before declaration in the gnat tree for gnat_entity. */
547 case E_Loop_Parameter:
548 case E_Out_Parameter:
551 /* Simple variables, loop variables, Out parameters, and exceptions. */
554 bool used_by_ref = false;
556 = ((kind == E_Constant || kind == E_Variable)
557 && Is_True_Constant (gnat_entity)
558 && !Treat_As_Volatile (gnat_entity)
559 && (((Nkind (Declaration_Node (gnat_entity))
560 == N_Object_Declaration)
561 && Present (Expression (Declaration_Node (gnat_entity))))
562 || Present (Renamed_Object (gnat_entity))));
563 bool inner_const_flag = const_flag;
564 bool static_p = Is_Statically_Allocated (gnat_entity);
565 bool mutable_p = false;
566 tree gnu_ext_name = NULL_TREE;
567 tree renamed_obj = NULL_TREE;
568 tree gnu_object_size;
570 if (Present (Renamed_Object (gnat_entity)) && !definition)
572 if (kind == E_Exception)
573 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
576 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
579 /* Get the type after elaborating the renamed object. */
580 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
582 /* For a debug renaming declaration, build a pure debug entity. */
583 if (Present (Debug_Renaming_Link (gnat_entity)))
586 gnu_decl = build_decl (input_location,
587 VAR_DECL, gnu_entity_name, gnu_type);
588 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
589 if (global_bindings_p ())
590 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
592 addr = stack_pointer_rtx;
593 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
594 gnat_pushdecl (gnu_decl, gnat_entity);
598 /* If this is a loop variable, its type should be the base type.
599 This is because the code for processing a loop determines whether
600 a normal loop end test can be done by comparing the bounds of the
601 loop against those of the base type, which is presumed to be the
602 size used for computation. But this is not correct when the size
603 of the subtype is smaller than the type. */
604 if (kind == E_Loop_Parameter)
605 gnu_type = get_base_type (gnu_type);
607 /* Reject non-renamed objects whose types are unconstrained arrays or
608 any object whose type is a dummy type or VOID_TYPE. */
610 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
611 && No (Renamed_Object (gnat_entity)))
612 || TYPE_IS_DUMMY_P (gnu_type)
613 || TREE_CODE (gnu_type) == VOID_TYPE)
615 gcc_assert (type_annotate_only);
618 return error_mark_node;
621 /* If an alignment is specified, use it if valid. Note that exceptions
622 are objects but don't have an alignment. We must do this before we
623 validate the size, since the alignment can affect the size. */
624 if (kind != E_Exception && Known_Alignment (gnat_entity))
626 gcc_assert (Present (Alignment (gnat_entity)));
627 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
628 TYPE_ALIGN (gnu_type));
629 /* No point in changing the type if there is an address clause
630 as the final type of the object will be a reference type. */
631 if (Present (Address_Clause (gnat_entity)))
635 = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
636 false, false, definition, true);
639 /* If we are defining the object, see if it has a Size value and
640 validate it if so. If we are not defining the object and a Size
641 clause applies, simply retrieve the value. We don't want to ignore
642 the clause and it is expected to have been validated already. Then
643 get the new type, if any. */
645 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
646 gnat_entity, VAR_DECL, false,
647 Has_Size_Clause (gnat_entity));
648 else if (Has_Size_Clause (gnat_entity))
649 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
654 = make_type_from_size (gnu_type, gnu_size,
655 Has_Biased_Representation (gnat_entity));
657 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
658 gnu_size = NULL_TREE;
661 /* If this object has self-referential size, it must be a record with
662 a default value. We are supposed to allocate an object of the
663 maximum size in this case unless it is a constant with an
664 initializing expression, in which case we can get the size from
665 that. Note that the resulting size may still be a variable, so
666 this may end up with an indirect allocation. */
667 if (No (Renamed_Object (gnat_entity))
668 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
670 if (gnu_expr && kind == E_Constant)
672 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
673 if (CONTAINS_PLACEHOLDER_P (size))
675 /* If the initializing expression is itself a constant,
676 despite having a nominal type with self-referential
677 size, we can get the size directly from it. */
678 if (TREE_CODE (gnu_expr) == COMPONENT_REF
680 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
681 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
682 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
683 || DECL_READONLY_ONCE_ELAB
684 (TREE_OPERAND (gnu_expr, 0))))
685 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
688 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
693 /* We may have no GNU_EXPR because No_Initialization is
694 set even though there's an Expression. */
695 else if (kind == E_Constant
696 && (Nkind (Declaration_Node (gnat_entity))
697 == N_Object_Declaration)
698 && Present (Expression (Declaration_Node (gnat_entity))))
700 = TYPE_SIZE (gnat_to_gnu_type
702 (Expression (Declaration_Node (gnat_entity)))));
705 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
710 /* If the size is zero bytes, make it one byte since some linkers have
711 trouble with zero-sized objects. If the object will have a
712 template, that will make it nonzero so don't bother. Also avoid
713 doing that for an object renaming or an object with an address
714 clause, as we would lose useful information on the view size
715 (e.g. for null array slices) and we are not allocating the object
718 && integer_zerop (gnu_size)
719 && !TREE_OVERFLOW (gnu_size))
720 || (TYPE_SIZE (gnu_type)
721 && integer_zerop (TYPE_SIZE (gnu_type))
722 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
723 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
724 || !Is_Array_Type (Etype (gnat_entity)))
725 && No (Renamed_Object (gnat_entity))
726 && No (Address_Clause (gnat_entity)))
727 gnu_size = bitsize_unit_node;
729 /* If this is an object with no specified size and alignment, and
730 if either it is atomic or we are not optimizing alignment for
731 space and it is composite and not an exception, an Out parameter
732 or a reference to another object, and the size of its type is a
733 constant, set the alignment to the smallest one which is not
734 smaller than the size, with an appropriate cap. */
735 if (!gnu_size && align == 0
736 && (Is_Atomic (gnat_entity)
737 || (!Optimize_Alignment_Space (gnat_entity)
738 && kind != E_Exception
739 && kind != E_Out_Parameter
740 && Is_Composite_Type (Etype (gnat_entity))
741 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
743 && No (Renamed_Object (gnat_entity))
744 && No (Address_Clause (gnat_entity))))
745 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
747 /* No point in jumping through all the hoops needed in order
748 to support BIGGEST_ALIGNMENT if we don't really have to.
749 So we cap to the smallest alignment that corresponds to
750 a known efficient memory access pattern of the target. */
751 unsigned int align_cap = Is_Atomic (gnat_entity)
753 : get_mode_alignment (ptr_mode);
755 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
756 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
759 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
761 /* But make sure not to under-align the object. */
762 if (align <= TYPE_ALIGN (gnu_type))
765 /* And honor the minimum valid atomic alignment, if any. */
766 #ifdef MINIMUM_ATOMIC_ALIGNMENT
767 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
768 align = MINIMUM_ATOMIC_ALIGNMENT;
772 /* If the object is set to have atomic components, find the component
773 type and validate it.
775 ??? Note that we ignore Has_Volatile_Components on objects; it's
776 not at all clear what to do in that case. */
778 if (Has_Atomic_Components (gnat_entity))
780 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
781 ? TREE_TYPE (gnu_type) : gnu_type);
783 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
784 && TYPE_MULTI_ARRAY_P (gnu_inner))
785 gnu_inner = TREE_TYPE (gnu_inner);
787 check_ok_for_atomic (gnu_inner, gnat_entity, true);
790 /* Now check if the type of the object allows atomic access. Note
791 that we must test the type, even if this object has size and
792 alignment to allow such access, because we will be going
793 inside the padded record to assign to the object. We could fix
794 this by always copying via an intermediate value, but it's not
795 clear it's worth the effort. */
796 if (Is_Atomic (gnat_entity))
797 check_ok_for_atomic (gnu_type, gnat_entity, false);
799 /* If this is an aliased object with an unconstrained nominal subtype,
800 make a type that includes the template. */
801 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
802 && Is_Array_Type (Etype (gnat_entity))
803 && !type_annotate_only)
806 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
809 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
810 concat_name (gnu_entity_name,
814 #ifdef MINIMUM_ATOMIC_ALIGNMENT
815 /* If the size is a constant and no alignment is specified, force
816 the alignment to be the minimum valid atomic alignment. The
817 restriction on constant size avoids problems with variable-size
818 temporaries; if the size is variable, there's no issue with
819 atomic access. Also don't do this for a constant, since it isn't
820 necessary and can interfere with constant replacement. Finally,
821 do not do it for Out parameters since that creates an
822 size inconsistency with In parameters. */
823 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
824 && !FLOAT_TYPE_P (gnu_type)
825 && !const_flag && No (Renamed_Object (gnat_entity))
826 && !imported_p && No (Address_Clause (gnat_entity))
827 && kind != E_Out_Parameter
828 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
829 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
830 align = MINIMUM_ATOMIC_ALIGNMENT;
833 /* Make a new type with the desired size and alignment, if needed.
834 But do not take into account alignment promotions to compute the
835 size of the object. */
836 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
837 if (gnu_size || align > 0)
838 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
839 false, false, definition,
840 gnu_size ? true : false);
842 /* If this is a renaming, avoid as much as possible to create a new
843 object. However, in several cases, creating it is required.
844 This processing needs to be applied to the raw expression so
845 as to make it more likely to rename the underlying object. */
846 if (Present (Renamed_Object (gnat_entity)))
848 bool create_normal_object = false;
850 /* If the renamed object had padding, strip off the reference
851 to the inner object and reset our type. */
852 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
853 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
854 /* Strip useless conversions around the object. */
855 || (TREE_CODE (gnu_expr) == NOP_EXPR
856 && gnat_types_compatible_p
857 (TREE_TYPE (gnu_expr),
858 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
860 gnu_expr = TREE_OPERAND (gnu_expr, 0);
861 gnu_type = TREE_TYPE (gnu_expr);
864 /* Case 1: If this is a constant renaming stemming from a function
865 call, treat it as a normal object whose initial value is what
866 is being renamed. RM 3.3 says that the result of evaluating a
867 function call is a constant object. As a consequence, it can
868 be the inner object of a constant renaming. In this case, the
869 renaming must be fully instantiated, i.e. it cannot be a mere
870 reference to (part of) an existing object. */
873 tree inner_object = gnu_expr;
874 while (handled_component_p (inner_object))
875 inner_object = TREE_OPERAND (inner_object, 0);
876 if (TREE_CODE (inner_object) == CALL_EXPR)
877 create_normal_object = true;
880 /* Otherwise, see if we can proceed with a stabilized version of
881 the renamed entity or if we need to make a new object. */
882 if (!create_normal_object)
884 tree maybe_stable_expr = NULL_TREE;
887 /* Case 2: If the renaming entity need not be materialized and
888 the renamed expression is something we can stabilize, use
889 that for the renaming. At the global level, we can only do
890 this if we know no SAVE_EXPRs need be made, because the
891 expression we return might be used in arbitrary conditional
892 branches so we must force the SAVE_EXPRs evaluation
893 immediately and this requires a function context. */
894 if (!Materialize_Entity (gnat_entity)
895 && (!global_bindings_p ()
896 || (staticp (gnu_expr)
897 && !TREE_SIDE_EFFECTS (gnu_expr))))
900 = maybe_stabilize_reference (gnu_expr, true, &stable);
904 /* ??? No DECL_EXPR is created so we need to mark
905 the expression manually lest it is shared. */
906 if (global_bindings_p ())
907 MARK_VISITED (maybe_stable_expr);
908 gnu_decl = maybe_stable_expr;
909 save_gnu_tree (gnat_entity, gnu_decl, true);
911 annotate_object (gnat_entity, gnu_type, NULL_TREE,
916 /* The stabilization failed. Keep maybe_stable_expr
917 untouched here to let the pointer case below know
918 about that failure. */
921 /* Case 3: If this is a constant renaming and creating a
922 new object is allowed and cheap, treat it as a normal
923 object whose initial value is what is being renamed. */
925 && !Is_Composite_Type
926 (Underlying_Type (Etype (gnat_entity))))
929 /* Case 4: Make this into a constant pointer to the object we
930 are to rename and attach the object to the pointer if it is
931 something we can stabilize.
933 From the proper scope, attached objects will be referenced
934 directly instead of indirectly via the pointer to avoid
935 subtle aliasing problems with non-addressable entities.
936 They have to be stable because we must not evaluate the
937 variables in the expression every time the renaming is used.
938 The pointer is called a "renaming" pointer in this case.
940 In the rare cases where we cannot stabilize the renamed
941 object, we just make a "bare" pointer, and the renamed
942 entity is always accessed indirectly through it. */
945 gnu_type = build_reference_type (gnu_type);
946 inner_const_flag = TREE_READONLY (gnu_expr);
949 /* If the previous attempt at stabilizing failed, there
950 is no point in trying again and we reuse the result
951 without attaching it to the pointer. In this case it
952 will only be used as the initializing expression of
953 the pointer and thus needs no special treatment with
954 regard to multiple evaluations. */
955 if (maybe_stable_expr)
958 /* Otherwise, try to stabilize and attach the expression
959 to the pointer if the stabilization succeeds.
961 Note that this might introduce SAVE_EXPRs and we don't
962 check whether we're at the global level or not. This
963 is fine since we are building a pointer initializer and
964 neither the pointer nor the initializing expression can
965 be accessed before the pointer elaboration has taken
966 place in a correct program.
968 These SAVE_EXPRs will be evaluated at the right place
969 by either the evaluation of the initializer for the
970 non-global case or the elaboration code for the global
971 case, and will be attached to the elaboration procedure
972 in the latter case. */
976 = maybe_stabilize_reference (gnu_expr, true, &stable);
979 renamed_obj = maybe_stable_expr;
981 /* Attaching is actually performed downstream, as soon
982 as we have a VAR_DECL for the pointer we make. */
986 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
988 gnu_size = NULL_TREE;
994 /* Make a volatile version of this object's type if we are to make
995 the object volatile. We also interpret 13.3(19) conservatively
996 and disallow any optimizations for such a non-constant object. */
997 if ((Treat_As_Volatile (gnat_entity)
999 && (Is_Exported (gnat_entity)
1000 || Is_Imported (gnat_entity)
1001 || Present (Address_Clause (gnat_entity)))))
1002 && !TYPE_VOLATILE (gnu_type))
1003 gnu_type = build_qualified_type (gnu_type,
1004 (TYPE_QUALS (gnu_type)
1005 | TYPE_QUAL_VOLATILE));
1007 /* If we are defining an aliased object whose nominal subtype is
1008 unconstrained, the object is a record that contains both the
1009 template and the object. If there is an initializer, it will
1010 have already been converted to the right type, but we need to
1011 create the template if there is no initializer. */
1014 && TREE_CODE (gnu_type) == RECORD_TYPE
1015 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1016 /* Beware that padding might have been introduced above. */
1017 || (TYPE_PADDING_P (gnu_type)
1018 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1020 && TYPE_CONTAINS_TEMPLATE_P
1021 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1024 = TYPE_PADDING_P (gnu_type)
1025 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1026 : TYPE_FIELDS (gnu_type);
1029 = gnat_build_constructor
1033 build_template (TREE_TYPE (template_field),
1034 TREE_TYPE (TREE_CHAIN (template_field)),
1039 /* Convert the expression to the type of the object except in the
1040 case where the object's type is unconstrained or the object's type
1041 is a padded record whose field is of self-referential size. In
1042 the former case, converting will generate unnecessary evaluations
1043 of the CONSTRUCTOR to compute the size and in the latter case, we
1044 want to only copy the actual data. */
1046 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1047 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1048 && !(TYPE_IS_PADDING_P (gnu_type)
1049 && CONTAINS_PLACEHOLDER_P
1050 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1051 gnu_expr = convert (gnu_type, gnu_expr);
1053 /* If this is a pointer and it does not have an initializing
1054 expression, initialize it to NULL, unless the object is
1057 && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
1058 && !Is_Imported (gnat_entity) && !gnu_expr)
1059 gnu_expr = integer_zero_node;
1061 /* If we are defining the object and it has an Address clause, we must
1062 either get the address expression from the saved GCC tree for the
1063 object if it has a Freeze node, or elaborate the address expression
1064 here since the front-end has guaranteed that the elaboration has no
1065 effects in this case. */
1066 if (definition && Present (Address_Clause (gnat_entity)))
1069 = present_gnu_tree (gnat_entity)
1070 ? get_gnu_tree (gnat_entity)
1071 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)));
1073 save_gnu_tree (gnat_entity, NULL_TREE, false);
1075 /* Ignore the size. It's either meaningless or was handled
1077 gnu_size = NULL_TREE;
1078 /* Convert the type of the object to a reference type that can
1079 alias everything as per 13.3(19). */
1081 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1082 gnu_address = convert (gnu_type, gnu_address);
1084 const_flag = !Is_Public (gnat_entity)
1085 || compile_time_known_address_p (Expression (Address_Clause
1088 /* If this is a deferred constant, the initializer is attached to
1090 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1093 (Expression (Declaration_Node (Full_View (gnat_entity))));
1095 /* If we don't have an initializing expression for the underlying
1096 variable, the initializing expression for the pointer is the
1097 specified address. Otherwise, we have to make a COMPOUND_EXPR
1098 to assign both the address and the initial value. */
1100 gnu_expr = gnu_address;
1103 = build2 (COMPOUND_EXPR, gnu_type,
1105 (MODIFY_EXPR, NULL_TREE,
1106 build_unary_op (INDIRECT_REF, NULL_TREE,
1112 /* If it has an address clause and we are not defining it, mark it
1113 as an indirect object. Likewise for Stdcall objects that are
1115 if ((!definition && Present (Address_Clause (gnat_entity)))
1116 || (Is_Imported (gnat_entity)
1117 && Has_Stdcall_Convention (gnat_entity)))
1119 /* Convert the type of the object to a reference type that can
1120 alias everything as per 13.3(19). */
1122 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1123 gnu_size = NULL_TREE;
1125 /* No point in taking the address of an initializing expression
1126 that isn't going to be used. */
1127 gnu_expr = NULL_TREE;
1129 /* If it has an address clause whose value is known at compile
1130 time, make the object a CONST_DECL. This will avoid a
1131 useless dereference. */
1132 if (Present (Address_Clause (gnat_entity)))
1134 Node_Id gnat_address
1135 = Expression (Address_Clause (gnat_entity));
1137 if (compile_time_known_address_p (gnat_address))
1139 gnu_expr = gnat_to_gnu (gnat_address);
1147 /* If we are at top level and this object is of variable size,
1148 make the actual type a hidden pointer to the real type and
1149 make the initializer be a memory allocation and initialization.
1150 Likewise for objects we aren't defining (presumed to be
1151 external references from other packages), but there we do
1152 not set up an initialization.
1154 If the object's size overflows, make an allocator too, so that
1155 Storage_Error gets raised. Note that we will never free
1156 such memory, so we presume it never will get allocated. */
1158 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1159 global_bindings_p () || !definition
1162 && ! allocatable_size_p (gnu_size,
1163 global_bindings_p () || !definition
1166 gnu_type = build_reference_type (gnu_type);
1167 gnu_size = NULL_TREE;
1171 /* In case this was a aliased object whose nominal subtype is
1172 unconstrained, the pointer above will be a thin pointer and
1173 build_allocator will automatically make the template.
1175 If we have a template initializer only (that we made above),
1176 pretend there is none and rely on what build_allocator creates
1177 again anyway. Otherwise (if we have a full initializer), get
1178 the data part and feed that to build_allocator.
1180 If we are elaborating a mutable object, tell build_allocator to
1181 ignore a possibly simpler size from the initializer, if any, as
1182 we must allocate the maximum possible size in this case. */
1186 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1188 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1189 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1192 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1194 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1195 && 1 == VEC_length (constructor_elt,
1196 CONSTRUCTOR_ELTS (gnu_expr)))
1200 = build_component_ref
1201 (gnu_expr, NULL_TREE,
1202 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1206 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1207 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1208 && !Is_Imported (gnat_entity))
1209 post_error ("?Storage_Error will be raised at run-time!",
1213 = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1214 Empty, Empty, gnat_entity, mutable_p);
1218 gnu_expr = NULL_TREE;
1223 /* If this object would go into the stack and has an alignment larger
1224 than the largest stack alignment the back-end can honor, resort to
1225 a variable of "aligning type". */
1226 if (!global_bindings_p () && !static_p && definition
1227 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1229 /* Create the new variable. No need for extra room before the
1230 aligned field as this is in automatic storage. */
1232 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1233 TYPE_SIZE_UNIT (gnu_type),
1234 BIGGEST_ALIGNMENT, 0);
1236 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1237 NULL_TREE, gnu_new_type, NULL_TREE, false,
1238 false, false, false, NULL, gnat_entity);
1240 /* Initialize the aligned field if we have an initializer. */
1243 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1245 (gnu_new_var, NULL_TREE,
1246 TYPE_FIELDS (gnu_new_type), false),
1250 /* And setup this entity as a reference to the aligned field. */
1251 gnu_type = build_reference_type (gnu_type);
1254 (ADDR_EXPR, gnu_type,
1255 build_component_ref (gnu_new_var, NULL_TREE,
1256 TYPE_FIELDS (gnu_new_type), false));
1258 gnu_size = NULL_TREE;
1264 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1265 | TYPE_QUAL_CONST));
1267 /* Convert the expression to the type of the object except in the
1268 case where the object's type is unconstrained or the object's type
1269 is a padded record whose field is of self-referential size. In
1270 the former case, converting will generate unnecessary evaluations
1271 of the CONSTRUCTOR to compute the size and in the latter case, we
1272 want to only copy the actual data. */
1274 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1275 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1276 && !(TYPE_IS_PADDING_P (gnu_type)
1277 && CONTAINS_PLACEHOLDER_P
1278 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
1279 gnu_expr = convert (gnu_type, gnu_expr);
1281 /* If this name is external or there was a name specified, use it,
1282 unless this is a VMS exception object since this would conflict
1283 with the symbol we need to export in addition. Don't use the
1284 Interface_Name if there is an address clause (see CD30005). */
1285 if (!Is_VMS_Exception (gnat_entity)
1286 && ((Present (Interface_Name (gnat_entity))
1287 && No (Address_Clause (gnat_entity)))
1288 || (Is_Public (gnat_entity)
1289 && (!Is_Imported (gnat_entity)
1290 || Is_Exported (gnat_entity)))))
1291 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1293 /* If this is constant initialized to a static constant and the
1294 object has an aggregate type, force it to be statically
1295 allocated. This will avoid an initialization copy. */
1296 if (!static_p && const_flag
1297 && gnu_expr && TREE_CONSTANT (gnu_expr)
1298 && AGGREGATE_TYPE_P (gnu_type)
1299 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1300 && !(TYPE_IS_PADDING_P (gnu_type)
1301 && !host_integerp (TYPE_SIZE_UNIT
1302 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1305 gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1306 gnu_expr, const_flag,
1307 Is_Public (gnat_entity),
1308 imported_p || !definition,
1309 static_p, attr_list, gnat_entity);
1310 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1311 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1312 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1314 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1315 if (global_bindings_p ())
1317 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1318 record_global_renaming_pointer (gnu_decl);
1322 if (definition && DECL_SIZE_UNIT (gnu_decl)
1323 && get_block_jmpbuf_decl ()
1324 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1325 || (flag_stack_check == GENERIC_STACK_CHECK
1326 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1327 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1328 add_stmt_with_node (build_call_1_expr
1329 (update_setjmp_buf_decl,
1330 build_unary_op (ADDR_EXPR, NULL_TREE,
1331 get_block_jmpbuf_decl ())),
1334 /* If we are defining an Out parameter and we're not optimizing,
1335 create a fake PARM_DECL for debugging purposes and make it
1336 point to the VAR_DECL. Suppress debug info for the latter
1337 but make sure it will still live on the stack so it can be
1338 accessed from within the debugger through the PARM_DECL. */
1339 if (kind == E_Out_Parameter && definition && !optimize)
1341 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1342 gnat_pushdecl (param, gnat_entity);
1343 SET_DECL_VALUE_EXPR (param, gnu_decl);
1344 DECL_HAS_VALUE_EXPR_P (param) = 1;
1346 debug_info_p = false;
1348 DECL_IGNORED_P (param) = 1;
1349 TREE_ADDRESSABLE (gnu_decl) = 1;
1352 /* If this is a public constant or we're not optimizing and we're not
1353 making a VAR_DECL for it, make one just for export or debugger use.
1354 Likewise if the address is taken or if either the object or type is
1355 aliased. Make an external declaration for a reference, unless this
1356 is a Standard entity since there no real symbol at the object level
1358 if (TREE_CODE (gnu_decl) == CONST_DECL
1359 && (definition || Sloc (gnat_entity) > Standard_Location)
1360 && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
1362 || Address_Taken (gnat_entity)
1363 || Is_Aliased (gnat_entity)
1364 || Is_Aliased (Etype (gnat_entity))))
1367 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1368 gnu_expr, true, Is_Public (gnat_entity),
1369 !definition, static_p, NULL,
1372 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1374 /* As debugging information will be generated for the variable,
1375 do not generate information for the constant. */
1376 DECL_IGNORED_P (gnu_decl) = 1;
1379 /* If this is declared in a block that contains a block with an
1380 exception handler, we must force this variable in memory to
1381 suppress an invalid optimization. */
1382 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1383 && Exception_Mechanism != Back_End_Exceptions)
1384 TREE_ADDRESSABLE (gnu_decl) = 1;
1386 /* Back-annotate Esize and Alignment of the object if not already
1387 known. Note that we pick the values of the type, not those of
1388 the object, to shield ourselves from low-level platform-dependent
1389 adjustments like alignment promotion. This is both consistent with
1390 all the treatment above, where alignment and size are set on the
1391 type of the object and not on the object directly, and makes it
1392 possible to support all confirming representation clauses. */
1393 annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
1399 /* Return a TYPE_DECL for "void" that we previously made. */
1400 gnu_decl = TYPE_NAME (void_type_node);
1403 case E_Enumeration_Type:
1404 /* A special case: for the types Character and Wide_Character in
1405 Standard, we do not list all the literals. So if the literals
1406 are not specified, make this an unsigned type. */
1407 if (No (First_Literal (gnat_entity)))
1409 gnu_type = make_unsigned_type (esize);
1410 TYPE_NAME (gnu_type) = gnu_entity_name;
1412 /* Set TYPE_STRING_FLAG for Character and Wide_Character types.
1413 This is needed by the DWARF-2 back-end to distinguish between
1414 unsigned integer types and character types. */
1415 TYPE_STRING_FLAG (gnu_type) = 1;
1419 /* Normal case of non-character type or non-Standard character type. */
1421 /* Here we have a list of enumeral constants in First_Literal.
1422 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1423 the list to be placed into TYPE_FIELDS. Each node in the list
1424 is a TREE_LIST whose TREE_VALUE is the literal name and whose
1425 TREE_PURPOSE is the value of the literal. */
1427 Entity_Id gnat_literal;
1428 tree gnu_literal_list = NULL_TREE;
1430 if (Is_Unsigned_Type (gnat_entity))
1431 gnu_type = make_unsigned_type (esize);
1433 gnu_type = make_signed_type (esize);
1435 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1437 for (gnat_literal = First_Literal (gnat_entity);
1438 Present (gnat_literal);
1439 gnat_literal = Next_Literal (gnat_literal))
1441 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1444 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1445 gnu_type, gnu_value, true, false, false,
1446 false, NULL, gnat_literal);
1448 save_gnu_tree (gnat_literal, gnu_literal, false);
1449 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1450 gnu_value, gnu_literal_list);
1453 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1455 /* Note that the bounds are updated at the end of this function
1456 to avoid an infinite recursion since they refer to the type. */
1460 case E_Signed_Integer_Type:
1461 case E_Ordinary_Fixed_Point_Type:
1462 case E_Decimal_Fixed_Point_Type:
1463 /* For integer types, just make a signed type the appropriate number
1465 gnu_type = make_signed_type (esize);
1468 case E_Modular_Integer_Type:
1470 /* For modular types, make the unsigned type of the proper number
1471 of bits and then set up the modulus, if required. */
1472 tree gnu_modulus, gnu_high = NULL_TREE;
1474 /* Packed array types are supposed to be subtypes only. */
1475 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1477 gnu_type = make_unsigned_type (esize);
1479 /* Get the modulus in this type. If it overflows, assume it is because
1480 it is equal to 2**Esize. Note that there is no overflow checking
1481 done on unsigned type, so we detect the overflow by looking for
1482 a modulus of zero, which is otherwise invalid. */
1483 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1485 if (!integer_zerop (gnu_modulus))
1487 TYPE_MODULAR_P (gnu_type) = 1;
1488 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1489 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1490 convert (gnu_type, integer_one_node));
1493 /* If the upper bound is not maximal, make an extra subtype. */
1495 && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
1497 tree gnu_subtype = make_unsigned_type (esize);
1498 SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
1499 TREE_TYPE (gnu_subtype) = gnu_type;
1500 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1501 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1502 gnu_type = gnu_subtype;
1507 case E_Signed_Integer_Subtype:
1508 case E_Enumeration_Subtype:
1509 case E_Modular_Integer_Subtype:
1510 case E_Ordinary_Fixed_Point_Subtype:
1511 case E_Decimal_Fixed_Point_Subtype:
1513 /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
1514 not want to call create_range_type since we would like each subtype
1515 node to be distinct. ??? Historically this was in preparation for
1516 when memory aliasing is implemented, but that's obsolete now given
1517 the call to relate_alias_sets below.
1519 The TREE_TYPE field of the INTEGER_TYPE points to the base type;
1520 this fact is used by the arithmetic conversion functions.
1522 We elaborate the Ancestor_Subtype if it is not in the current unit
1523 and one of our bounds is non-static. We do this to ensure consistent
1524 naming in the case where several subtypes share the same bounds, by
1525 elaborating the first such subtype first, thus using its name. */
1528 && Present (Ancestor_Subtype (gnat_entity))
1529 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1530 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1531 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1532 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1534 /* Set the precision to the Esize except for bit-packed arrays. */
1535 if (Is_Packed_Array_Type (gnat_entity)
1536 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1537 esize = UI_To_Int (RM_Size (gnat_entity));
1539 /* This should be an unsigned type if the base type is unsigned or
1540 if the lower bound is constant and non-negative or if the type
1542 if (Is_Unsigned_Type (Etype (gnat_entity))
1543 || Is_Unsigned_Type (gnat_entity)
1544 || Has_Biased_Representation (gnat_entity))
1545 gnu_type = make_unsigned_type (esize);
1547 gnu_type = make_signed_type (esize);
1548 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1550 SET_TYPE_RM_MIN_VALUE
1552 convert (TREE_TYPE (gnu_type),
1553 elaborate_expression (Type_Low_Bound (gnat_entity),
1554 gnat_entity, get_identifier ("L"),
1556 Needs_Debug_Info (gnat_entity))));
1558 SET_TYPE_RM_MAX_VALUE
1560 convert (TREE_TYPE (gnu_type),
1561 elaborate_expression (Type_High_Bound (gnat_entity),
1562 gnat_entity, get_identifier ("U"),
1564 Needs_Debug_Info (gnat_entity))));
1566 /* One of the above calls might have caused us to be elaborated,
1567 so don't blow up if so. */
1568 if (present_gnu_tree (gnat_entity))
1570 maybe_present = true;
1574 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1575 = Has_Biased_Representation (gnat_entity);
1577 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
1578 TYPE_STUB_DECL (gnu_type)
1579 = create_type_stub_decl (gnu_entity_name, gnu_type);
1581 /* Inherit our alias set from what we're a subtype of. Subtypes
1582 are not different types and a pointer can designate any instance
1583 within a subtype hierarchy. */
1584 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1586 /* For a packed array, make the original array type a parallel type. */
1588 && Is_Packed_Array_Type (gnat_entity)
1589 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1590 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1592 (Original_Array_Type (gnat_entity)));
1594 /* If the type we are dealing with represents a bit-packed array,
1595 we need to have the bits left justified on big-endian targets
1596 and right justified on little-endian targets. We also need to
1597 ensure that when the value is read (e.g. for comparison of two
1598 such values), we only get the good bits, since the unused bits
1599 are uninitialized. Both goals are accomplished by wrapping up
1600 the modular type in an enclosing record type. */
1601 if (Is_Packed_Array_Type (gnat_entity)
1602 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1604 tree gnu_field_type, gnu_field;
1606 /* Set the RM size before wrapping up the type. */
1607 SET_TYPE_RM_SIZE (gnu_type,
1608 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1609 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1610 gnu_field_type = gnu_type;
1612 gnu_type = make_node (RECORD_TYPE);
1613 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1615 /* Propagate the alignment of the modular type to the record.
1616 This means that bit-packed arrays have "ceil" alignment for
1617 their size, which may seem counter-intuitive but makes it
1618 possible to easily overlay them on modular types. */
1619 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1620 TYPE_PACKED (gnu_type) = 1;
1622 /* Create a stripped-down declaration of the original type, mainly
1624 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1625 debug_info_p, gnat_entity);
1627 /* Don't notify the field as "addressable", since we won't be taking
1628 it's address and it would prevent create_field_decl from making a
1630 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1631 gnu_field_type, gnu_type, 1, 0, 0, 0);
1633 /* Do not finalize it until after the parallel type is added. */
1634 finish_record_type (gnu_type, gnu_field, 0, true);
1635 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1637 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1639 /* Make the original array type a parallel type. */
1641 && present_gnu_tree (Original_Array_Type (gnat_entity)))
1642 add_parallel_type (TYPE_STUB_DECL (gnu_type),
1644 (Original_Array_Type (gnat_entity)));
1646 rest_of_record_type_compilation (gnu_type);
1649 /* If the type we are dealing with has got a smaller alignment than the
1650 natural one, we need to wrap it up in a record type and under-align
1651 the latter. We reuse the padding machinery for this purpose. */
1652 else if (Present (Alignment_Clause (gnat_entity))
1653 && UI_Is_In_Int_Range (Alignment (gnat_entity))
1654 && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
1655 && align < TYPE_ALIGN (gnu_type))
1657 tree gnu_field_type, gnu_field;
1659 /* Set the RM size before wrapping up the type. */
1660 SET_TYPE_RM_SIZE (gnu_type,
1661 UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
1662 gnu_field_type = gnu_type;
1664 gnu_type = make_node (RECORD_TYPE);
1665 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1667 TYPE_ALIGN (gnu_type) = align;
1668 TYPE_PACKED (gnu_type) = 1;
1670 /* Create a stripped-down declaration of the original type, mainly
1672 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1673 debug_info_p, gnat_entity);
1675 /* Don't notify the field as "addressable", since we won't be taking
1676 it's address and it would prevent create_field_decl from making a
1678 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1679 gnu_field_type, gnu_type, 1, 0, 0, 0);
1681 finish_record_type (gnu_type, gnu_field, 0, false);
1682 TYPE_PADDING_P (gnu_type) = 1;
1684 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1687 /* Otherwise reset the alignment lest we computed it above. */
1693 case E_Floating_Point_Type:
1694 /* If this is a VAX floating-point type, use an integer of the proper
1695 size. All the operations will be handled with ASM statements. */
1696 if (Vax_Float (gnat_entity))
1698 gnu_type = make_signed_type (esize);
1699 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1700 SET_TYPE_DIGITS_VALUE (gnu_type,
1701 UI_To_gnu (Digits_Value (gnat_entity),
1706 /* The type of the Low and High bounds can be our type if this is
1707 a type from Standard, so set them at the end of the function. */
1708 gnu_type = make_node (REAL_TYPE);
1709 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1710 layout_type (gnu_type);
1713 case E_Floating_Point_Subtype:
1714 if (Vax_Float (gnat_entity))
1716 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1722 && Present (Ancestor_Subtype (gnat_entity))
1723 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1724 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1725 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1726 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1729 gnu_type = make_node (REAL_TYPE);
1730 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1731 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1732 TYPE_GCC_MIN_VALUE (gnu_type)
1733 = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
1734 TYPE_GCC_MAX_VALUE (gnu_type)
1735 = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
1736 layout_type (gnu_type);
1738 SET_TYPE_RM_MIN_VALUE
1740 convert (TREE_TYPE (gnu_type),
1741 elaborate_expression (Type_Low_Bound (gnat_entity),
1742 gnat_entity, get_identifier ("L"),
1744 Needs_Debug_Info (gnat_entity))));
1746 SET_TYPE_RM_MAX_VALUE
1748 convert (TREE_TYPE (gnu_type),
1749 elaborate_expression (Type_High_Bound (gnat_entity),
1750 gnat_entity, get_identifier ("U"),
1752 Needs_Debug_Info (gnat_entity))));
1754 /* One of the above calls might have caused us to be elaborated,
1755 so don't blow up if so. */
1756 if (present_gnu_tree (gnat_entity))
1758 maybe_present = true;
1762 /* Inherit our alias set from what we're a subtype of, as for
1763 integer subtypes. */
1764 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1768 /* Array and String Types and Subtypes
1770 Unconstrained array types are represented by E_Array_Type and
1771 constrained array types are represented by E_Array_Subtype. There
1772 are no actual objects of an unconstrained array type; all we have
1773 are pointers to that type.
1775 The following fields are defined on array types and subtypes:
1777 Component_Type Component type of the array.
1778 Number_Dimensions Number of dimensions (an int).
1779 First_Index Type of first index. */
1784 Entity_Id gnat_index, gnat_name;
1785 const bool convention_fortran_p
1786 = (Convention (gnat_entity) == Convention_Fortran);
1787 const int ndim = Number_Dimensions (gnat_entity);
1788 tree gnu_template_fields = NULL_TREE;
1789 tree gnu_template_type = make_node (RECORD_TYPE);
1790 tree gnu_template_reference;
1791 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1792 tree gnu_fat_type = make_node (RECORD_TYPE);
1793 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
1794 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
1795 tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
1798 TYPE_NAME (gnu_template_type)
1799 = create_concat_name (gnat_entity, "XUB");
1801 /* Make a node for the array. If we are not defining the array
1802 suppress expanding incomplete types. */
1803 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1807 defer_incomplete_level++;
1808 this_deferred = true;
1811 /* Build the fat pointer type. Use a "void *" object instead of
1812 a pointer to the array type since we don't have the array type
1813 yet (it will reference the fat pointer via the bounds). */
1814 tem = chainon (chainon (NULL_TREE,
1815 create_field_decl (get_identifier ("P_ARRAY"),
1818 NULL_TREE, NULL_TREE, 0)),
1819 create_field_decl (get_identifier ("P_BOUNDS"),
1822 NULL_TREE, NULL_TREE, 0));
1824 /* Make sure we can put this into a register. */
1825 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1827 /* Do not finalize this record type since the types of its fields
1828 are still incomplete at this point. */
1829 finish_record_type (gnu_fat_type, tem, 0, true);
1830 TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
1832 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1833 is the fat pointer. This will be used to access the individual
1834 fields once we build them. */
1835 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1836 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1837 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1838 gnu_template_reference
1839 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1840 TREE_READONLY (gnu_template_reference) = 1;
1842 /* Now create the GCC type for each index and add the fields for that
1843 index to the template. */
1844 for (index = (convention_fortran_p ? ndim - 1 : 0),
1845 gnat_index = First_Index (gnat_entity);
1846 0 <= index && index < ndim;
1847 index += (convention_fortran_p ? - 1 : 1),
1848 gnat_index = Next_Index (gnat_index))
1850 char field_name[16];
1851 tree gnu_index_base_type
1852 = get_unpadded_type (Base_Type (Etype (gnat_index)));
1853 tree gnu_low_field, gnu_high_field, gnu_low, gnu_high, gnu_max;
1855 /* Make the FIELD_DECLs for the low and high bounds of this
1856 type and then make extractions of these fields from the
1858 sprintf (field_name, "LB%d", index);
1859 gnu_low_field = create_field_decl (get_identifier (field_name),
1860 gnu_index_base_type,
1861 gnu_template_type, 0,
1862 NULL_TREE, NULL_TREE, 0);
1863 Sloc_to_locus (Sloc (gnat_entity),
1864 &DECL_SOURCE_LOCATION (gnu_low_field));
1866 field_name[0] = 'U';
1867 gnu_high_field = create_field_decl (get_identifier (field_name),
1868 gnu_index_base_type,
1869 gnu_template_type, 0,
1870 NULL_TREE, NULL_TREE, 0);
1871 Sloc_to_locus (Sloc (gnat_entity),
1872 &DECL_SOURCE_LOCATION (gnu_high_field));
1874 gnu_temp_fields[index] = chainon (gnu_low_field, gnu_high_field);
1876 /* We can't use build_component_ref here since the template type
1877 isn't complete yet. */
1878 gnu_low = build3 (COMPONENT_REF, gnu_index_base_type,
1879 gnu_template_reference, gnu_low_field,
1881 gnu_high = build3 (COMPONENT_REF, gnu_index_base_type,
1882 gnu_template_reference, gnu_high_field,
1884 TREE_READONLY (gnu_low) = TREE_READONLY (gnu_high) = 1;
1886 /* Compute the size of this dimension. */
1888 = build3 (COND_EXPR, gnu_index_base_type,
1889 build2 (GE_EXPR, integer_type_node, gnu_high, gnu_low),
1891 build2 (MINUS_EXPR, gnu_index_base_type,
1892 gnu_low, fold_convert (gnu_index_base_type,
1893 integer_one_node)));
1895 /* Make a range type with the new range in the Ada base type.
1896 Then make an index type with the size range in sizetype. */
1897 gnu_index_types[index]
1898 = create_index_type (convert (sizetype, gnu_low),
1899 convert (sizetype, gnu_max),
1900 create_range_type (gnu_index_base_type,
1904 /* Update the maximum size of the array in elements. */
1907 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
1909 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
1911 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
1913 = size_binop (MAX_EXPR,
1914 size_binop (PLUS_EXPR, size_one_node,
1915 size_binop (MINUS_EXPR,
1919 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1920 && TREE_OVERFLOW (gnu_this_max))
1921 gnu_max_size = NULL_TREE;
1924 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1927 TYPE_NAME (gnu_index_types[index])
1928 = create_concat_name (gnat_entity, field_name);
1931 for (index = 0; index < ndim; index++)
1933 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1935 /* Install all the fields into the template. */
1936 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1937 TYPE_READONLY (gnu_template_type) = 1;
1939 /* Now make the array of arrays and update the pointer to the array
1940 in the fat pointer. Note that it is the first field. */
1941 tem = gnat_to_gnu_component_type (gnat_entity, definition,
1944 /* If Component_Size is not already specified, annotate it with the
1945 size of the component. */
1946 if (Unknown_Component_Size (gnat_entity))
1947 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1949 /* Compute the maximum size of the array in units and bits. */
1952 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1953 TYPE_SIZE_UNIT (tem));
1954 gnu_max_size = size_binop (MULT_EXPR,
1955 convert (bitsizetype, gnu_max_size),
1959 gnu_max_size_unit = NULL_TREE;
1961 /* Now build the array type. */
1962 for (index = ndim - 1; index >= 0; index--)
1964 tem = build_array_type (tem, gnu_index_types[index]);
1965 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1966 if (array_type_has_nonaliased_component (gnat_entity, tem))
1967 TYPE_NONALIASED_COMPONENT (tem) = 1;
1970 /* If an alignment is specified, use it if valid. But ignore it
1971 for the original type of packed array types. If the alignment
1972 was requested with an explicit alignment clause, state so. */
1973 if (No (Packed_Array_Type (gnat_entity))
1974 && Known_Alignment (gnat_entity))
1977 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1979 if (Present (Alignment_Clause (gnat_entity)))
1980 TYPE_USER_ALIGN (tem) = 1;
1983 TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
1984 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1986 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1987 corresponding fat pointer. */
1988 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1989 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1990 SET_TYPE_MODE (gnu_type, BLKmode);
1991 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1992 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1994 /* If the maximum size doesn't overflow, use it. */
1996 && TREE_CODE (gnu_max_size) == INTEGER_CST
1997 && !TREE_OVERFLOW (gnu_max_size)
1998 && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1999 && !TREE_OVERFLOW (gnu_max_size_unit))
2001 TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
2003 TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
2004 TYPE_SIZE_UNIT (tem));
2007 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2008 tem, NULL, !Comes_From_Source (gnat_entity),
2009 debug_info_p, gnat_entity);
2011 /* Give the fat pointer type a name. If this is a packed type, tell
2012 the debugger how to interpret the underlying bits. */
2013 if (Present (Packed_Array_Type (gnat_entity)))
2014 gnat_name = Packed_Array_Type (gnat_entity);
2016 gnat_name = gnat_entity;
2017 create_type_decl (create_concat_name (gnat_name, "XUP"),
2018 gnu_fat_type, NULL, true,
2019 debug_info_p, gnat_entity);
2021 /* Create the type to be used as what a thin pointer designates: an
2022 record type for the object and its template with the field offsets
2023 shifted to have the template at a negative offset. */
2024 tem = build_unc_object_type (gnu_template_type, tem,
2025 create_concat_name (gnat_name, "XUT"));
2026 shift_unc_components_for_thin_pointers (tem);
2028 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2029 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2033 case E_String_Subtype:
2034 case E_Array_Subtype:
2036 /* This is the actual data type for array variables. Multidimensional
2037 arrays are implemented as arrays of arrays. Note that arrays which
2038 have sparse enumeration subtypes as index components create sparse
2039 arrays, which is obviously space inefficient but so much easier to
2042 Also note that the subtype never refers to the unconstrained array
2043 type, which is somewhat at variance with Ada semantics.
2045 First check to see if this is simply a renaming of the array type.
2046 If so, the result is the array type. */
2048 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2049 if (!Is_Constrained (gnat_entity))
2053 Entity_Id gnat_index, gnat_base_index;
2054 const bool convention_fortran_p
2055 = (Convention (gnat_entity) == Convention_Fortran);
2056 const int ndim = Number_Dimensions (gnat_entity);
2057 tree gnu_base_type = gnu_type;
2058 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
2059 tree gnu_max_size = size_one_node, gnu_max_size_unit;
2060 bool need_index_type_struct = false;
2063 /* First create the GCC type for each index and find out whether
2064 special types are needed for debugging information. */
2065 for (index = (convention_fortran_p ? ndim - 1 : 0),
2066 gnat_index = First_Index (gnat_entity),
2068 = First_Index (Implementation_Base_Type (gnat_entity));
2069 0 <= index && index < ndim;
2070 index += (convention_fortran_p ? - 1 : 1),
2071 gnat_index = Next_Index (gnat_index),
2072 gnat_base_index = Next_Index (gnat_base_index))
2074 tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
2076 = compare_tree_int (TYPE_RM_SIZE (gnu_index_type),
2077 TYPE_PRECISION (sizetype));
2078 const bool subrange_p = (prec_comp < 0)
2080 && TYPE_UNSIGNED (gnu_index_type)
2081 == TYPE_UNSIGNED (sizetype));
2082 const bool wider_p = (prec_comp > 0);
2083 tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
2084 tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
2085 tree gnu_min = convert (sizetype, gnu_orig_min);
2086 tree gnu_max = convert (sizetype, gnu_orig_max);
2087 tree gnu_base_index_type
2088 = get_unpadded_type (Etype (gnat_base_index));
2089 tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
2090 tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
2091 tree gnu_high, gnu_low;
2093 /* See if the base array type is already flat. If it is, we
2094 are probably compiling an ACATS test but it will cause the
2095 code below to malfunction if we don't handle it specially. */
2096 if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
2097 && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
2098 && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
2100 gnu_min = size_one_node;
2101 gnu_max = size_zero_node;
2105 /* Similarly, if one of the values overflows in sizetype and the
2106 range is null, use 1..0 for the sizetype bounds. */
2107 else if (!subrange_p
2108 && TREE_CODE (gnu_min) == INTEGER_CST
2109 && TREE_CODE (gnu_max) == INTEGER_CST
2110 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2111 && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
2113 gnu_min = size_one_node;
2114 gnu_max = size_zero_node;
2118 /* If the minimum and maximum values both overflow in sizetype,
2119 but the difference in the original type does not overflow in
2120 sizetype, ignore the overflow indication. */
2121 else if (!subrange_p
2122 && TREE_CODE (gnu_min) == INTEGER_CST
2123 && TREE_CODE (gnu_max) == INTEGER_CST
2124 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2127 fold_build2 (MINUS_EXPR, gnu_index_type,
2131 TREE_OVERFLOW (gnu_min) = 0;
2132 TREE_OVERFLOW (gnu_max) = 0;
2136 /* Compute the size of this dimension in the general case. We
2137 need to provide GCC with an upper bound to use but have to
2138 deal with the "superflat" case. There are three ways to do
2139 this. If we can prove that the array can never be superflat,
2140 we can just use the high bound of the index type. */
2141 else if (Nkind (gnat_index) == N_Range
2142 && cannot_be_superflat_p (gnat_index))
2145 /* Otherwise, if we can prove that the low bound minus one and
2146 the high bound cannot overflow, we can just use the expression
2147 MAX (hb, lb - 1). Similarly, if we can prove that the high
2148 bound plus one and the low bound cannot overflow, we can use
2149 the high bound as-is and MIN (hb + 1, lb) for the low bound.
2150 Otherwise, we have to fall back to the most general expression
2151 (hb >= lb) ? hb : lb - 1. Note that the comparison must be
2152 done in the original index type, to avoid any overflow during
2156 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2157 gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node);
2159 /* If gnu_high is a constant that has overflowed, the low
2160 bound is the smallest integer so cannot be the maximum.
2161 If gnu_low is a constant that has overflowed, the high
2162 bound is the highest integer so cannot be the minimum. */
2163 if ((TREE_CODE (gnu_high) == INTEGER_CST
2164 && TREE_OVERFLOW (gnu_high))
2165 || (TREE_CODE (gnu_low) == INTEGER_CST
2166 && TREE_OVERFLOW (gnu_low)))
2169 /* If the index type is a subrange and gnu_high a constant
2170 that hasn't overflowed, we can use the maximum. */
2171 else if (subrange_p && TREE_CODE (gnu_high) == INTEGER_CST)
2172 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2174 /* If the index type is a subrange and gnu_low a constant
2175 that hasn't overflowed, we can use the minimum. */
2176 else if (subrange_p && TREE_CODE (gnu_low) == INTEGER_CST)
2179 gnu_min = size_binop (MIN_EXPR, gnu_min, gnu_low);
2184 = build_cond_expr (sizetype,
2185 build_binary_op (GE_EXPR,
2192 gnu_index_types[index]
2193 = create_index_type (gnu_min, gnu_high, gnu_index_type,
2196 /* Update the maximum size of the array in elements. Here we
2197 see if any constraint on the index type of the base type
2198 can be used in the case of self-referential bound on the
2199 index type of the subtype. We look for a non-"infinite"
2200 and non-self-referential bound from any type involved and
2201 handle each bound separately. */
2204 tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
2205 tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
2206 tree gnu_base_index_base_type
2207 = get_base_type (gnu_base_index_type);
2208 tree gnu_base_base_min
2209 = convert (sizetype,
2210 TYPE_MIN_VALUE (gnu_base_index_base_type));
2211 tree gnu_base_base_max
2212 = convert (sizetype,
2213 TYPE_MAX_VALUE (gnu_base_index_base_type));
2215 if (!CONTAINS_PLACEHOLDER_P (gnu_min)
2216 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2217 && !TREE_OVERFLOW (gnu_base_min)))
2218 gnu_base_min = gnu_min;
2220 if (!CONTAINS_PLACEHOLDER_P (gnu_max)
2221 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2222 && !TREE_OVERFLOW (gnu_base_max)))
2223 gnu_base_max = gnu_max;
2225 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2226 && TREE_OVERFLOW (gnu_base_min))
2227 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2228 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2229 && TREE_OVERFLOW (gnu_base_max))
2230 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2231 gnu_max_size = NULL_TREE;
2235 = size_binop (MAX_EXPR,
2236 size_binop (PLUS_EXPR, size_one_node,
2237 size_binop (MINUS_EXPR,
2242 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2243 && TREE_OVERFLOW (gnu_this_max))
2244 gnu_max_size = NULL_TREE;
2247 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2251 /* We need special types for debugging information to point to
2252 the index types if they have variable bounds, are not integer
2253 types, are biased or are wider than sizetype. */
2254 if (!integer_onep (gnu_orig_min)
2255 || TREE_CODE (gnu_orig_max) != INTEGER_CST
2256 || TREE_CODE (gnu_index_type) != INTEGER_TYPE
2257 || (TREE_TYPE (gnu_index_type)
2258 && TREE_CODE (TREE_TYPE (gnu_index_type))
2260 || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)
2262 need_index_type_struct = true;
2265 /* Then flatten: create the array of arrays. For an array type
2266 used to implement a packed array, get the component type from
2267 the original array type since the representation clauses that
2268 can affect it are on the latter. */
2269 if (Is_Packed_Array_Type (gnat_entity)
2270 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2272 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2273 for (index = ndim - 1; index >= 0; index--)
2274 gnu_type = TREE_TYPE (gnu_type);
2276 /* One of the above calls might have caused us to be elaborated,
2277 so don't blow up if so. */
2278 if (present_gnu_tree (gnat_entity))
2280 maybe_present = true;
2286 gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
2289 /* One of the above calls might have caused us to be elaborated,
2290 so don't blow up if so. */
2291 if (present_gnu_tree (gnat_entity))
2293 maybe_present = true;
2298 /* Compute the maximum size of the array in units and bits. */
2301 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2302 TYPE_SIZE_UNIT (gnu_type));
2303 gnu_max_size = size_binop (MULT_EXPR,
2304 convert (bitsizetype, gnu_max_size),
2305 TYPE_SIZE (gnu_type));
2308 gnu_max_size_unit = NULL_TREE;
2310 /* Now build the array type. */
2311 for (index = ndim - 1; index >= 0; index --)
2313 gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
2314 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2315 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2316 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2319 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2320 TYPE_STUB_DECL (gnu_type)
2321 = create_type_stub_decl (gnu_entity_name, gnu_type);
2323 /* If we are at file level and this is a multi-dimensional array,
2324 we need to make a variable corresponding to the stride of the
2325 inner dimensions. */
2326 if (global_bindings_p () && ndim > 1)
2328 tree gnu_str_name = get_identifier ("ST");
2331 for (gnu_arr_type = TREE_TYPE (gnu_type);
2332 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2333 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2334 gnu_str_name = concat_name (gnu_str_name, "ST"))
2336 tree eltype = TREE_TYPE (gnu_arr_type);
2338 TYPE_SIZE (gnu_arr_type)
2339 = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
2340 gnat_entity, gnu_str_name,
2343 /* ??? For now, store the size as a multiple of the
2344 alignment of the element type in bytes so that we
2345 can see the alignment from the tree. */
2346 TYPE_SIZE_UNIT (gnu_arr_type)
2348 (MULT_EXPR, sizetype,
2349 elaborate_expression_1
2350 (build_binary_op (EXACT_DIV_EXPR, sizetype,
2351 TYPE_SIZE_UNIT (gnu_arr_type),
2352 size_int (TYPE_ALIGN (eltype)
2354 gnat_entity, concat_name (gnu_str_name, "A_U"),
2356 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2358 /* ??? create_type_decl is not invoked on the inner types so
2359 the MULT_EXPR node built above will never be marked. */
2360 MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
2364 /* If we need to write out a record type giving the names of the
2365 bounds for debugging purposes, do it now and make the record
2366 type a parallel type. This is not needed for a packed array
2367 since the bounds are conveyed by the original array type. */
2368 if (need_index_type_struct
2370 && !Is_Packed_Array_Type (gnat_entity))
2372 tree gnu_bound_rec = make_node (RECORD_TYPE);
2373 tree gnu_field_list = NULL_TREE;
2376 TYPE_NAME (gnu_bound_rec)
2377 = create_concat_name (gnat_entity, "XA");
2379 for (index = ndim - 1; index >= 0; index--)
2381 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
2382 tree gnu_index_name = TYPE_NAME (gnu_index);
2384 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2385 gnu_index_name = DECL_NAME (gnu_index_name);
2387 /* Make sure to reference the types themselves, and not just
2388 their names, as the debugger may fall back on them. */
2389 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2391 0, NULL_TREE, NULL_TREE, 0);
2392 TREE_CHAIN (gnu_field) = gnu_field_list;
2393 gnu_field_list = gnu_field;
2396 finish_record_type (gnu_bound_rec, gnu_field_list, 0, false);
2397 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2400 /* Otherwise, for a packed array, make the original array type a
2402 else if (debug_info_p
2403 && Is_Packed_Array_Type (gnat_entity)
2404 && present_gnu_tree (Original_Array_Type (gnat_entity)))
2405 add_parallel_type (TYPE_STUB_DECL (gnu_type),
2407 (Original_Array_Type (gnat_entity)));
2409 TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
2410 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2411 = (Is_Packed_Array_Type (gnat_entity)
2412 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2414 /* If the size is self-referential and the maximum size doesn't
2415 overflow, use it. */
2416 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2418 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2419 && TREE_OVERFLOW (gnu_max_size))
2420 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2421 && TREE_OVERFLOW (gnu_max_size_unit)))
2423 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2424 TYPE_SIZE (gnu_type));
2425 TYPE_SIZE_UNIT (gnu_type)
2426 = size_binop (MIN_EXPR, gnu_max_size_unit,
2427 TYPE_SIZE_UNIT (gnu_type));
2430 /* Set our alias set to that of our base type. This gives all
2431 array subtypes the same alias set. */
2432 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2434 /* If this is a packed type, make this type the same as the packed
2435 array type, but do some adjusting in the type first. */
2436 if (Present (Packed_Array_Type (gnat_entity)))
2438 Entity_Id gnat_index;
2441 /* First finish the type we had been making so that we output
2442 debugging information for it. */
2443 if (Treat_As_Volatile (gnat_entity))
2445 = build_qualified_type (gnu_type,
2446 TYPE_QUALS (gnu_type)
2447 | TYPE_QUAL_VOLATILE);
2449 /* Make it artificial only if the base type was artificial too.
2450 That's sort of "morally" true and will make it possible for
2451 the debugger to look it up by name in DWARF, which is needed
2452 in order to decode the packed array type. */
2454 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2455 !Comes_From_Source (Etype (gnat_entity))
2456 && !Comes_From_Source (gnat_entity),
2457 debug_info_p, gnat_entity);
2459 /* Save it as our equivalent in case the call below elaborates
2461 save_gnu_tree (gnat_entity, gnu_decl, false);
2463 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2465 this_made_decl = true;
2466 gnu_type = TREE_TYPE (gnu_decl);
2467 save_gnu_tree (gnat_entity, NULL_TREE, false);
2469 gnu_inner = gnu_type;
2470 while (TREE_CODE (gnu_inner) == RECORD_TYPE
2471 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
2472 || TYPE_PADDING_P (gnu_inner)))
2473 gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
2475 /* We need to attach the index type to the type we just made so
2476 that the actual bounds can later be put into a template. */
2477 if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
2478 && !TYPE_ACTUAL_BOUNDS (gnu_inner))
2479 || (TREE_CODE (gnu_inner) == INTEGER_TYPE
2480 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
2482 if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
2484 /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
2485 TYPE_MODULUS for modular types so we make an extra
2486 subtype if necessary. */
2487 if (TYPE_MODULAR_P (gnu_inner))
2490 = make_unsigned_type (TYPE_PRECISION (gnu_inner));
2491 TREE_TYPE (gnu_subtype) = gnu_inner;
2492 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2493 SET_TYPE_RM_MIN_VALUE (gnu_subtype,
2494 TYPE_MIN_VALUE (gnu_inner));
2495 SET_TYPE_RM_MAX_VALUE (gnu_subtype,
2496 TYPE_MAX_VALUE (gnu_inner));
2497 gnu_inner = gnu_subtype;
2500 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
2502 #ifdef ENABLE_CHECKING
2503 /* Check for other cases of overloading. */
2504 gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
2508 for (gnat_index = First_Index (gnat_entity);
2509 Present (gnat_index);
2510 gnat_index = Next_Index (gnat_index))
2511 SET_TYPE_ACTUAL_BOUNDS
2513 tree_cons (NULL_TREE,
2514 get_unpadded_type (Etype (gnat_index)),
2515 TYPE_ACTUAL_BOUNDS (gnu_inner)));
2517 if (Convention (gnat_entity) != Convention_Fortran)
2518 SET_TYPE_ACTUAL_BOUNDS
2519 (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
2521 if (TREE_CODE (gnu_type) == RECORD_TYPE
2522 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2523 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
2528 /* Abort if packed array with no Packed_Array_Type field set. */
2529 gcc_assert (!Is_Packed (gnat_entity));
2533 case E_String_Literal_Subtype:
2534 /* Create the type for a string literal. */
2536 Entity_Id gnat_full_type
2537 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2538 && Present (Full_View (Etype (gnat_entity)))
2539 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2540 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2541 tree gnu_string_array_type
2542 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2543 tree gnu_string_index_type
2544 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2545 (TYPE_DOMAIN (gnu_string_array_type))));
2546 tree gnu_lower_bound
2547 = convert (gnu_string_index_type,
2548 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2549 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2550 tree gnu_length = ssize_int (length - 1);
2551 tree gnu_upper_bound
2552 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2554 convert (gnu_string_index_type, gnu_length));
2556 = create_index_type (convert (sizetype, gnu_lower_bound),
2557 convert (sizetype, gnu_upper_bound),
2558 create_range_type (gnu_string_index_type,
2564 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2566 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2567 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2568 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2572 /* Record Types and Subtypes
2574 The following fields are defined on record types:
2576 Has_Discriminants True if the record has discriminants
2577 First_Discriminant Points to head of list of discriminants
2578 First_Entity Points to head of list of fields
2579 Is_Tagged_Type True if the record is tagged
2581 Implementation of Ada records and discriminated records:
2583 A record type definition is transformed into the equivalent of a C
2584 struct definition. The fields that are the discriminants which are
2585 found in the Full_Type_Declaration node and the elements of the
2586 Component_List found in the Record_Type_Definition node. The
2587 Component_List can be a recursive structure since each Variant of
2588 the Variant_Part of the Component_List has a Component_List.
2590 Processing of a record type definition comprises starting the list of
2591 field declarations here from the discriminants and the calling the
2592 function components_to_record to add the rest of the fields from the
2593 component list and return the gnu type node. The function
2594 components_to_record will call itself recursively as it traverses
2598 if (Has_Complex_Representation (gnat_entity))
2601 = build_complex_type
2603 (Etype (Defining_Entity
2604 (First (Component_Items
2607 (Declaration_Node (gnat_entity)))))))));
2613 Node_Id full_definition = Declaration_Node (gnat_entity);
2614 Node_Id record_definition = Type_Definition (full_definition);
2615 Entity_Id gnat_field;
2616 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2617 /* Set PACKED in keeping with gnat_to_gnu_field. */
2619 = Is_Packed (gnat_entity)
2621 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2623 : (Known_Alignment (gnat_entity)
2624 || (Strict_Alignment (gnat_entity)
2625 && Known_Static_Esize (gnat_entity)))
2628 bool has_discr = Has_Discriminants (gnat_entity);
2629 bool has_rep = Has_Specified_Layout (gnat_entity);
2630 bool all_rep = has_rep;
2632 = (Is_Tagged_Type (gnat_entity)
2633 && Nkind (record_definition) == N_Derived_Type_Definition);
2634 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2636 /* See if all fields have a rep clause. Stop when we find one
2639 for (gnat_field = First_Entity (gnat_entity);
2640 Present (gnat_field);
2641 gnat_field = Next_Entity (gnat_field))
2642 if ((Ekind (gnat_field) == E_Component
2643 || Ekind (gnat_field) == E_Discriminant)
2644 && No (Component_Clause (gnat_field)))
2650 /* If this is a record extension, go a level further to find the
2651 record definition. Also, verify we have a Parent_Subtype. */
2654 if (!type_annotate_only
2655 || Present (Record_Extension_Part (record_definition)))
2656 record_definition = Record_Extension_Part (record_definition);
2658 gcc_assert (type_annotate_only
2659 || Present (Parent_Subtype (gnat_entity)));
2662 /* Make a node for the record. If we are not defining the record,
2663 suppress expanding incomplete types. */
2664 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2665 TYPE_NAME (gnu_type) = gnu_entity_name;
2666 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2670 defer_incomplete_level++;
2671 this_deferred = true;
2674 /* If both a size and rep clause was specified, put the size in
2675 the record type now so that it can get the proper mode. */
2676 if (has_rep && Known_Esize (gnat_entity))
2677 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2679 /* Always set the alignment here so that it can be used to
2680 set the mode, if it is making the alignment stricter. If
2681 it is invalid, it will be checked again below. If this is to
2682 be Atomic, choose a default alignment of a word unless we know
2683 the size and it's smaller. */
2684 if (Known_Alignment (gnat_entity))
2685 TYPE_ALIGN (gnu_type)
2686 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2687 else if (Is_Atomic (gnat_entity))
2688 TYPE_ALIGN (gnu_type)
2689 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2690 /* If a type needs strict alignment, the minimum size will be the
2691 type size instead of the RM size (see validate_size). Cap the
2692 alignment, lest it causes this type size to become too large. */
2693 else if (Strict_Alignment (gnat_entity)
2694 && Known_Static_Esize (gnat_entity))
2696 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2697 unsigned int raw_align = raw_size & -raw_size;
2698 if (raw_align < BIGGEST_ALIGNMENT)
2699 TYPE_ALIGN (gnu_type) = raw_align;
2702 TYPE_ALIGN (gnu_type) = 0;
2704 /* If we have a Parent_Subtype, make a field for the parent. If
2705 this record has rep clauses, force the position to zero. */
2706 if (Present (Parent_Subtype (gnat_entity)))
2708 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2711 /* A major complexity here is that the parent subtype will
2712 reference our discriminants in its Discriminant_Constraint
2713 list. But those must reference the parent component of this
2714 record which is of the parent subtype we have not built yet!
2715 To break the circle we first build a dummy COMPONENT_REF which
2716 represents the "get to the parent" operation and initialize
2717 each of those discriminants to a COMPONENT_REF of the above
2718 dummy parent referencing the corresponding discriminant of the
2719 base type of the parent subtype. */
2720 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2721 build0 (PLACEHOLDER_EXPR, gnu_type),
2722 build_decl (input_location,
2723 FIELD_DECL, NULL_TREE,
2728 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2729 Present (gnat_field);
2730 gnat_field = Next_Stored_Discriminant (gnat_field))
2731 if (Present (Corresponding_Discriminant (gnat_field)))
2734 build3 (COMPONENT_REF,
2735 get_unpadded_type (Etype (gnat_field)),
2737 gnat_to_gnu_field_decl (Corresponding_Discriminant
2742 /* Then we build the parent subtype. If it has discriminants but
2743 the type itself has unknown discriminants, this means that it
2744 doesn't contain information about how the discriminants are
2745 derived from those of the ancestor type, so it cannot be used
2746 directly. Instead it is built by cloning the parent subtype
2747 of the underlying record view of the type, for which the above
2748 derivation of discriminants has been made explicit. */
2749 if (Has_Discriminants (gnat_parent)
2750 && Has_Unknown_Discriminants (gnat_entity))
2752 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2754 /* If we are defining the type, the underlying record
2755 view must already have been elaborated at this point.
2756 Otherwise do it now as its parent subtype cannot be
2757 technically elaborated on its own. */
2759 gcc_assert (present_gnu_tree (gnat_uview));
2761 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2763 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2765 /* Substitute the "get to the parent" of the type for that
2766 of its underlying record view in the cloned type. */
2767 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2768 Present (gnat_field);
2769 gnat_field = Next_Stored_Discriminant (gnat_field))
2770 if (Present (Corresponding_Discriminant (gnat_field)))
2772 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2774 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2775 gnu_get_parent, gnu_field, NULL_TREE);
2777 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2781 gnu_parent = gnat_to_gnu_type (gnat_parent);
2783 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2784 initially built. The discriminants must reference the fields
2785 of the parent subtype and not those of its base type for the
2786 placeholder machinery to properly work. */
2789 /* The actual parent subtype is the full view. */
2790 if (IN (Ekind (gnat_parent), Private_Kind))
2792 if (Present (Full_View (gnat_parent)))
2793 gnat_parent = Full_View (gnat_parent);
2795 gnat_parent = Underlying_Full_View (gnat_parent);
2798 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2799 Present (gnat_field);
2800 gnat_field = Next_Stored_Discriminant (gnat_field))
2801 if (Present (Corresponding_Discriminant (gnat_field)))
2803 Entity_Id field = Empty;
2804 for (field = First_Stored_Discriminant (gnat_parent);
2806 field = Next_Stored_Discriminant (field))
2807 if (same_discriminant_p (gnat_field, field))
2809 gcc_assert (Present (field));
2810 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2811 = gnat_to_gnu_field_decl (field);
2815 /* The "get to the parent" COMPONENT_REF must be given its
2817 TREE_TYPE (gnu_get_parent) = gnu_parent;
2819 /* ...and reference the _Parent field of this record. */
2821 = create_field_decl (get_identifier
2822 (Get_Name_String (Name_uParent)),
2823 gnu_parent, gnu_type, 0,
2825 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2827 ? bitsize_zero_node : NULL_TREE, 1);
2828 DECL_INTERNAL_P (gnu_field) = 1;
2829 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2830 TYPE_FIELDS (gnu_type) = gnu_field;
2833 /* Make the fields for the discriminants and put them into the record
2834 unless it's an Unchecked_Union. */
2836 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2837 Present (gnat_field);
2838 gnat_field = Next_Stored_Discriminant (gnat_field))
2840 /* If this is a record extension and this discriminant is the
2841 renaming of another discriminant, we've handled it above. */
2842 if (Present (Parent_Subtype (gnat_entity))
2843 && Present (Corresponding_Discriminant (gnat_field)))
2847 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
2850 /* Make an expression using a PLACEHOLDER_EXPR from the
2851 FIELD_DECL node just created and link that with the
2852 corresponding GNAT defining identifier. */
2853 save_gnu_tree (gnat_field,
2854 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2855 build0 (PLACEHOLDER_EXPR, gnu_type),
2856 gnu_field, NULL_TREE),
2859 if (!is_unchecked_union)
2861 TREE_CHAIN (gnu_field) = gnu_field_list;
2862 gnu_field_list = gnu_field;
2866 /* Add the fields into the record type and finish it up. */
2867 components_to_record (gnu_type, Component_List (record_definition),
2868 gnu_field_list, packed, definition, NULL,
2869 false, all_rep, false, is_unchecked_union,
2872 /* If it is a tagged record force the type to BLKmode to insure that
2873 these objects will always be put in memory. Likewise for limited
2875 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2876 SET_TYPE_MODE (gnu_type, BLKmode);
2878 /* We used to remove the associations of the discriminants and _Parent
2879 for validity checking but we may need them if there's a Freeze_Node
2880 for a subtype used in this record. */
2881 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2883 /* Fill in locations of fields. */
2884 annotate_rep (gnat_entity, gnu_type);
2886 /* If there are any entities in the chain corresponding to components
2887 that we did not elaborate, ensure we elaborate their types if they
2889 for (gnat_temp = First_Entity (gnat_entity);
2890 Present (gnat_temp);
2891 gnat_temp = Next_Entity (gnat_temp))
2892 if ((Ekind (gnat_temp) == E_Component
2893 || Ekind (gnat_temp) == E_Discriminant)
2894 && Is_Itype (Etype (gnat_temp))
2895 && !present_gnu_tree (gnat_temp))
2896 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2900 case E_Class_Wide_Subtype:
2901 /* If an equivalent type is present, that is what we should use.
2902 Otherwise, fall through to handle this like a record subtype
2903 since it may have constraints. */
2904 if (gnat_equiv_type != gnat_entity)
2906 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2907 maybe_present = true;
2911 /* ... fall through ... */
2913 case E_Record_Subtype:
2914 /* If Cloned_Subtype is Present it means this record subtype has
2915 identical layout to that type or subtype and we should use
2916 that GCC type for this one. The front end guarantees that
2917 the component list is shared. */
2918 if (Present (Cloned_Subtype (gnat_entity)))
2920 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2922 maybe_present = true;
2926 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2927 changing the type, make a new type with each field having the type of
2928 the field in the new subtype but the position computed by transforming
2929 every discriminant reference according to the constraints. We don't
2930 see any difference between private and non-private type here since
2931 derivations from types should have been deferred until the completion
2932 of the private type. */
2935 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2940 defer_incomplete_level++;
2941 this_deferred = true;
2944 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2946 if (present_gnu_tree (gnat_entity))
2948 maybe_present = true;
2952 /* When the subtype has discriminants and these discriminants affect
2953 the initial shape it has inherited, factor them in. But for an
2954 Unchecked_Union (it must be an Itype), just return the type.
2955 We can't just test Is_Constrained because private subtypes without
2956 discriminants of types with discriminants with default expressions
2957 are Is_Constrained but aren't constrained! */
2958 if (IN (Ekind (gnat_base_type), Record_Kind)
2959 && !Is_Unchecked_Union (gnat_base_type)
2960 && !Is_For_Access_Subtype (gnat_entity)
2961 && Is_Constrained (gnat_entity)
2962 && Has_Discriminants (gnat_entity)
2963 && Present (Discriminant_Constraint (gnat_entity))
2964 && Stored_Constraint (gnat_entity) != No_Elist)
2967 = build_subst_list (gnat_entity, gnat_base_type, definition);
2968 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
2969 tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
2970 bool selected_variant = false;
2971 Entity_Id gnat_field;
2973 gnu_type = make_node (RECORD_TYPE);
2974 TYPE_NAME (gnu_type) = gnu_entity_name;
2976 /* Set the size, alignment and alias set of the new type to
2977 match that of the old one, doing required substitutions. */
2978 copy_and_substitute_in_size (gnu_type, gnu_base_type,
2981 if (TYPE_IS_PADDING_P (gnu_base_type))
2982 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2984 gnu_unpad_base_type = gnu_base_type;
2986 /* Look for a REP part in the base type. */
2987 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
2989 /* Look for a variant part in the base type. */
2990 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
2992 /* If there is a variant part, we must compute whether the
2993 constraints statically select a particular variant. If
2994 so, we simply drop the qualified union and flatten the
2995 list of fields. Otherwise we'll build a new qualified
2996 union for the variants that are still relevant. */
2997 if (gnu_variant_part)
3000 = build_variant_list (TREE_TYPE (gnu_variant_part),
3001 gnu_subst_list, NULL_TREE);
3003 /* If all the qualifiers are unconditionally true, the
3004 innermost variant is statically selected. */
3005 selected_variant = true;
3006 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3007 if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
3009 selected_variant = false;
3013 /* Otherwise, create the new variants. */
3014 if (!selected_variant)
3015 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3017 tree old_variant = TREE_PURPOSE (t);
3018 tree new_variant = make_node (RECORD_TYPE);
3019 TYPE_NAME (new_variant)
3020 = DECL_NAME (TYPE_NAME (old_variant));
3021 copy_and_substitute_in_size (new_variant, old_variant,
3023 TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
3028 gnu_variant_list = NULL_TREE;
3029 selected_variant = false;
3033 = build_position_list (gnu_unpad_base_type,
3034 gnu_variant_list && !selected_variant,
3035 size_zero_node, bitsize_zero_node,
3036 BIGGEST_ALIGNMENT, NULL_TREE);
3038 for (gnat_field = First_Entity (gnat_entity);
3039 Present (gnat_field);
3040 gnat_field = Next_Entity (gnat_field))
3041 if ((Ekind (gnat_field) == E_Component
3042 || Ekind (gnat_field) == E_Discriminant)
3043 && !(Present (Corresponding_Discriminant (gnat_field))
3044 && Is_Tagged_Type (gnat_base_type))
3045 && Underlying_Type (Scope (Original_Record_Component
3049 Name_Id gnat_name = Chars (gnat_field);
3050 Entity_Id gnat_old_field
3051 = Original_Record_Component (gnat_field);
3053 = gnat_to_gnu_field_decl (gnat_old_field);
3054 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3055 tree gnu_field, gnu_field_type, gnu_size;
3056 tree gnu_cont_type, gnu_last = NULL_TREE;
3058 /* If the type is the same, retrieve the GCC type from the
3059 old field to take into account possible adjustments. */
3060 if (Etype (gnat_field) == Etype (gnat_old_field))
3061 gnu_field_type = TREE_TYPE (gnu_old_field);
3063 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3065 /* If there was a component clause, the field types must be
3066 the same for the type and subtype, so copy the data from
3067 the old field to avoid recomputation here. Also if the
3068 field is justified modular and the optimization in
3069 gnat_to_gnu_field was applied. */
3070 if (Present (Component_Clause (gnat_old_field))
3071 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3072 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3073 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3074 == TREE_TYPE (gnu_old_field)))
3076 gnu_size = DECL_SIZE (gnu_old_field);
3077 gnu_field_type = TREE_TYPE (gnu_old_field);
3080 /* If the old field was packed and of constant size, we
3081 have to get the old size here, as it might differ from
3082 what the Etype conveys and the latter might overlap
3083 onto the following field. Try to arrange the type for
3084 possible better packing along the way. */
3085 else if (DECL_PACKED (gnu_old_field)
3086 && TREE_CODE (DECL_SIZE (gnu_old_field))
3089 gnu_size = DECL_SIZE (gnu_old_field);
3090 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3091 && !TYPE_FAT_POINTER_P (gnu_field_type)
3092 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3094 = make_packable_type (gnu_field_type, true);
3098 gnu_size = TYPE_SIZE (gnu_field_type);
3100 /* If the context of the old field is the base type or its
3101 REP part (if any), put the field directly in the new
3102 type; otherwise look up the context in the variant list
3103 and put the field either in the new type if there is a
3104 selected variant or in one of the new variants. */
3105 if (gnu_context == gnu_unpad_base_type
3107 && gnu_context == TREE_TYPE (gnu_rep_part)))
3108 gnu_cont_type = gnu_type;
3111 t = purpose_member (gnu_context, gnu_variant_list);
3114 if (selected_variant)
3115 gnu_cont_type = gnu_type;
3117 gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
3120 /* The front-end may pass us "ghost" components if
3121 it fails to recognize that a constrained subtype
3122 is statically constrained. Discard them. */
3126 /* Now create the new field modeled on the old one. */
3128 = create_field_decl_from (gnu_old_field, gnu_field_type,
3129 gnu_cont_type, gnu_size,
3130 gnu_pos_list, gnu_subst_list);
3132 /* Put it in one of the new variants directly. */
3133 if (gnu_cont_type != gnu_type)
3135 TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3136 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3139 /* To match the layout crafted in components_to_record,
3140 if this is the _Tag or _Parent field, put it before
3141 any other fields. */
3142 else if (gnat_name == Name_uTag
3143 || gnat_name == Name_uParent)
3144 gnu_field_list = chainon (gnu_field_list, gnu_field);
3146 /* Similarly, if this is the _Controller field, put
3147 it before the other fields except for the _Tag or
3149 else if (gnat_name == Name_uController && gnu_last)
3151 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
3152 TREE_CHAIN (gnu_last) = gnu_field;
3155 /* Otherwise, if this is a regular field, put it after
3156 the other fields. */
3159 TREE_CHAIN (gnu_field) = gnu_field_list;
3160 gnu_field_list = gnu_field;
3162 gnu_last = gnu_field;
3165 save_gnu_tree (gnat_field, gnu_field, false);
3168 /* If there is a variant list and no selected variant, we need
3169 to create the nest of variant parts from the old nest. */
3170 if (gnu_variant_list && !selected_variant)
3172 tree new_variant_part
3173 = create_variant_part_from (gnu_variant_part,
3174 gnu_variant_list, gnu_type,
3175 gnu_pos_list, gnu_subst_list);
3176 TREE_CHAIN (new_variant_part) = gnu_field_list;
3177 gnu_field_list = new_variant_part;
3180 /* Now go through the entities again looking for Itypes that
3181 we have not elaborated but should (e.g., Etypes of fields
3182 that have Original_Components). */
3183 for (gnat_field = First_Entity (gnat_entity);
3184 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3185 if ((Ekind (gnat_field) == E_Discriminant
3186 || Ekind (gnat_field) == E_Component)
3187 && !present_gnu_tree (Etype (gnat_field)))
3188 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3190 /* Do not finalize it since we're going to modify it below. */
3191 gnu_field_list = nreverse (gnu_field_list);
3192 finish_record_type (gnu_type, gnu_field_list, 2, true);
3194 /* See the E_Record_Type case for the rationale. */
3195 if (Is_Tagged_Type (gnat_entity)
3196 || Is_Limited_Record (gnat_entity))
3197 SET_TYPE_MODE (gnu_type, BLKmode);
3199 compute_record_mode (gnu_type);
3201 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3203 /* Fill in locations of fields. */
3204 annotate_rep (gnat_entity, gnu_type);
3206 /* If debugging information is being written for the type, write
3207 a record that shows what we are a subtype of and also make a
3208 variable that indicates our size, if still variable. */
3211 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3212 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3213 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3215 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3216 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3218 TYPE_NAME (gnu_subtype_marker)
3219 = create_concat_name (gnat_entity, "XVS");
3220 finish_record_type (gnu_subtype_marker,
3221 create_field_decl (gnu_unpad_base_name,
3222 build_reference_type
3223 (gnu_unpad_base_type),
3229 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3230 gnu_subtype_marker);
3233 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3234 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3235 create_var_decl (create_concat_name (gnat_entity, "XVZ"),
3236 NULL_TREE, sizetype, gnu_size_unit, false,
3237 false, false, false, NULL, gnat_entity);
3240 /* Now we can finalize it. */
3241 rest_of_record_type_compilation (gnu_type);
3244 /* Otherwise, go down all the components in the new type and make
3245 them equivalent to those in the base type. */
3248 gnu_type = gnu_base_type;
3250 for (gnat_temp = First_Entity (gnat_entity);
3251 Present (gnat_temp);
3252 gnat_temp = Next_Entity (gnat_temp))
3253 if ((Ekind (gnat_temp) == E_Discriminant
3254 && !Is_Unchecked_Union (gnat_base_type))
3255 || Ekind (gnat_temp) == E_Component)
3256 save_gnu_tree (gnat_temp,
3257 gnat_to_gnu_field_decl
3258 (Original_Record_Component (gnat_temp)),
3264 case E_Access_Subprogram_Type:
3265 /* Use the special descriptor type for dispatch tables if needed,
3266 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3267 Note that we are only required to do so for static tables in
3268 order to be compatible with the C++ ABI, but Ada 2005 allows
3269 to extend library level tagged types at the local level so
3270 we do it in the non-static case as well. */
3271 if (TARGET_VTABLE_USES_DESCRIPTORS
3272 && Is_Dispatch_Table_Entity (gnat_entity))
3274 gnu_type = fdesc_type_node;
3275 gnu_size = TYPE_SIZE (gnu_type);
3279 /* ... fall through ... */
3281 case E_Anonymous_Access_Subprogram_Type:
3282 /* If we are not defining this entity, and we have incomplete
3283 entities being processed above us, make a dummy type and
3284 fill it in later. */
3285 if (!definition && defer_incomplete_level != 0)
3287 struct incomplete *p
3288 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3291 = build_pointer_type
3292 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3293 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3294 !Comes_From_Source (gnat_entity),
3295 debug_info_p, gnat_entity);
3296 this_made_decl = true;
3297 gnu_type = TREE_TYPE (gnu_decl);
3298 save_gnu_tree (gnat_entity, gnu_decl, false);
3301 p->old_type = TREE_TYPE (gnu_type);
3302 p->full_type = Directly_Designated_Type (gnat_entity);
3303 p->next = defer_incomplete_list;
3304 defer_incomplete_list = p;
3308 /* ... fall through ... */
3310 case E_Allocator_Type:
3312 case E_Access_Attribute_Type:
3313 case E_Anonymous_Access_Type:
3314 case E_General_Access_Type:
3316 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3317 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3318 bool is_from_limited_with
3319 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3320 && From_With_Type (gnat_desig_equiv));
3322 /* Get the "full view" of this entity. If this is an incomplete
3323 entity from a limited with, treat its non-limited view as the full
3324 view. Otherwise, if this is an incomplete or private type, use the
3325 full view. In the former case, we might point to a private type,
3326 in which case, we need its full view. Also, we want to look at the
3327 actual type used for the representation, so this takes a total of
3329 Entity_Id gnat_desig_full_direct_first
3330 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3331 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3332 ? Full_View (gnat_desig_equiv) : Empty));
3333 Entity_Id gnat_desig_full_direct
3334 = ((is_from_limited_with
3335 && Present (gnat_desig_full_direct_first)
3336 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3337 ? Full_View (gnat_desig_full_direct_first)
3338 : gnat_desig_full_direct_first);
3339 Entity_Id gnat_desig_full
3340 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3342 /* This the type actually used to represent the designated type,
3343 either gnat_desig_full or gnat_desig_equiv. */
3344 Entity_Id gnat_desig_rep;
3346 /* True if this is a pointer to an unconstrained array. */
3347 bool is_unconstrained_array;
3349 /* We want to know if we'll be seeing the freeze node for any
3350 incomplete type we may be pointing to. */
3352 = (Present (gnat_desig_full)
3353 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3354 : In_Extended_Main_Code_Unit (gnat_desig_type));
3356 /* True if we make a dummy type here. */
3357 bool got_fat_p = false;
3358 /* True if the dummy is a fat pointer. */
3359 bool made_dummy = false;
3360 tree gnu_desig_type = NULL_TREE;
3361 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3363 if (!targetm.valid_pointer_mode (p_mode))
3366 /* If either the designated type or its full view is an unconstrained
3367 array subtype, replace it with the type it's a subtype of. This
3368 avoids problems with multiple copies of unconstrained array types.
3369 Likewise, if the designated type is a subtype of an incomplete
3370 record type, use the parent type to avoid order of elaboration
3371 issues. This can lose some code efficiency, but there is no
3373 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3374 && ! Is_Constrained (gnat_desig_equiv))
3375 gnat_desig_equiv = Etype (gnat_desig_equiv);
3376 if (Present (gnat_desig_full)
3377 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3378 && ! Is_Constrained (gnat_desig_full))
3379 || (Ekind (gnat_desig_full) == E_Record_Subtype
3380 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3381 gnat_desig_full = Etype (gnat_desig_full);
3383 /* Now set the type that actually marks the representation of
3384 the designated type and also flag whether we have a unconstrained
3386 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3387 is_unconstrained_array
3388 = (Is_Array_Type (gnat_desig_rep)
3389 && ! Is_Constrained (gnat_desig_rep));
3391 /* If we are pointing to an incomplete type whose completion is an
3392 unconstrained array, make a fat pointer type. The two types in our
3393 fields will be pointers to dummy nodes and will be replaced in
3394 update_pointer_to. Similarly, if the type itself is a dummy type or
3395 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3396 in case we have any thin pointers to it. */
3397 if (is_unconstrained_array
3398 && (Present (gnat_desig_full)
3399 || (present_gnu_tree (gnat_desig_equiv)
3400 && TYPE_IS_DUMMY_P (TREE_TYPE
3401 (get_gnu_tree (gnat_desig_equiv))))
3402 || (No (gnat_desig_full) && ! in_main_unit
3403 && defer_incomplete_level != 0
3404 && ! present_gnu_tree (gnat_desig_equiv))
3405 || (in_main_unit && is_from_limited_with
3406 && Present (Freeze_Node (gnat_desig_rep)))))
3410 if (present_gnu_tree (gnat_desig_rep))
3411 gnu_old = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3414 gnu_old = make_dummy_type (gnat_desig_rep);
3416 /* Show the dummy we get will be a fat pointer. */
3417 got_fat_p = made_dummy = true;
3420 /* If the call above got something that has a pointer, that
3421 pointer is our type. This could have happened either
3422 because the type was elaborated or because somebody
3423 else executed the code below. */
3424 gnu_type = TYPE_POINTER_TO (gnu_old);
3427 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3428 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3429 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3430 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3433 TYPE_NAME (gnu_template_type)
3434 = create_concat_name (gnat_desig_equiv, "XUB");
3435 TYPE_DUMMY_P (gnu_template_type) = 1;
3437 TYPE_NAME (gnu_array_type)
3438 = create_concat_name (gnat_desig_equiv, "XUA");
3439 TYPE_DUMMY_P (gnu_array_type) = 1;
3441 gnu_type = make_node (RECORD_TYPE);
3442 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3443 TYPE_POINTER_TO (gnu_old) = gnu_type;
3445 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3447 = chainon (chainon (NULL_TREE,
3449 (get_identifier ("P_ARRAY"),
3451 gnu_type, 0, 0, 0, 0)),
3452 create_field_decl (get_identifier ("P_BOUNDS"),
3454 gnu_type, 0, 0, 0, 0));
3456 /* Make sure we can place this into a register. */
3457 TYPE_ALIGN (gnu_type)
3458 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3459 TYPE_FAT_POINTER_P (gnu_type) = 1;
3461 /* Do not finalize this record type since the types of
3462 its fields are incomplete. */
3463 finish_record_type (gnu_type, fields, 0, true);
3465 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3466 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3467 = create_concat_name (gnat_desig_equiv, "XUT");
3468 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3472 /* If we already know what the full type is, use it. */
3473 else if (Present (gnat_desig_full)
3474 && present_gnu_tree (gnat_desig_full))
3475 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3477 /* Get the type of the thing we are to point to and build a pointer
3478 to it. If it is a reference to an incomplete or private type with a
3479 full view that is a record, make a dummy type node and get the
3480 actual type later when we have verified it is safe. */
3481 else if ((! in_main_unit
3482 && ! present_gnu_tree (gnat_desig_equiv)
3483 && Present (gnat_desig_full)
3484 && ! present_gnu_tree (gnat_desig_full)
3485 && Is_Record_Type (gnat_desig_full))
3486 /* Likewise if we are pointing to a record or array and we
3487 are to defer elaborating incomplete types. We do this
3488 since this access type may be the full view of some
3489 private type. Note that the unconstrained array case is
3491 || ((! in_main_unit || imported_p)
3492 && defer_incomplete_level != 0
3493 && ! present_gnu_tree (gnat_desig_equiv)
3494 && ((Is_Record_Type (gnat_desig_rep)
3495 || Is_Array_Type (gnat_desig_rep))))
3496 /* If this is a reference from a limited_with type back to our
3497 main unit and there's a Freeze_Node for it, either we have
3498 already processed the declaration and made the dummy type,
3499 in which case we just reuse the latter, or we have not yet,
3500 in which case we make the dummy type and it will be reused
3501 when the declaration is processed. In both cases, the
3502 pointer eventually created below will be automatically
3503 adjusted when the Freeze_Node is processed. Note that the
3504 unconstrained array case is handled above. */
3505 || (in_main_unit && is_from_limited_with
3506 && Present (Freeze_Node (gnat_desig_rep))))
3508 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3512 /* Otherwise handle the case of a pointer to itself. */
3513 else if (gnat_desig_equiv == gnat_entity)
3516 = build_pointer_type_for_mode (void_type_node, p_mode,
3517 No_Strict_Aliasing (gnat_entity));
3518 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3521 /* If expansion is disabled, the equivalent type of a concurrent
3522 type is absent, so build a dummy pointer type. */
3523 else if (type_annotate_only && No (gnat_desig_equiv))
3524 gnu_type = ptr_void_type_node;
3526 /* Finally, handle the straightforward case where we can just
3527 elaborate our designated type and point to it. */
3529 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3531 /* It is possible that a call to gnat_to_gnu_type above resolved our
3532 type. If so, just return it. */
3533 if (present_gnu_tree (gnat_entity))
3535 maybe_present = true;
3539 /* If we have a GCC type for the designated type, possibly modify it
3540 if we are pointing only to constant objects and then make a pointer
3541 to it. Don't do this for unconstrained arrays. */
3542 if (!gnu_type && gnu_desig_type)
3544 if (Is_Access_Constant (gnat_entity)
3545 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3548 = build_qualified_type
3550 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3552 /* Some extra processing is required if we are building a
3553 pointer to an incomplete type (in the GCC sense). We might
3554 have such a type if we just made a dummy, or directly out
3555 of the call to gnat_to_gnu_type above if we are processing
3556 an access type for a record component designating the
3557 record type itself. */
3558 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3560 /* We must ensure that the pointer to variant we make will
3561 be processed by update_pointer_to when the initial type
3562 is completed. Pretend we made a dummy and let further
3563 processing act as usual. */
3566 /* We must ensure that update_pointer_to will not retrieve
3567 the dummy variant when building a properly qualified
3568 version of the complete type. We take advantage of the
3569 fact that get_qualified_type is requiring TYPE_NAMEs to
3570 match to influence build_qualified_type and then also
3571 update_pointer_to here. */
3572 TYPE_NAME (gnu_desig_type)
3573 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3578 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3579 No_Strict_Aliasing (gnat_entity));
3582 /* If we are not defining this object and we made a dummy pointer,
3583 save our current definition, evaluate the actual type, and replace
3584 the tentative type we made with the actual one. If we are to defer
3585 actually looking up the actual type, make an entry in the
3586 deferred list. If this is from a limited with, we have to defer
3587 to the end of the current spec in two cases: first if the
3588 designated type is in the current unit and second if the access
3590 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3593 = TYPE_IS_FAT_POINTER_P (gnu_type)
3594 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3596 if (esize == POINTER_SIZE
3597 && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
3599 = build_pointer_type
3600 (TYPE_OBJECT_RECORD_TYPE
3601 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3603 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3604 !Comes_From_Source (gnat_entity),
3605 debug_info_p, gnat_entity);
3606 this_made_decl = true;
3607 gnu_type = TREE_TYPE (gnu_decl);
3608 save_gnu_tree (gnat_entity, gnu_decl, false);
3611 if (defer_incomplete_level == 0
3612 && ! (is_from_limited_with
3614 || In_Extended_Main_Code_Unit (gnat_entity))))
3615 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3616 gnat_to_gnu_type (gnat_desig_equiv));
3618 /* Note that the call to gnat_to_gnu_type here might have
3619 updated gnu_old_type directly, in which case it is not a
3620 dummy type any more when we get into update_pointer_to.
3622 This may happen for instance when the designated type is a
3623 record type, because their elaboration starts with an
3624 initial node from make_dummy_type, which may yield the same
3625 node as the one we got.
3627 Besides, variants of this non-dummy type might have been
3628 created along the way. update_pointer_to is expected to
3629 properly take care of those situations. */
3632 struct incomplete *p
3633 = (struct incomplete *) xmalloc (sizeof
3634 (struct incomplete));
3635 struct incomplete **head
3636 = (is_from_limited_with
3638 || In_Extended_Main_Code_Unit (gnat_entity))
3639 ? &defer_limited_with : &defer_incomplete_list);
3641 p->old_type = gnu_old_type;
3642 p->full_type = gnat_desig_equiv;
3650 case E_Access_Protected_Subprogram_Type:
3651 case E_Anonymous_Access_Protected_Subprogram_Type:
3652 if (type_annotate_only && No (gnat_equiv_type))
3653 gnu_type = ptr_void_type_node;
3656 /* The runtime representation is the equivalent type. */
3657 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3658 maybe_present = true;
3661 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3662 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3663 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3664 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3665 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3670 case E_Access_Subtype:
3672 /* We treat this as identical to its base type; any constraint is
3673 meaningful only to the front end.
3675 The designated type must be elaborated as well, if it does
3676 not have its own freeze node. Designated (sub)types created
3677 for constrained components of records with discriminants are
3678 not frozen by the front end and thus not elaborated by gigi,
3679 because their use may appear before the base type is frozen,
3680 and because it is not clear that they are needed anywhere in
3681 Gigi. With the current model, there is no correct place where
3682 they could be elaborated. */
3684 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3685 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3686 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3687 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3688 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3690 /* If we are not defining this entity, and we have incomplete
3691 entities being processed above us, make a dummy type and
3692 elaborate it later. */
3693 if (!definition && defer_incomplete_level != 0)
3695 struct incomplete *p
3696 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3698 = build_pointer_type
3699 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3701 p->old_type = TREE_TYPE (gnu_ptr_type);
3702 p->full_type = Directly_Designated_Type (gnat_entity);
3703 p->next = defer_incomplete_list;
3704 defer_incomplete_list = p;
3706 else if (!IN (Ekind (Base_Type
3707 (Directly_Designated_Type (gnat_entity))),
3708 Incomplete_Or_Private_Kind))
3709 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3713 maybe_present = true;
3716 /* Subprogram Entities
3718 The following access functions are defined for subprograms (functions
3721 First_Formal The first formal parameter.
3722 Is_Imported Indicates that the subprogram has appeared in
3723 an INTERFACE or IMPORT pragma. For now we
3724 assume that the external language is C.
3725 Is_Exported Likewise but for an EXPORT pragma.
3726 Is_Inlined True if the subprogram is to be inlined.
3728 In addition for function subprograms we have:
3730 Etype Return type of the function.
3732 Each parameter is first checked by calling must_pass_by_ref on its
3733 type to determine if it is passed by reference. For parameters which
3734 are copied in, if they are Ada In Out or Out parameters, their return
3735 value becomes part of a record which becomes the return type of the
3736 function (C function - note that this applies only to Ada procedures
3737 so there is no Ada return type). Additional code to store back the
3738 parameters will be generated on the caller side. This transformation
3739 is done here, not in the front-end.
3741 The intended result of the transformation can be seen from the
3742 equivalent source rewritings that follow:
3744 struct temp {int a,b};
3745 procedure P (A,B: In Out ...) is temp P (int A,B)
3748 end P; return {A,B};
3755 For subprogram types we need to perform mainly the same conversions to
3756 GCC form that are needed for procedures and function declarations. The
3757 only difference is that at the end, we make a type declaration instead
3758 of a function declaration. */
3760 case E_Subprogram_Type:
3764 /* The first GCC parameter declaration (a PARM_DECL node). The
3765 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3766 actually is the head of this parameter list. */
3767 tree gnu_param_list = NULL_TREE;
3768 /* Likewise for the stub associated with an exported procedure. */
3769 tree gnu_stub_param_list = NULL_TREE;
3770 /* The type returned by a function. If the subprogram is a procedure
3771 this type should be void_type_node. */
3772 tree gnu_return_type = void_type_node;
3773 /* List of fields in return type of procedure with copy-in copy-out
3775 tree gnu_field_list = NULL_TREE;
3776 /* Non-null for subprograms containing parameters passed by copy-in
3777 copy-out (Ada In Out or Out parameters not passed by reference),
3778 in which case it is the list of nodes used to specify the values of
3779 the in out/out parameters that are returned as a record upon
3780 procedure return. The TREE_PURPOSE of an element of this list is
3781 a field of the record and the TREE_VALUE is the PARM_DECL
3782 corresponding to that field. This list will be saved in the
3783 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3784 tree gnu_return_list = NULL_TREE;
3785 /* If an import pragma asks to map this subprogram to a GCC builtin,
3786 this is the builtin DECL node. */
3787 tree gnu_builtin_decl = NULL_TREE;
3788 /* For the stub associated with an exported procedure. */
3789 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3790 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3791 Entity_Id gnat_param;
3792 bool inline_flag = Is_Inlined (gnat_entity);
3793 bool public_flag = Is_Public (gnat_entity) || imported_p;
3795 = (Is_Public (gnat_entity) && !definition) || imported_p;
3797 /* The semantics of "pure" in Ada essentially matches that of "const"
3798 in the back-end. In particular, both properties are orthogonal to
3799 the "nothrow" property if the EH circuitry is explicit in the
3800 internal representation of the back-end. If we are to completely
3801 hide the EH circuitry from it, we need to declare that calls to pure
3802 Ada subprograms that can throw have side effects since they can
3803 trigger an "abnormal" transfer of control flow; thus they can be
3804 neither "const" nor "pure" in the back-end sense. */
3806 = (Exception_Mechanism == Back_End_Exceptions
3807 && Is_Pure (gnat_entity));
3809 bool volatile_flag = No_Return (gnat_entity);
3810 bool returns_by_ref = false;
3811 bool returns_unconstrained = false;
3812 bool returns_by_target_ptr = false;
3813 bool has_copy_in_out = false;
3814 bool has_stub = false;
3817 /* A parameter may refer to this type, so defer completion of any
3818 incomplete types. */
3819 if (kind == E_Subprogram_Type && !definition)
3821 defer_incomplete_level++;
3822 this_deferred = true;
3825 /* If the subprogram has an alias, it is probably inherited, so
3826 we can use the original one. If the original "subprogram"
3827 is actually an enumeration literal, it may be the first use
3828 of its type, so we must elaborate that type now. */
3829 if (Present (Alias (gnat_entity)))
3831 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3832 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3834 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3837 /* Elaborate any Itypes in the parameters of this entity. */
3838 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3839 Present (gnat_temp);
3840 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3841 if (Is_Itype (Etype (gnat_temp)))
3842 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3847 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3848 corresponding DECL node.
3850 We still want the parameter associations to take place because the
3851 proper generation of calls depends on it (a GNAT parameter without
3852 a corresponding GCC tree has a very specific meaning), so we don't
3854 if (Convention (gnat_entity) == Convention_Intrinsic)
3855 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3857 /* ??? What if we don't find the builtin node above ? warn ? err ?
3858 In the current state we neither warn nor err, and calls will just
3859 be handled as for regular subprograms. */
3861 if (kind == E_Function || kind == E_Subprogram_Type)
3862 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3864 /* If this function returns by reference, make the actual
3865 return type of this function the pointer and mark the decl. */
3866 if (Returns_By_Ref (gnat_entity))
3868 returns_by_ref = true;
3869 gnu_return_type = build_pointer_type (gnu_return_type);
3872 /* If the Mechanism is By_Reference, ensure the return type uses
3873 the machine's by-reference mechanism, which may not the same
3874 as above (e.g., it might be by passing a fake parameter). */
3875 else if (kind == E_Function
3876 && Mechanism (gnat_entity) == By_Reference)
3878 TREE_ADDRESSABLE (gnu_return_type) = 1;
3880 /* We expect this bit to be reset by gigi shortly, so can avoid a
3881 type node copy here. This actually also prevents troubles with
3882 the generation of debug information for the function, because
3883 we might have issued such info for this type already, and would
3884 be attaching a distinct type node to the function if we made a
3888 /* If we are supposed to return an unconstrained array,
3889 actually return a fat pointer and make a note of that. Return
3890 a pointer to an unconstrained record of variable size. */
3891 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3893 gnu_return_type = TREE_TYPE (gnu_return_type);
3894 returns_unconstrained = true;
3897 /* If the type requires a transient scope, the result is allocated
3898 on the secondary stack, so the result type of the function is
3900 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3902 gnu_return_type = build_pointer_type (gnu_return_type);
3903 returns_unconstrained = true;
3906 /* If the type is a padded type and the underlying type would not
3907 be passed by reference or this function has a foreign convention,
3908 return the underlying type. */
3909 else if (TYPE_IS_PADDING_P (gnu_return_type)
3910 && (!default_pass_by_ref (TREE_TYPE
3911 (TYPE_FIELDS (gnu_return_type)))
3912 || Has_Foreign_Convention (gnat_entity)))
3913 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3915 /* If the return type has a non-constant size, we convert the function
3916 into a procedure and its caller will pass a pointer to an object as
3917 the first parameter when we call the function. This can happen for
3918 an unconstrained type with a maximum size or a constrained type with
3919 a size not known at compile time. */
3920 if (TYPE_SIZE_UNIT (gnu_return_type)
3921 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3923 returns_by_target_ptr = true;
3925 = create_param_decl (get_identifier ("TARGET"),
3926 build_reference_type (gnu_return_type),
3928 gnu_return_type = void_type_node;
3931 /* If the return type has a size that overflows, we cannot have
3932 a function that returns that type. This usage doesn't make
3933 sense anyway, so give an error here. */
3934 if (TYPE_SIZE_UNIT (gnu_return_type)
3935 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3936 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3938 post_error ("cannot return type whose size overflows",
3940 gnu_return_type = copy_node (gnu_return_type);
3941 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3942 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3943 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3944 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3947 /* Look at all our parameters and get the type of
3948 each. While doing this, build a copy-out structure if
3951 /* Loop over the parameters and get their associated GCC tree.
3952 While doing this, build a copy-out structure if we need one. */
3953 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3954 Present (gnat_param);
3955 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3957 tree gnu_param_name = get_entity_name (gnat_param);
3958 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3959 tree gnu_param, gnu_field;
3960 bool copy_in_copy_out = false;
3961 Mechanism_Type mech = Mechanism (gnat_param);
3963 /* Builtins are expanded inline and there is no real call sequence
3964 involved. So the type expected by the underlying expander is
3965 always the type of each argument "as is". */
3966 if (gnu_builtin_decl)
3968 /* Handle the first parameter of a valued procedure specially. */
3969 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3970 mech = By_Copy_Return;
3971 /* Otherwise, see if a Mechanism was supplied that forced this
3972 parameter to be passed one way or another. */
3973 else if (mech == Default
3974 || mech == By_Copy || mech == By_Reference)
3976 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3977 mech = By_Descriptor;
3979 else if (By_Short_Descriptor_Last <= mech &&
3980 mech <= By_Short_Descriptor)
3981 mech = By_Short_Descriptor;
3985 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3986 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3987 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3989 mech = By_Reference;
3995 post_error ("unsupported mechanism for&", gnat_param);
4000 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4001 Has_Foreign_Convention (gnat_entity),
4004 /* We are returned either a PARM_DECL or a type if no parameter
4005 needs to be passed; in either case, adjust the type. */
4006 if (DECL_P (gnu_param))
4007 gnu_param_type = TREE_TYPE (gnu_param);
4010 gnu_param_type = gnu_param;
4011 gnu_param = NULL_TREE;
4016 /* If it's an exported subprogram, we build a parameter list
4017 in parallel, in case we need to emit a stub for it. */
4018 if (Is_Exported (gnat_entity))
4021 = chainon (gnu_param, gnu_stub_param_list);
4022 /* Change By_Descriptor parameter to By_Reference for
4023 the internal version of an exported subprogram. */
4024 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4027 = gnat_to_gnu_param (gnat_param, By_Reference,
4033 gnu_param = copy_node (gnu_param);
4036 gnu_param_list = chainon (gnu_param, gnu_param_list);
4037 Sloc_to_locus (Sloc (gnat_param),
4038 &DECL_SOURCE_LOCATION (gnu_param));
4039 save_gnu_tree (gnat_param, gnu_param, false);
4041 /* If a parameter is a pointer, this function may modify
4042 memory through it and thus shouldn't be considered
4043 a const function. Also, the memory may be modified
4044 between two calls, so they can't be CSE'ed. The latter
4045 case also handles by-ref parameters. */
4046 if (POINTER_TYPE_P (gnu_param_type)
4047 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4051 if (copy_in_copy_out)
4053 if (!has_copy_in_out)
4055 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
4056 gnu_return_type = make_node (RECORD_TYPE);
4057 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4058 has_copy_in_out = true;
4061 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
4062 gnu_return_type, 0, 0, 0, 0);
4063 Sloc_to_locus (Sloc (gnat_param),
4064 &DECL_SOURCE_LOCATION (gnu_field));
4065 TREE_CHAIN (gnu_field) = gnu_field_list;
4066 gnu_field_list = gnu_field;
4067 gnu_return_list = tree_cons (gnu_field, gnu_param,
4072 /* Do not compute record for out parameters if subprogram is
4073 stubbed since structures are incomplete for the back-end. */
4074 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
4075 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4078 /* If we have a CICO list but it has only one entry, we convert
4079 this function into a function that simply returns that one
4081 if (list_length (gnu_return_list) == 1)
4082 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
4084 if (Has_Stdcall_Convention (gnat_entity))
4085 prepend_one_attribute_to
4086 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4087 get_identifier ("stdcall"), NULL_TREE,
4090 /* If we are on a target where stack realignment is needed for 'main'
4091 to honor GCC's implicit expectations (stack alignment greater than
4092 what the base ABI guarantees), ensure we do the same for foreign
4093 convention subprograms as they might be used as callbacks from code
4094 breaking such expectations. Note that this applies to task entry
4095 points in particular. */
4096 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4097 && Has_Foreign_Convention (gnat_entity))
4098 prepend_one_attribute_to
4099 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4100 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4103 /* The lists have been built in reverse. */
4104 gnu_param_list = nreverse (gnu_param_list);
4106 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4107 gnu_return_list = nreverse (gnu_return_list);
4109 if (Ekind (gnat_entity) == E_Function)
4110 Set_Mechanism (gnat_entity,
4111 (returns_by_ref || returns_unconstrained
4112 ? By_Reference : By_Copy));
4114 = create_subprog_type (gnu_return_type, gnu_param_list,
4115 gnu_return_list, returns_unconstrained,
4116 returns_by_ref, returns_by_target_ptr);
4120 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4121 gnu_return_list, returns_unconstrained,
4122 returns_by_ref, returns_by_target_ptr);
4124 /* A subprogram (something that doesn't return anything) shouldn't
4125 be considered const since there would be no reason for such a
4126 subprogram. Note that procedures with Out (or In Out) parameters
4127 have already been converted into a function with a return type. */
4128 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4132 = build_qualified_type (gnu_type,
4133 TYPE_QUALS (gnu_type)
4134 | (TYPE_QUAL_CONST * const_flag)
4135 | (TYPE_QUAL_VOLATILE * volatile_flag));
4137 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4141 = build_qualified_type (gnu_stub_type,
4142 TYPE_QUALS (gnu_stub_type)
4143 | (TYPE_QUAL_CONST * const_flag)
4144 | (TYPE_QUAL_VOLATILE * volatile_flag));
4146 /* If we have a builtin decl for that function, check the signatures
4147 compatibilities. If the signatures are compatible, use the builtin
4148 decl. If they are not, we expect the checker predicate to have
4149 posted the appropriate errors, and just continue with what we have
4151 if (gnu_builtin_decl)
4153 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4155 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4157 gnu_decl = gnu_builtin_decl;
4158 gnu_type = gnu_builtin_type;
4163 /* If there was no specified Interface_Name and the external and
4164 internal names of the subprogram are the same, only use the
4165 internal name to allow disambiguation of nested subprograms. */
4166 if (No (Interface_Name (gnat_entity))
4167 && gnu_ext_name == gnu_entity_name)
4168 gnu_ext_name = NULL_TREE;
4170 /* If we are defining the subprogram and it has an Address clause
4171 we must get the address expression from the saved GCC tree for the
4172 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4173 the address expression here since the front-end has guaranteed
4174 in that case that the elaboration has no effects. If there is
4175 an Address clause and we are not defining the object, just
4176 make it a constant. */
4177 if (Present (Address_Clause (gnat_entity)))
4179 tree gnu_address = NULL_TREE;
4183 = (present_gnu_tree (gnat_entity)
4184 ? get_gnu_tree (gnat_entity)
4185 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4187 save_gnu_tree (gnat_entity, NULL_TREE, false);
4189 /* Convert the type of the object to a reference type that can
4190 alias everything as per 13.3(19). */
4192 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4194 gnu_address = convert (gnu_type, gnu_address);
4197 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4198 gnu_address, false, Is_Public (gnat_entity),
4199 extern_flag, false, NULL, gnat_entity);
4200 DECL_BY_REF_P (gnu_decl) = 1;
4203 else if (kind == E_Subprogram_Type)
4204 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4205 !Comes_From_Source (gnat_entity),
4206 debug_info_p, gnat_entity);
4211 gnu_stub_name = gnu_ext_name;
4212 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4213 public_flag = false;
4216 gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4217 gnu_type, gnu_param_list,
4218 inline_flag, public_flag,
4219 extern_flag, attr_list,
4224 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4225 gnu_stub_type, gnu_stub_param_list,
4227 extern_flag, attr_list,
4229 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4232 /* This is unrelated to the stub built right above. */
4233 DECL_STUBBED_P (gnu_decl)
4234 = Convention (gnat_entity) == Convention_Stubbed;
4239 case E_Incomplete_Type:
4240 case E_Incomplete_Subtype:
4241 case E_Private_Type:
4242 case E_Private_Subtype:
4243 case E_Limited_Private_Type:
4244 case E_Limited_Private_Subtype:
4245 case E_Record_Type_With_Private:
4246 case E_Record_Subtype_With_Private:
4248 /* Get the "full view" of this entity. If this is an incomplete
4249 entity from a limited with, treat its non-limited view as the
4250 full view. Otherwise, use either the full view or the underlying
4251 full view, whichever is present. This is used in all the tests
4254 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4255 && From_With_Type (gnat_entity))
4256 ? Non_Limited_View (gnat_entity)
4257 : Present (Full_View (gnat_entity))
4258 ? Full_View (gnat_entity)
4259 : Underlying_Full_View (gnat_entity);
4261 /* If this is an incomplete type with no full view, it must be a Taft
4262 Amendment type, in which case we return a dummy type. Otherwise,
4263 just get the type from its Etype. */
4266 if (kind == E_Incomplete_Type)
4268 gnu_type = make_dummy_type (gnat_entity);
4269 gnu_decl = TYPE_STUB_DECL (gnu_type);
4273 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4275 maybe_present = true;
4280 /* If we already made a type for the full view, reuse it. */
4281 else if (present_gnu_tree (full_view))
4283 gnu_decl = get_gnu_tree (full_view);
4287 /* Otherwise, if we are not defining the type now, get the type
4288 from the full view. But always get the type from the full view
4289 for define on use types, since otherwise we won't see them! */
4290 else if (!definition
4291 || (Is_Itype (full_view)
4292 && No (Freeze_Node (gnat_entity)))
4293 || (Is_Itype (gnat_entity)
4294 && No (Freeze_Node (full_view))))
4296 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4297 maybe_present = true;
4301 /* For incomplete types, make a dummy type entry which will be
4302 replaced later. Save it as the full declaration's type so
4303 we can do any needed updates when we see it. */
4304 gnu_type = make_dummy_type (gnat_entity);
4305 gnu_decl = TYPE_STUB_DECL (gnu_type);
4306 save_gnu_tree (full_view, gnu_decl, 0);
4310 /* Simple class_wide types are always viewed as their root_type
4311 by Gigi unless an Equivalent_Type is specified. */
4312 case E_Class_Wide_Type:
4313 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4314 maybe_present = true;
4318 case E_Task_Subtype:
4319 case E_Protected_Type:
4320 case E_Protected_Subtype:
4321 if (type_annotate_only && No (gnat_equiv_type))
4322 gnu_type = void_type_node;
4324 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4326 maybe_present = true;
4330 gnu_decl = create_label_decl (gnu_entity_name);
4335 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4336 we've already saved it, so we don't try to. */
4337 gnu_decl = error_mark_node;
4345 /* If we had a case where we evaluated another type and it might have
4346 defined this one, handle it here. */
4347 if (maybe_present && present_gnu_tree (gnat_entity))
4349 gnu_decl = get_gnu_tree (gnat_entity);
4353 /* If we are processing a type and there is either no decl for it or
4354 we just made one, do some common processing for the type, such as
4355 handling alignment and possible padding. */
4356 if (is_type && (!gnu_decl || this_made_decl))
4358 if (Is_Tagged_Type (gnat_entity)
4359 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4360 TYPE_ALIGN_OK (gnu_type) = 1;
4362 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4363 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4365 /* ??? Don't set the size for a String_Literal since it is either
4366 confirming or we don't handle it properly (if the low bound is
4368 if (!gnu_size && kind != E_String_Literal_Subtype)
4369 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4371 Has_Size_Clause (gnat_entity));
4373 /* If a size was specified, see if we can make a new type of that size
4374 by rearranging the type, for example from a fat to a thin pointer. */
4378 = make_type_from_size (gnu_type, gnu_size,
4379 Has_Biased_Representation (gnat_entity));
4381 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4382 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4386 /* If the alignment hasn't already been processed and this is
4387 not an unconstrained array, see if an alignment is specified.
4388 If not, we pick a default alignment for atomic objects. */
4389 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4391 else if (Known_Alignment (gnat_entity))
4393 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4394 TYPE_ALIGN (gnu_type));
4396 /* Warn on suspiciously large alignments. This should catch
4397 errors about the (alignment,byte)/(size,bit) discrepancy. */
4398 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4402 /* If a size was specified, take it into account. Otherwise
4403 use the RM size for records as the type size has already
4404 been adjusted to the alignment. */
4407 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4408 || TREE_CODE (gnu_type) == UNION_TYPE
4409 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4410 && !TYPE_FAT_POINTER_P (gnu_type))
4411 size = rm_size (gnu_type);
4413 size = TYPE_SIZE (gnu_type);
4415 /* Consider an alignment as suspicious if the alignment/size
4416 ratio is greater or equal to the byte/bit ratio. */
4417 if (host_integerp (size, 1)
4418 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4419 post_error_ne ("?suspiciously large alignment specified for&",
4420 Expression (Alignment_Clause (gnat_entity)),
4424 else if (Is_Atomic (gnat_entity) && !gnu_size
4425 && host_integerp (TYPE_SIZE (gnu_type), 1)
4426 && integer_pow2p (TYPE_SIZE (gnu_type)))
4427 align = MIN (BIGGEST_ALIGNMENT,
4428 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4429 else if (Is_Atomic (gnat_entity) && gnu_size
4430 && host_integerp (gnu_size, 1)
4431 && integer_pow2p (gnu_size))
4432 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4434 /* See if we need to pad the type. If we did, and made a record,
4435 the name of the new type may be changed. So get it back for
4436 us when we make the new TYPE_DECL below. */
4437 if (gnu_size || align > 0)
4438 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4439 false, !gnu_decl, definition, false);
4441 if (TYPE_IS_PADDING_P (gnu_type))
4443 gnu_entity_name = TYPE_NAME (gnu_type);
4444 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4445 gnu_entity_name = DECL_NAME (gnu_entity_name);
4448 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4450 /* If we are at global level, GCC will have applied variable_size to
4451 the type, but that won't have done anything. So, if it's not
4452 a constant or self-referential, call elaborate_expression_1 to
4453 make a variable for the size rather than calculating it each time.
4454 Handle both the RM size and the actual size. */
4455 if (global_bindings_p ()
4456 && TYPE_SIZE (gnu_type)
4457 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4458 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4460 if (TREE_CODE (gnu_type) == RECORD_TYPE
4461 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4462 TYPE_SIZE (gnu_type), 0))
4464 TYPE_SIZE (gnu_type)
4465 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4466 gnat_entity, get_identifier ("SIZE"),
4468 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4472 TYPE_SIZE (gnu_type)
4473 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4474 gnat_entity, get_identifier ("SIZE"),
4477 /* ??? For now, store the size as a multiple of the alignment
4478 in bytes so that we can see the alignment from the tree. */
4479 TYPE_SIZE_UNIT (gnu_type)
4481 (MULT_EXPR, sizetype,
4482 elaborate_expression_1
4483 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4484 TYPE_SIZE_UNIT (gnu_type),
4485 size_int (TYPE_ALIGN (gnu_type)
4487 gnat_entity, get_identifier ("SIZE_A_UNIT"),
4489 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4491 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4494 elaborate_expression_1 (TYPE_ADA_SIZE (gnu_type),
4496 get_identifier ("RM_SIZE"),
4497 definition, false));
4501 /* If this is a record type or subtype, call elaborate_expression_1 on
4502 any field position. Do this for both global and local types.
4503 Skip any fields that we haven't made trees for to avoid problems with
4504 class wide types. */
4505 if (IN (kind, Record_Kind))
4506 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4507 gnat_temp = Next_Entity (gnat_temp))
4508 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4510 tree gnu_field = get_gnu_tree (gnat_temp);
4512 /* ??? Unfortunately, GCC needs to be able to prove the
4513 alignment of this offset and if it's a variable, it can't.
4514 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4515 right now, we have to put in an explicit multiply and
4516 divide by that value. */
4517 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4519 DECL_FIELD_OFFSET (gnu_field)
4521 (MULT_EXPR, sizetype,
4522 elaborate_expression_1
4523 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4524 DECL_FIELD_OFFSET (gnu_field),
4525 size_int (DECL_OFFSET_ALIGN (gnu_field)
4527 gnat_temp, get_identifier ("OFFSET"),
4529 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4531 /* ??? The context of gnu_field is not necessarily gnu_type so
4532 the MULT_EXPR node built above may not be marked by the call
4533 to create_type_decl below. */
4534 if (global_bindings_p ())
4535 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4539 if (Treat_As_Volatile (gnat_entity))
4541 = build_qualified_type (gnu_type,
4542 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4544 if (Is_Atomic (gnat_entity))
4545 check_ok_for_atomic (gnu_type, gnat_entity, false);
4547 if (Present (Alignment_Clause (gnat_entity)))
4548 TYPE_USER_ALIGN (gnu_type) = 1;
4550 if (Universal_Aliasing (gnat_entity))
4551 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4554 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4555 !Comes_From_Source (gnat_entity),
4556 debug_info_p, gnat_entity);
4559 TREE_TYPE (gnu_decl) = gnu_type;
4560 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4564 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4566 gnu_type = TREE_TYPE (gnu_decl);
4568 /* If this is a derived type, relate its alias set to that of its parent
4569 to avoid troubles when a call to an inherited primitive is inlined in
4570 a context where a derived object is accessed. The inlined code works
4571 on the parent view so the resulting code may access the same object
4572 using both the parent and the derived alias sets, which thus have to
4573 conflict. As the same issue arises with component references, the
4574 parent alias set also has to conflict with composite types enclosing
4575 derived components. For instance, if we have:
4582 we want T to conflict with both D and R, in addition to R being a
4583 superset of D by record/component construction.
4585 One way to achieve this is to perform an alias set copy from the
4586 parent to the derived type. This is not quite appropriate, though,
4587 as we don't want separate derived types to conflict with each other:
4589 type I1 is new Integer;
4590 type I2 is new Integer;
4592 We want I1 and I2 to both conflict with Integer but we do not want
4593 I1 to conflict with I2, and an alias set copy on derivation would
4596 The option chosen is to make the alias set of the derived type a
4597 superset of that of its parent type. It trivially fulfills the
4598 simple requirement for the Integer derivation example above, and
4599 the component case as well by superset transitivity:
4602 R ----------> D ----------> T
4604 The language rules ensure the parent type is already frozen here. */
4605 if (Is_Derived_Type (gnat_entity))
4607 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4608 relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET);
4611 /* Back-annotate the Alignment of the type if not already in the
4612 tree. Likewise for sizes. */
4613 if (Unknown_Alignment (gnat_entity))
4615 unsigned int double_align, align;
4616 bool is_capped_double, align_clause;
4618 /* If the default alignment of "double" or larger scalar types is
4619 specifically capped and this is not an array with an alignment
4620 clause on the component type, return the cap. */
4621 if ((double_align = double_float_alignment) > 0)
4623 = is_double_float_or_array (gnat_entity, &align_clause);
4624 else if ((double_align = double_scalar_alignment) > 0)
4626 = is_double_scalar_or_array (gnat_entity, &align_clause);
4628 is_capped_double = align_clause = false;
4630 if (is_capped_double && !align_clause)
4631 align = double_align;
4633 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4635 Set_Alignment (gnat_entity, UI_From_Int (align));
4638 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4640 /* If the size is self-referential, we annotate the maximum
4641 value of that size. */
4642 tree gnu_size = TYPE_SIZE (gnu_type);
4644 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4645 gnu_size = max_size (gnu_size, true);
4647 Set_Esize (gnat_entity, annotate_value (gnu_size));
4649 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4651 /* In this mode the tag and the parent components are not
4652 generated by the front-end, so the sizes must be adjusted
4654 int size_offset, new_size;
4656 if (Is_Derived_Type (gnat_entity))
4659 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4660 Set_Alignment (gnat_entity,
4661 Alignment (Etype (Base_Type (gnat_entity))));
4664 size_offset = POINTER_SIZE;
4666 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4667 Set_Esize (gnat_entity,
4668 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4669 / POINTER_SIZE) * POINTER_SIZE));
4670 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4674 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4675 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4678 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4679 DECL_ARTIFICIAL (gnu_decl) = 1;
4681 if (!debug_info_p && DECL_P (gnu_decl)
4682 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4683 && No (Renamed_Object (gnat_entity)))
4684 DECL_IGNORED_P (gnu_decl) = 1;
4686 /* If we haven't already, associate the ..._DECL node that we just made with
4687 the input GNAT entity node. */
4689 save_gnu_tree (gnat_entity, gnu_decl, false);
4691 /* If this is an enumeration or floating-point type, we were not able to set
4692 the bounds since they refer to the type. These are always static. */
4693 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4694 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4696 tree gnu_scalar_type = gnu_type;
4697 tree gnu_low_bound, gnu_high_bound;
4699 /* If this is a padded type, we need to use the underlying type. */
4700 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4701 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4703 /* If this is a floating point type and we haven't set a floating
4704 point type yet, use this in the evaluation of the bounds. */
4705 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4706 longest_float_type_node = gnu_scalar_type;
4708 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4709 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4711 if (kind == E_Enumeration_Type)
4713 /* Enumeration types have specific RM bounds. */
4714 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4715 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4717 /* Write full debugging information. Since this has both a
4718 typedef and a tag, avoid outputting the name twice. */
4719 DECL_ARTIFICIAL (gnu_decl) = 1;
4720 rest_of_type_decl_compilation (gnu_decl);
4725 /* Floating-point types don't have specific RM bounds. */
4726 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4727 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4731 /* If we deferred processing of incomplete types, re-enable it. If there
4732 were no other disables and we have some to process, do so. */
4733 if (this_deferred && --defer_incomplete_level == 0)
4735 if (defer_incomplete_list)
4737 struct incomplete *incp, *next;
4739 /* We are back to level 0 for the deferring of incomplete types.
4740 But processing these incomplete types below may itself require
4741 deferring, so preserve what we have and restart from scratch. */
4742 incp = defer_incomplete_list;
4743 defer_incomplete_list = NULL;
4745 /* For finalization, however, all types must be complete so we
4746 cannot do the same because deferred incomplete types may end up
4747 referencing each other. Process them all recursively first. */
4748 defer_finalize_level++;
4750 for (; incp; incp = next)
4755 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4756 gnat_to_gnu_type (incp->full_type));
4760 defer_finalize_level--;
4763 /* All the deferred incomplete types have been processed so we can
4764 now proceed with the finalization of the deferred types. */
4765 if (defer_finalize_level == 0 && defer_finalize_list)
4770 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4771 rest_of_type_decl_compilation_no_defer (t);
4773 VEC_free (tree, heap, defer_finalize_list);
4777 /* If we are not defining this type, see if it's in the incomplete list.
4778 If so, handle that list entry now. */
4779 else if (!definition)
4781 struct incomplete *incp;
4783 for (incp = defer_incomplete_list; incp; incp = incp->next)
4784 if (incp->old_type && incp->full_type == gnat_entity)
4786 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4787 TREE_TYPE (gnu_decl));
4788 incp->old_type = NULL_TREE;
4795 /* If this is a packed array type whose original array type is itself
4796 an Itype without freeze node, make sure the latter is processed. */
4797 if (Is_Packed_Array_Type (gnat_entity)
4798 && Is_Itype (Original_Array_Type (gnat_entity))
4799 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4800 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4801 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
4806 /* Similar, but if the returned value is a COMPONENT_REF, return the
4810 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4812 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4814 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4815 gnu_field = TREE_OPERAND (gnu_field, 1);
4820 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4821 the GCC type corresponding to that entity. */
4824 gnat_to_gnu_type (Entity_Id gnat_entity)
4828 /* The back end never attempts to annotate generic types. */
4829 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4830 return void_type_node;
4832 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4833 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4835 return TREE_TYPE (gnu_decl);
4838 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4839 the unpadded version of the GCC type corresponding to that entity. */
4842 get_unpadded_type (Entity_Id gnat_entity)
4844 tree type = gnat_to_gnu_type (gnat_entity);
4846 if (TYPE_IS_PADDING_P (type))
4847 type = TREE_TYPE (TYPE_FIELDS (type));
4852 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4853 Every TYPE_DECL generated for a type definition must be passed
4854 to this function once everything else has been done for it. */
4857 rest_of_type_decl_compilation (tree decl)
4859 /* We need to defer finalizing the type if incomplete types
4860 are being deferred or if they are being processed. */
4861 if (defer_incomplete_level || defer_finalize_level)
4862 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4864 rest_of_type_decl_compilation_no_defer (decl);
4867 /* Same as above but without deferring the compilation. This
4868 function should not be invoked directly on a TYPE_DECL. */
4871 rest_of_type_decl_compilation_no_defer (tree decl)
4873 const int toplev = global_bindings_p ();
4874 tree t = TREE_TYPE (decl);
4876 rest_of_decl_compilation (decl, toplev, 0);
4878 /* Now process all the variants. This is needed for STABS. */
4879 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4881 if (t == TREE_TYPE (decl))
4884 if (!TYPE_STUB_DECL (t))
4885 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
4887 rest_of_type_compilation (t, toplev);
4891 /* Finalize any From_With_Type incomplete types. We do this after processing
4892 our compilation unit and after processing its spec, if this is a body. */
4895 finalize_from_with_types (void)
4897 struct incomplete *incp = defer_limited_with;
4898 struct incomplete *next;
4900 defer_limited_with = 0;
4901 for (; incp; incp = next)
4905 if (incp->old_type != 0)
4906 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4907 gnat_to_gnu_type (incp->full_type));
4912 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4913 kind of type (such E_Task_Type) that has a different type which Gigi
4914 uses for its representation. If the type does not have a special type
4915 for its representation, return GNAT_ENTITY. If a type is supposed to
4916 exist, but does not, abort unless annotating types, in which case
4917 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4920 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4922 Entity_Id gnat_equiv = gnat_entity;
4924 if (No (gnat_entity))
4927 switch (Ekind (gnat_entity))
4929 case E_Class_Wide_Subtype:
4930 if (Present (Equivalent_Type (gnat_entity)))
4931 gnat_equiv = Equivalent_Type (gnat_entity);
4934 case E_Access_Protected_Subprogram_Type:
4935 case E_Anonymous_Access_Protected_Subprogram_Type:
4936 gnat_equiv = Equivalent_Type (gnat_entity);
4939 case E_Class_Wide_Type:
4940 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4941 ? Equivalent_Type (gnat_entity)
4942 : Root_Type (gnat_entity));
4946 case E_Task_Subtype:
4947 case E_Protected_Type:
4948 case E_Protected_Subtype:
4949 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4956 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4960 /* Return a GCC tree for a type corresponding to the component type of the
4961 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
4962 is for an array being defined. DEBUG_INFO_P is true if we need to write
4963 debug information for other types that we may create in the process. */
4966 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
4969 tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
4972 /* Try to get a smaller form of the component if needed. */
4973 if ((Is_Packed (gnat_array)
4974 || Has_Component_Size_Clause (gnat_array))
4975 && !Is_Bit_Packed_Array (gnat_array)
4976 && !Has_Aliased_Components (gnat_array)
4977 && !Strict_Alignment (Component_Type (gnat_array))
4978 && TREE_CODE (gnu_type) == RECORD_TYPE
4979 && !TYPE_FAT_POINTER_P (gnu_type)
4980 && host_integerp (TYPE_SIZE (gnu_type), 1))
4981 gnu_type = make_packable_type (gnu_type, false);
4983 if (Has_Atomic_Components (gnat_array))
4984 check_ok_for_atomic (gnu_type, gnat_array, true);
4986 /* Get and validate any specified Component_Size. */
4988 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
4989 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
4990 true, Has_Component_Size_Clause (gnat_array));
4992 /* If the array has aliased components and the component size can be zero,
4993 force at least unit size to ensure that the components have distinct
4996 && Has_Aliased_Components (gnat_array)
4997 && (integer_zerop (TYPE_SIZE (gnu_type))
4998 || (TREE_CODE (gnu_type) == ARRAY_TYPE
4999 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5001 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5003 /* If the component type is a RECORD_TYPE that has a self-referential size,
5004 then use the maximum size for the component size. */
5006 && TREE_CODE (gnu_type) == RECORD_TYPE
5007 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5008 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5010 /* Honor the component size. This is not needed for bit-packed arrays. */
5011 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5013 tree orig_type = gnu_type;
5014 unsigned int max_align;
5016 /* If an alignment is specified, use it as a cap on the component type
5017 so that it can be honored for the whole type. But ignore it for the
5018 original type of packed array types. */
5019 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5020 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5024 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5025 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5026 gnu_type = orig_type;
5028 orig_type = gnu_type;
5030 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5031 true, false, definition, true);
5033 /* If a padding record was made, declare it now since it will never be
5034 declared otherwise. This is necessary to ensure that its subtrees
5035 are properly marked. */
5036 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5037 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5038 debug_info_p, gnat_array);
5041 if (Has_Volatile_Components (Base_Type (gnat_array)))
5043 = build_qualified_type (gnu_type,
5044 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5049 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5050 using MECH as its passing mechanism, to be placed in the parameter
5051 list built for GNAT_SUBPROG. Assume a foreign convention for the
5052 latter if FOREIGN is true. Also set CICO to true if the parameter
5053 must use the copy-in copy-out implementation mechanism.
5055 The returned tree is a PARM_DECL, except for those cases where no
5056 parameter needs to be actually passed to the subprogram; the type
5057 of this "shadow" parameter is then returned instead. */
5060 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5061 Entity_Id gnat_subprog, bool foreign, bool *cico)
5063 tree gnu_param_name = get_entity_name (gnat_param);
5064 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5065 tree gnu_param_type_alt = NULL_TREE;
5066 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5067 /* The parameter can be indirectly modified if its address is taken. */
5068 bool ro_param = in_param && !Address_Taken (gnat_param);
5069 bool by_return = false, by_component_ptr = false, by_ref = false;
5072 /* Copy-return is used only for the first parameter of a valued procedure.
5073 It's a copy mechanism for which a parameter is never allocated. */
5074 if (mech == By_Copy_Return)
5076 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5081 /* If this is either a foreign function or if the underlying type won't
5082 be passed by reference, strip off possible padding type. */
5083 if (TYPE_IS_PADDING_P (gnu_param_type))
5085 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5087 if (mech == By_Reference
5089 || (!must_pass_by_ref (unpadded_type)
5090 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5091 gnu_param_type = unpadded_type;
5094 /* If this is a read-only parameter, make a variant of the type that is
5095 read-only. ??? However, if this is an unconstrained array, that type
5096 can be very complex, so skip it for now. Likewise for any other
5097 self-referential type. */
5099 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5100 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5101 gnu_param_type = build_qualified_type (gnu_param_type,
5102 (TYPE_QUALS (gnu_param_type)
5103 | TYPE_QUAL_CONST));
5105 /* For foreign conventions, pass arrays as pointers to the element type.
5106 First check for unconstrained array and get the underlying array. */
5107 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5109 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5111 /* VMS descriptors are themselves passed by reference. */
5112 if (mech == By_Short_Descriptor ||
5113 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5115 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5116 Mechanism (gnat_param),
5118 else if (mech == By_Descriptor)
5120 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5121 chosen in fill_vms_descriptor. */
5123 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5124 Mechanism (gnat_param),
5127 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5128 Mechanism (gnat_param),
5132 /* Arrays are passed as pointers to element type for foreign conventions. */
5135 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5137 /* Strip off any multi-dimensional entries, then strip
5138 off the last array to get the component type. */
5139 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5140 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5141 gnu_param_type = TREE_TYPE (gnu_param_type);
5143 by_component_ptr = true;
5144 gnu_param_type = TREE_TYPE (gnu_param_type);
5147 gnu_param_type = build_qualified_type (gnu_param_type,
5148 (TYPE_QUALS (gnu_param_type)
5149 | TYPE_QUAL_CONST));
5151 gnu_param_type = build_pointer_type (gnu_param_type);
5154 /* Fat pointers are passed as thin pointers for foreign conventions. */
5155 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5157 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5159 /* If we must pass or were requested to pass by reference, do so.
5160 If we were requested to pass by copy, do so.
5161 Otherwise, for foreign conventions, pass In Out or Out parameters
5162 or aggregates by reference. For COBOL and Fortran, pass all
5163 integer and FP types that way too. For Convention Ada, use
5164 the standard Ada default. */
5165 else if (must_pass_by_ref (gnu_param_type)
5166 || mech == By_Reference
5169 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5171 && (Convention (gnat_subprog) == Convention_Fortran
5172 || Convention (gnat_subprog) == Convention_COBOL)
5173 && (INTEGRAL_TYPE_P (gnu_param_type)
5174 || FLOAT_TYPE_P (gnu_param_type)))
5176 && default_pass_by_ref (gnu_param_type)))))
5178 gnu_param_type = build_reference_type (gnu_param_type);
5182 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5186 if (mech == By_Copy && (by_ref || by_component_ptr))
5187 post_error ("?cannot pass & by copy", gnat_param);
5189 /* If this is an Out parameter that isn't passed by reference and isn't
5190 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5191 it will be a VAR_DECL created when we process the procedure, so just
5192 return its type. For the special parameter of a valued procedure,
5195 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5196 Out parameters with discriminants or implicit initial values to be
5197 handled like In Out parameters. These type are normally built as
5198 aggregates, hence passed by reference, except for some packed arrays
5199 which end up encoded in special integer types.
5201 The exception we need to make is then for packed arrays of records
5202 with discriminants or implicit initial values. We have no light/easy
5203 way to check for the latter case, so we merely check for packed arrays
5204 of records. This may lead to useless copy-in operations, but in very
5205 rare cases only, as these would be exceptions in a set of already
5206 exceptional situations. */
5207 if (Ekind (gnat_param) == E_Out_Parameter
5210 || (mech != By_Descriptor
5211 && mech != By_Short_Descriptor
5212 && !POINTER_TYPE_P (gnu_param_type)
5213 && !AGGREGATE_TYPE_P (gnu_param_type)))
5214 && !(Is_Array_Type (Etype (gnat_param))
5215 && Is_Packed (Etype (gnat_param))
5216 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5217 return gnu_param_type;
5219 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5220 ro_param || by_ref || by_component_ptr);
5221 DECL_BY_REF_P (gnu_param) = by_ref;
5222 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5223 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5224 mech == By_Short_Descriptor);
5225 DECL_POINTS_TO_READONLY_P (gnu_param)
5226 = (ro_param && (by_ref || by_component_ptr));
5228 /* Save the alternate descriptor type, if any. */
5229 if (gnu_param_type_alt)
5230 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5232 /* If no Mechanism was specified, indicate what we're using, then
5233 back-annotate it. */
5234 if (mech == Default)
5235 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5237 Set_Mechanism (gnat_param, mech);
5241 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5244 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5246 while (Present (Corresponding_Discriminant (discr1)))
5247 discr1 = Corresponding_Discriminant (discr1);
5249 while (Present (Corresponding_Discriminant (discr2)))
5250 discr2 = Corresponding_Discriminant (discr2);
5253 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5256 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
5257 a non-aliased component in the back-end sense. */
5260 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
5262 /* If the type below this is a multi-array type, then
5263 this does not have aliased components. */
5264 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5265 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5268 if (Has_Aliased_Components (gnat_type))
5271 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5274 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5277 compile_time_known_address_p (Node_Id gnat_address)
5279 /* Catch System'To_Address. */
5280 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5281 gnat_address = Expression (gnat_address);
5283 return Compile_Time_Known_Value (gnat_address);
5286 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e.
5287 cannot verify HB < LB-1 when LB and HB are the low and high bounds. */
5290 cannot_be_superflat_p (Node_Id gnat_range)
5292 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5293 Node_Id scalar_range;
5295 tree gnu_lb, gnu_hb;
5297 /* If the low bound is not constant, try to find an upper bound. */
5298 while (Nkind (gnat_lb) != N_Integer_Literal
5299 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5300 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5301 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5302 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5303 || Nkind (scalar_range) == N_Range))
5304 gnat_lb = High_Bound (scalar_range);
5306 /* If the high bound is not constant, try to find a lower bound. */
5307 while (Nkind (gnat_hb) != N_Integer_Literal
5308 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5309 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5310 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5311 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5312 || Nkind (scalar_range) == N_Range))
5313 gnat_hb = Low_Bound (scalar_range);
5315 if (!(Nkind (gnat_lb) == N_Integer_Literal
5316 && Nkind (gnat_hb) == N_Integer_Literal))
5319 gnu_lb = UI_To_gnu (Intval (gnat_lb), bitsizetype);
5320 gnu_hb = UI_To_gnu (Intval (gnat_hb), bitsizetype);
5322 /* If the low bound is the smallest integer, nothing can be smaller. */
5323 gnu_lb = size_binop (MINUS_EXPR, gnu_lb, bitsize_one_node);
5324 if (TREE_OVERFLOW (gnu_lb))
5327 return (tree_int_cst_lt (gnu_hb, gnu_lb) == 0);
5330 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5331 be elaborated at the point of its definition, but do nothing else. */
5334 elaborate_entity (Entity_Id gnat_entity)
5336 switch (Ekind (gnat_entity))
5338 case E_Signed_Integer_Subtype:
5339 case E_Modular_Integer_Subtype:
5340 case E_Enumeration_Subtype:
5341 case E_Ordinary_Fixed_Point_Subtype:
5342 case E_Decimal_Fixed_Point_Subtype:
5343 case E_Floating_Point_Subtype:
5345 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5346 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5348 /* ??? Tests to avoid Constraint_Error in static expressions
5349 are needed until after the front stops generating bogus
5350 conversions on bounds of real types. */
5351 if (!Raises_Constraint_Error (gnat_lb))
5352 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5353 true, false, Needs_Debug_Info (gnat_entity));
5354 if (!Raises_Constraint_Error (gnat_hb))
5355 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5356 true, false, Needs_Debug_Info (gnat_entity));
5362 Node_Id full_definition = Declaration_Node (gnat_entity);
5363 Node_Id record_definition = Type_Definition (full_definition);
5365 /* If this is a record extension, go a level further to find the
5366 record definition. */
5367 if (Nkind (record_definition) == N_Derived_Type_Definition)
5368 record_definition = Record_Extension_Part (record_definition);
5372 case E_Record_Subtype:
5373 case E_Private_Subtype:
5374 case E_Limited_Private_Subtype:
5375 case E_Record_Subtype_With_Private:
5376 if (Is_Constrained (gnat_entity)
5377 && Has_Discriminants (gnat_entity)
5378 && Present (Discriminant_Constraint (gnat_entity)))
5380 Node_Id gnat_discriminant_expr;
5381 Entity_Id gnat_field;
5384 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5385 gnat_discriminant_expr
5386 = First_Elmt (Discriminant_Constraint (gnat_entity));
5387 Present (gnat_field);
5388 gnat_field = Next_Discriminant (gnat_field),
5389 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5390 /* ??? For now, ignore access discriminants. */
5391 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5392 elaborate_expression (Node (gnat_discriminant_expr),
5393 gnat_entity, get_entity_name (gnat_field),
5394 true, false, false);
5401 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5402 any entities on its entity chain similarly. */
5405 mark_out_of_scope (Entity_Id gnat_entity)
5407 Entity_Id gnat_sub_entity;
5408 unsigned int kind = Ekind (gnat_entity);
5410 /* If this has an entity list, process all in the list. */
5411 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5412 || IN (kind, Private_Kind)
5413 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5414 || kind == E_Function || kind == E_Generic_Function
5415 || kind == E_Generic_Package || kind == E_Generic_Procedure
5416 || kind == E_Loop || kind == E_Operator || kind == E_Package
5417 || kind == E_Package_Body || kind == E_Procedure
5418 || kind == E_Record_Type || kind == E_Record_Subtype
5419 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5420 for (gnat_sub_entity = First_Entity (gnat_entity);
5421 Present (gnat_sub_entity);
5422 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5423 if (Scope (gnat_sub_entity) == gnat_entity
5424 && gnat_sub_entity != gnat_entity)
5425 mark_out_of_scope (gnat_sub_entity);
5427 /* Now clear this if it has been defined, but only do so if it isn't
5428 a subprogram or parameter. We could refine this, but it isn't
5429 worth it. If this is statically allocated, it is supposed to
5430 hang around out of cope. */
5431 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5432 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5434 save_gnu_tree (gnat_entity, NULL_TREE, true);
5435 save_gnu_tree (gnat_entity, error_mark_node, true);
5439 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5440 If this is a multi-dimensional array type, do this recursively.
5443 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5444 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5445 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5448 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5450 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5451 of a one-dimensional array, since the padding has the same alias set
5452 as the field type, but if it's a multi-dimensional array, we need to
5453 see the inner types. */
5454 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5455 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5456 || TYPE_PADDING_P (gnu_old_type)))
5457 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5459 /* Unconstrained array types are deemed incomplete and would thus be given
5460 alias set 0. Retrieve the underlying array type. */
5461 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5463 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5464 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5466 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5468 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5469 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5470 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5471 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5475 case ALIAS_SET_COPY:
5476 /* The alias set shouldn't be copied between array types with different
5477 aliasing settings because this can break the aliasing relationship
5478 between the array type and its element type. */
5479 #ifndef ENABLE_CHECKING
5480 if (flag_strict_aliasing)
5482 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5483 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5484 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5485 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5487 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5490 case ALIAS_SET_SUBSET:
5491 case ALIAS_SET_SUPERSET:
5493 alias_set_type old_set = get_alias_set (gnu_old_type);
5494 alias_set_type new_set = get_alias_set (gnu_new_type);
5496 /* Do nothing if the alias sets conflict. This ensures that we
5497 never call record_alias_subset several times for the same pair
5498 or at all for alias set 0. */
5499 if (!alias_sets_conflict_p (old_set, new_set))
5501 if (op == ALIAS_SET_SUBSET)
5502 record_alias_subset (old_set, new_set);
5504 record_alias_subset (new_set, old_set);
5513 record_component_aliases (gnu_new_type);
5516 /* Return true if the size represented by GNU_SIZE can be handled by an
5517 allocation. If STATIC_P is true, consider only what can be done with a
5518 static allocation. */
5521 allocatable_size_p (tree gnu_size, bool static_p)
5523 HOST_WIDE_INT our_size;
5525 /* If this is not a static allocation, the only case we want to forbid
5526 is an overflowing size. That will be converted into a raise a
5529 return !(TREE_CODE (gnu_size) == INTEGER_CST
5530 && TREE_OVERFLOW (gnu_size));
5532 /* Otherwise, we need to deal with both variable sizes and constant
5533 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5534 since assemblers may not like very large sizes. */
5535 if (!host_integerp (gnu_size, 1))
5538 our_size = tree_low_cst (gnu_size, 1);
5539 return (int) our_size == our_size;
5542 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5543 NAME, ARGS and ERROR_POINT. */
5546 prepend_one_attribute_to (struct attrib ** attr_list,
5547 enum attr_type attr_type,
5550 Node_Id attr_error_point)
5552 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5554 attr->type = attr_type;
5555 attr->name = attr_name;
5556 attr->args = attr_args;
5557 attr->error_point = attr_error_point;
5559 attr->next = *attr_list;
5563 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5566 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5570 /* Attributes are stored as Representation Item pragmas. */
5572 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5573 gnat_temp = Next_Rep_Item (gnat_temp))
5574 if (Nkind (gnat_temp) == N_Pragma)
5576 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5577 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5578 enum attr_type etype;
5580 /* Map the kind of pragma at hand. Skip if this is not one
5581 we know how to handle. */
5583 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5585 case Pragma_Machine_Attribute:
5586 etype = ATTR_MACHINE_ATTRIBUTE;
5589 case Pragma_Linker_Alias:
5590 etype = ATTR_LINK_ALIAS;
5593 case Pragma_Linker_Section:
5594 etype = ATTR_LINK_SECTION;
5597 case Pragma_Linker_Constructor:
5598 etype = ATTR_LINK_CONSTRUCTOR;
5601 case Pragma_Linker_Destructor:
5602 etype = ATTR_LINK_DESTRUCTOR;
5605 case Pragma_Weak_External:
5606 etype = ATTR_WEAK_EXTERNAL;
5609 case Pragma_Thread_Local_Storage:
5610 etype = ATTR_THREAD_LOCAL_STORAGE;
5617 /* See what arguments we have and turn them into GCC trees for
5618 attribute handlers. These expect identifier for strings. We
5619 handle at most two arguments, static expressions only. */
5621 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5623 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5624 Node_Id gnat_arg1 = Empty;
5626 if (Present (gnat_arg0)
5627 && Is_Static_Expression (Expression (gnat_arg0)))
5629 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5631 if (TREE_CODE (gnu_arg0) == STRING_CST)
5632 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5634 gnat_arg1 = Next (gnat_arg0);
5637 if (Present (gnat_arg1)
5638 && Is_Static_Expression (Expression (gnat_arg1)))
5640 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5642 if (TREE_CODE (gnu_arg1) == STRING_CST)
5643 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
5647 /* Prepend to the list now. Make a list of the argument we might
5648 have, as GCC expects it. */
5649 prepend_one_attribute_to
5652 (gnu_arg1 != NULL_TREE)
5653 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5654 Present (Next (First (gnat_assoc)))
5655 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5659 /* Called when we need to protect a variable object using a SAVE_EXPR. */
5662 maybe_variable (tree gnu_operand)
5664 if (TREE_CONSTANT (gnu_operand)
5665 || TREE_READONLY (gnu_operand)
5666 || TREE_CODE (gnu_operand) == SAVE_EXPR
5667 || TREE_CODE (gnu_operand) == NULL_EXPR)
5670 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5673 = build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
5674 variable_size (TREE_OPERAND (gnu_operand, 0)));
5676 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5677 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5681 return variable_size (gnu_operand);
5684 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5685 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5686 return the GCC tree to use for that expression. GNU_NAME is the suffix
5687 to use if a variable needs to be created and DEFINITION is true if this
5688 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
5689 otherwise, we are just elaborating the expression for side-effects. If
5690 NEED_DEBUG is true, we need a variable for debugging purposes even if it
5691 isn't needed for code generation. */
5694 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
5695 bool definition, bool need_value, bool need_debug)
5699 /* If we already elaborated this expression (e.g. it was involved
5700 in the definition of a private type), use the old value. */
5701 if (present_gnu_tree (gnat_expr))
5702 return get_gnu_tree (gnat_expr);
5704 /* If we don't need a value and this is static or a discriminant,
5705 we don't need to do anything. */
5707 && (Is_OK_Static_Expression (gnat_expr)
5708 || (Nkind (gnat_expr) == N_Identifier
5709 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5712 /* If it's a static expression, we don't need a variable for debugging. */
5713 if (need_debug && Is_OK_Static_Expression (gnat_expr))
5716 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
5717 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
5718 gnu_name, definition, need_debug);
5720 /* Save the expression in case we try to elaborate this entity again. Since
5721 it's not a DECL, don't check it. Don't save if it's a discriminant. */
5722 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5723 save_gnu_tree (gnat_expr, gnu_expr, true);
5725 return need_value ? gnu_expr : error_mark_node;
5728 /* Similar, but take a GNU expression and always return a result. */
5731 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
5732 bool definition, bool need_debug)
5734 /* Skip any conversions and simple arithmetics to see if the expression
5735 is a read-only variable.
5736 ??? This really should remain read-only, but we have to think about
5737 the typing of the tree here. */
5739 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5740 tree gnu_decl = NULL_TREE;
5741 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5744 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
5745 reference will have been replaced with a COMPONENT_REF when the type
5746 is being elaborated. However, there are some cases involving child
5747 types where we will. So convert it to a COMPONENT_REF. We hope it
5748 will be at the highest level of the expression in these cases. */
5749 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5750 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5751 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5752 gnu_expr, NULL_TREE);
5754 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5755 that is read-only, make a variable that is initialized to contain the
5756 bound when the package containing the definition is elaborated. If
5757 this entity is defined at top level and a bound or discriminant value
5758 isn't a constant or a reference to a discriminant, replace the bound
5759 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5760 rely here on the fact that an expression cannot contain both the
5761 discriminant and some other variable. */
5762 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5763 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5764 && (TREE_READONLY (gnu_inner_expr)
5765 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5766 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5768 /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */
5769 if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
5772 /* Now create the variable if we need it. */
5773 if (need_debug || (expr_variable && expr_global))
5775 = create_var_decl (create_concat_name (gnat_entity,
5776 IDENTIFIER_POINTER (gnu_name)),
5777 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5778 !need_debug, Is_Public (gnat_entity),
5779 !definition, false, NULL, gnat_entity);
5781 /* We only need to use this variable if we are in global context since GCC
5782 can do the right thing in the local case. */
5783 if (expr_global && expr_variable)
5786 return expr_variable ? maybe_variable (gnu_expr) : gnu_expr;
5789 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5790 starting bit position so that it is aligned to ALIGN bits, and leaving at
5791 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5792 record is guaranteed to get. */
5795 make_aligning_type (tree type, unsigned int align, tree size,
5796 unsigned int base_align, int room)
5798 /* We will be crafting a record type with one field at a position set to be
5799 the next multiple of ALIGN past record'address + room bytes. We use a
5800 record placeholder to express record'address. */
5802 tree record_type = make_node (RECORD_TYPE);
5803 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5806 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5808 /* The diagram below summarizes the shape of what we manipulate:
5810 <--------- pos ---------->
5811 { +------------+-------------+-----------------+
5812 record =>{ |############| ... | field (type) |
5813 { +------------+-------------+-----------------+
5814 |<-- room -->|<- voffset ->|<---- size ----->|
5817 record_addr vblock_addr
5819 Every length is in sizetype bytes there, except "pos" which has to be
5820 set as a bit position in the GCC tree for the record. */
5822 tree room_st = size_int (room);
5823 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5824 tree voffset_st, pos, field;
5826 tree name = TYPE_NAME (type);
5828 if (TREE_CODE (name) == TYPE_DECL)
5829 name = DECL_NAME (name);
5831 TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
5833 /* Compute VOFFSET and then POS. The next byte position multiple of some
5834 alignment after some address is obtained by "and"ing the alignment minus
5835 1 with the two's complement of the address. */
5837 voffset_st = size_binop (BIT_AND_EXPR,
5838 size_diffop (size_zero_node, vblock_addr_st),
5839 ssize_int ((align / BITS_PER_UNIT) - 1));
5841 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5843 pos = size_binop (MULT_EXPR,
5844 convert (bitsizetype,
5845 size_binop (PLUS_EXPR, room_st, voffset_st)),
5848 /* Craft the GCC record representation. We exceptionally do everything
5849 manually here because 1) our generic circuitry is not quite ready to
5850 handle the complex position/size expressions we are setting up, 2) we
5851 have a strong simplifying factor at hand: we know the maximum possible
5852 value of voffset, and 3) we have to set/reset at least the sizes in
5853 accordance with this maximum value anyway, as we need them to convey
5854 what should be "alloc"ated for this type.
5856 Use -1 as the 'addressable' indication for the field to prevent the
5857 creation of a bitfield. We don't need one, it would have damaging
5858 consequences on the alignment computation, and create_field_decl would
5859 make one without this special argument, for instance because of the
5860 complex position expression. */
5862 field = create_field_decl (get_identifier ("F"), type, record_type,
5864 TYPE_FIELDS (record_type) = field;
5866 TYPE_ALIGN (record_type) = base_align;
5867 TYPE_USER_ALIGN (record_type) = 1;
5869 TYPE_SIZE (record_type)
5870 = size_binop (PLUS_EXPR,
5871 size_binop (MULT_EXPR, convert (bitsizetype, size),
5873 bitsize_int (align + room * BITS_PER_UNIT));
5874 TYPE_SIZE_UNIT (record_type)
5875 = size_binop (PLUS_EXPR, size,
5876 size_int (room + align / BITS_PER_UNIT));
5878 SET_TYPE_MODE (record_type, BLKmode);
5880 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
5884 /* Return the result of rounding T up to ALIGN. */
5886 static inline unsigned HOST_WIDE_INT
5887 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5895 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5896 as the field type of a packed record if IN_RECORD is true, or as the
5897 component type of a packed array if IN_RECORD is false. See if we can
5898 rewrite it either as a type that has a non-BLKmode, which we can pack
5899 tighter in the packed record case, or as a smaller type. If so, return
5900 the new type. If not, return the original type. */
5903 make_packable_type (tree type, bool in_record)
5905 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5906 unsigned HOST_WIDE_INT new_size;
5907 tree new_type, old_field, field_list = NULL_TREE;
5909 /* No point in doing anything if the size is zero. */
5913 new_type = make_node (TREE_CODE (type));
5915 /* Copy the name and flags from the old type to that of the new.
5916 Note that we rely on the pointer equality created here for
5917 TYPE_NAME to look through conversions in various places. */
5918 TYPE_NAME (new_type) = TYPE_NAME (type);
5919 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5920 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5921 if (TREE_CODE (type) == RECORD_TYPE)
5922 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
5924 /* If we are in a record and have a small size, set the alignment to
5925 try for an integral mode. Otherwise set it to try for a smaller
5926 type with BLKmode. */
5927 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5929 TYPE_ALIGN (new_type) = ceil_alignment (size);
5930 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5934 unsigned HOST_WIDE_INT align;
5936 /* Do not try to shrink the size if the RM size is not constant. */
5937 if (TYPE_CONTAINS_TEMPLATE_P (type)
5938 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5941 /* Round the RM size up to a unit boundary to get the minimal size
5942 for a BLKmode record. Give up if it's already the size. */
5943 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5944 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5945 if (new_size == size)
5948 align = new_size & -new_size;
5949 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5952 TYPE_USER_ALIGN (new_type) = 1;
5954 /* Now copy the fields, keeping the position and size as we don't want
5955 to change the layout by propagating the packedness downwards. */
5956 for (old_field = TYPE_FIELDS (type); old_field;
5957 old_field = TREE_CHAIN (old_field))
5959 tree new_field_type = TREE_TYPE (old_field);
5960 tree new_field, new_size;
5962 if ((TREE_CODE (new_field_type) == RECORD_TYPE
5963 || TREE_CODE (new_field_type) == UNION_TYPE
5964 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5965 && !TYPE_FAT_POINTER_P (new_field_type)
5966 && host_integerp (TYPE_SIZE (new_field_type), 1))
5967 new_field_type = make_packable_type (new_field_type, true);
5969 /* However, for the last field in a not already packed record type
5970 that is of an aggregate type, we need to use the RM size in the
5971 packable version of the record type, see finish_record_type. */
5972 if (!TREE_CHAIN (old_field)
5973 && !TYPE_PACKED (type)
5974 && (TREE_CODE (new_field_type) == RECORD_TYPE
5975 || TREE_CODE (new_field_type) == UNION_TYPE
5976 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5977 && !TYPE_FAT_POINTER_P (new_field_type)
5978 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5979 && TYPE_ADA_SIZE (new_field_type))
5980 new_size = TYPE_ADA_SIZE (new_field_type);
5982 new_size = DECL_SIZE (old_field);
5984 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5985 new_type, TYPE_PACKED (type), new_size,
5986 bit_position (old_field),
5987 !DECL_NONADDRESSABLE_P (old_field));
5989 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5990 SET_DECL_ORIGINAL_FIELD
5991 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5992 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5994 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5995 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5997 TREE_CHAIN (new_field) = field_list;
5998 field_list = new_field;
6001 finish_record_type (new_type, nreverse (field_list), 2, true);
6002 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6004 /* If this is a padding record, we never want to make the size smaller
6005 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6006 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6008 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6009 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6013 TYPE_SIZE (new_type) = bitsize_int (new_size);
6014 TYPE_SIZE_UNIT (new_type)
6015 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6018 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6019 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6021 compute_record_mode (new_type);
6023 /* Try harder to get a packable type if necessary, for example
6024 in case the record itself contains a BLKmode field. */
6025 if (in_record && TYPE_MODE (new_type) == BLKmode)
6026 SET_TYPE_MODE (new_type,
6027 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6029 /* If neither the mode nor the size has shrunk, return the old type. */
6030 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6036 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6037 if needed. We have already verified that SIZE and TYPE are large enough.
6038 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6039 IS_COMPONENT_TYPE is true if this is being done for the component type
6040 of an array. IS_USER_TYPE is true if we must complete the original type.
6041 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6042 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6043 it's set to the RM size of the original type. */
6046 maybe_pad_type (tree type, tree size, unsigned int align,
6047 Entity_Id gnat_entity, bool is_component_type,
6048 bool is_user_type, bool definition, bool same_rm_size)
6050 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6051 tree orig_size = TYPE_SIZE (type);
6054 /* If TYPE is a padded type, see if it agrees with any size and alignment
6055 we were given. If so, return the original type. Otherwise, strip
6056 off the padding, since we will either be returning the inner type
6057 or repadding it. If no size or alignment is specified, use that of
6058 the original padded type. */
6059 if (TYPE_IS_PADDING_P (type))
6062 || operand_equal_p (round_up (size,
6063 MAX (align, TYPE_ALIGN (type))),
6064 round_up (TYPE_SIZE (type),
6065 MAX (align, TYPE_ALIGN (type))),
6067 && (align == 0 || align == TYPE_ALIGN (type)))
6071 size = TYPE_SIZE (type);
6073 align = TYPE_ALIGN (type);
6075 type = TREE_TYPE (TYPE_FIELDS (type));
6076 orig_size = TYPE_SIZE (type);
6079 /* If the size is either not being changed or is being made smaller (which
6080 is not done here and is only valid for bitfields anyway), show the size
6081 isn't changing. Likewise, clear the alignment if it isn't being
6082 changed. Then return if we aren't doing anything. */
6084 && (operand_equal_p (size, orig_size, 0)
6085 || (TREE_CODE (orig_size) == INTEGER_CST
6086 && tree_int_cst_lt (size, orig_size))))
6089 if (align == TYPE_ALIGN (type))
6092 if (align == 0 && !size)
6095 /* If requested, complete the original type and give it a name. */
6097 create_type_decl (get_entity_name (gnat_entity), type,
6098 NULL, !Comes_From_Source (gnat_entity),
6100 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6101 && DECL_IGNORED_P (TYPE_NAME (type))),
6104 /* We used to modify the record in place in some cases, but that could
6105 generate incorrect debugging information. So make a new record
6107 record = make_node (RECORD_TYPE);
6108 TYPE_PADDING_P (record) = 1;
6110 if (Present (gnat_entity))
6111 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6113 TYPE_VOLATILE (record)
6114 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6116 TYPE_ALIGN (record) = align;
6117 TYPE_SIZE (record) = size ? size : orig_size;
6118 TYPE_SIZE_UNIT (record)
6119 = convert (sizetype,
6120 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6121 bitsize_unit_node));
6123 /* If we are changing the alignment and the input type is a record with
6124 BLKmode and a small constant size, try to make a form that has an
6125 integral mode. This might allow the padding record to also have an
6126 integral mode, which will be much more efficient. There is no point
6127 in doing so if a size is specified unless it is also a small constant
6128 size and it is incorrect to do so if we cannot guarantee that the mode
6129 will be naturally aligned since the field must always be addressable.
6131 ??? This might not always be a win when done for a stand-alone object:
6132 since the nominal and the effective type of the object will now have
6133 different modes, a VIEW_CONVERT_EXPR will be required for converting
6134 between them and it might be hard to overcome afterwards, including
6135 at the RTL level when the stand-alone object is accessed as a whole. */
6137 && TREE_CODE (type) == RECORD_TYPE
6138 && TYPE_MODE (type) == BLKmode
6139 && TREE_CODE (orig_size) == INTEGER_CST
6140 && !TREE_OVERFLOW (orig_size)
6141 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6143 || (TREE_CODE (size) == INTEGER_CST
6144 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6146 tree packable_type = make_packable_type (type, true);
6147 if (TYPE_MODE (packable_type) != BLKmode
6148 && align >= TYPE_ALIGN (packable_type))
6149 type = packable_type;
6152 /* Now create the field with the original size. */
6153 field = create_field_decl (get_identifier ("F"), type, record, 0,
6154 orig_size, bitsize_zero_node, 1);
6155 DECL_INTERNAL_P (field) = 1;
6157 /* Do not finalize it until after the auxiliary record is built. */
6158 finish_record_type (record, field, 1, true);
6160 /* Set the same size for its RM size if requested; otherwise reuse
6161 the RM size of the original type. */
6162 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6164 /* Unless debugging information isn't being written for the input type,
6165 write a record that shows what we are a subtype of and also make a
6166 variable that indicates our size, if still variable. */
6167 if (TYPE_NAME (record)
6168 && AGGREGATE_TYPE_P (type)
6169 && TREE_CODE (orig_size) != INTEGER_CST
6170 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6171 && DECL_IGNORED_P (TYPE_NAME (type))))
6173 tree marker = make_node (RECORD_TYPE);
6174 tree name = TYPE_NAME (record);
6175 tree orig_name = TYPE_NAME (type);
6177 if (TREE_CODE (name) == TYPE_DECL)
6178 name = DECL_NAME (name);
6180 if (TREE_CODE (orig_name) == TYPE_DECL)
6181 orig_name = DECL_NAME (orig_name);
6183 TYPE_NAME (marker) = concat_name (name, "XVS");
6184 finish_record_type (marker,
6185 create_field_decl (orig_name,
6186 build_reference_type (type),
6187 marker, 0, NULL_TREE, NULL_TREE,
6191 add_parallel_type (TYPE_STUB_DECL (record), marker);
6193 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6194 create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6195 TYPE_SIZE_UNIT (record), false, false, false,
6196 false, NULL, gnat_entity);
6199 rest_of_record_type_compilation (record);
6201 /* If the size was widened explicitly, maybe give a warning. Take the
6202 original size as the maximum size of the input if there was an
6203 unconstrained record involved and round it up to the specified alignment,
6204 if one was specified. */
6205 if (CONTAINS_PLACEHOLDER_P (orig_size))
6206 orig_size = max_size (orig_size, true);
6209 orig_size = round_up (orig_size, align);
6211 if (Present (gnat_entity)
6213 && TREE_CODE (size) != MAX_EXPR
6214 && !operand_equal_p (size, orig_size, 0)
6215 && !(TREE_CODE (size) == INTEGER_CST
6216 && TREE_CODE (orig_size) == INTEGER_CST
6217 && tree_int_cst_lt (size, orig_size)))
6219 Node_Id gnat_error_node = Empty;
6221 if (Is_Packed_Array_Type (gnat_entity))
6222 gnat_entity = Original_Array_Type (gnat_entity);
6224 if ((Ekind (gnat_entity) == E_Component
6225 || Ekind (gnat_entity) == E_Discriminant)
6226 && Present (Component_Clause (gnat_entity)))
6227 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6228 else if (Present (Size_Clause (gnat_entity)))
6229 gnat_error_node = Expression (Size_Clause (gnat_entity));
6231 /* Generate message only for entities that come from source, since
6232 if we have an entity created by expansion, the message will be
6233 generated for some other corresponding source entity. */
6234 if (Comes_From_Source (gnat_entity))
6236 if (Present (gnat_error_node))
6237 post_error_ne_tree ("{^ }bits of & unused?",
6238 gnat_error_node, gnat_entity,
6239 size_diffop (size, orig_size));
6240 else if (is_component_type)
6241 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6242 gnat_entity, gnat_entity,
6243 size_diffop (size, orig_size));
6250 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6251 the value passed against the list of choices. */
6254 choices_to_gnu (tree operand, Node_Id choices)
6258 tree result = integer_zero_node;
6259 tree this_test, low = 0, high = 0, single = 0;
6261 for (choice = First (choices); Present (choice); choice = Next (choice))
6263 switch (Nkind (choice))
6266 low = gnat_to_gnu (Low_Bound (choice));
6267 high = gnat_to_gnu (High_Bound (choice));
6269 /* There's no good type to use here, so we might as well use
6270 integer_type_node. */
6272 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6273 build_binary_op (GE_EXPR, integer_type_node,
6275 build_binary_op (LE_EXPR, integer_type_node,
6280 case N_Subtype_Indication:
6281 gnat_temp = Range_Expression (Constraint (choice));
6282 low = gnat_to_gnu (Low_Bound (gnat_temp));
6283 high = gnat_to_gnu (High_Bound (gnat_temp));
6286 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6287 build_binary_op (GE_EXPR, integer_type_node,
6289 build_binary_op (LE_EXPR, integer_type_node,
6294 case N_Expanded_Name:
6295 /* This represents either a subtype range, an enumeration
6296 literal, or a constant Ekind says which. If an enumeration
6297 literal or constant, fall through to the next case. */
6298 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6299 && Ekind (Entity (choice)) != E_Constant)
6301 tree type = gnat_to_gnu_type (Entity (choice));
6303 low = TYPE_MIN_VALUE (type);
6304 high = TYPE_MAX_VALUE (type);
6307 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6308 build_binary_op (GE_EXPR, integer_type_node,
6310 build_binary_op (LE_EXPR, integer_type_node,
6315 /* ... fall through ... */
6317 case N_Character_Literal:
6318 case N_Integer_Literal:
6319 single = gnat_to_gnu (choice);
6320 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
6324 case N_Others_Choice:
6325 this_test = integer_one_node;
6332 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6339 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6340 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6343 adjust_packed (tree field_type, tree record_type, int packed)
6345 /* If the field contains an item of variable size, we cannot pack it
6346 because we cannot create temporaries of non-fixed size in case
6347 we need to take the address of the field. See addressable_p and
6348 the notes on the addressability issues for further details. */
6349 if (is_variable_size (field_type))
6352 /* If the alignment of the record is specified and the field type
6353 is over-aligned, request Storage_Unit alignment for the field. */
6356 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6365 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6366 placed in GNU_RECORD_TYPE.
6368 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6369 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6370 record has a specified alignment.
6372 DEFINITION is true if this field is for a record being defined.
6374 DEBUG_INFO_P is true if we need to write debug information for types
6375 that we may create in the process. */
6378 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6379 bool definition, bool debug_info_p)
6381 tree gnu_field_id = get_entity_name (gnat_field);
6382 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6383 tree gnu_field, gnu_size, gnu_pos;
6384 bool needs_strict_alignment
6385 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6386 || Treat_As_Volatile (gnat_field));
6388 /* If this field requires strict alignment, we cannot pack it because
6389 it would very likely be under-aligned in the record. */
6390 if (needs_strict_alignment)
6393 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6395 /* If a size is specified, use it. Otherwise, if the record type is packed,
6396 use the official RM size. See "Handling of Type'Size Values" in Einfo
6397 for further details. */
6398 if (Known_Static_Esize (gnat_field))
6399 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6400 gnat_field, FIELD_DECL, false, true);
6401 else if (packed == 1)
6402 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6403 gnat_field, FIELD_DECL, false, true);
6405 gnu_size = NULL_TREE;
6407 /* If we have a specified size that's smaller than that of the field type,
6408 or a position is specified, and the field type is a record, see if we can
6409 get either an integral mode form of the type or a smaller form. If we
6410 can, show a size was specified for the field if there wasn't one already,
6411 so we know to make this a bitfield and avoid making things wider.
6413 Doing this is first useful if the record is packed because we may then
6414 place the field at a non-byte-aligned position and so achieve tighter
6417 This is in addition *required* if the field shares a byte with another
6418 field and the front-end lets the back-end handle the references, because
6419 GCC does not handle BLKmode bitfields properly.
6421 We avoid the transformation if it is not required or potentially useful,
6422 as it might entail an increase of the field's alignment and have ripple
6423 effects on the outer record type. A typical case is a field known to be
6424 byte aligned and not to share a byte with another field.
6426 Besides, we don't even look the possibility of a transformation in cases
6427 known to be in error already, for instance when an invalid size results
6428 from a component clause. */
6430 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6431 && !TYPE_FAT_POINTER_P (gnu_field_type)
6432 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6435 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6436 || Present (Component_Clause (gnat_field))))))
6438 /* See what the alternate type and size would be. */
6439 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6441 bool has_byte_aligned_clause
6442 = Present (Component_Clause (gnat_field))
6443 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6444 % BITS_PER_UNIT == 0);
6446 /* Compute whether we should avoid the substitution. */
6448 /* There is no point substituting if there is no change... */
6449 = (gnu_packable_type == gnu_field_type)
6450 /* ... nor when the field is known to be byte aligned and not to
6451 share a byte with another field. */
6452 || (has_byte_aligned_clause
6453 && value_factor_p (gnu_size, BITS_PER_UNIT))
6454 /* The size of an aliased field must be an exact multiple of the
6455 type's alignment, which the substitution might increase. Reject
6456 substitutions that would so invalidate a component clause when the
6457 specified position is byte aligned, as the change would have no
6458 real benefit from the packing standpoint anyway. */
6459 || (Is_Aliased (gnat_field)
6460 && has_byte_aligned_clause
6461 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6463 /* Substitute unless told otherwise. */
6466 gnu_field_type = gnu_packable_type;
6469 gnu_size = rm_size (gnu_field_type);
6473 /* If we are packing the record and the field is BLKmode, round the
6474 size up to a byte boundary. */
6475 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6476 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6478 if (Present (Component_Clause (gnat_field)))
6480 Entity_Id gnat_parent
6481 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6483 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6484 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6485 gnat_field, FIELD_DECL, false, true);
6487 /* Ensure the position does not overlap with the parent subtype, if there
6488 is one. This test is omitted if the parent of the tagged type has a
6489 full rep clause since, in this case, component clauses are allowed to
6490 overlay the space allocated for the parent type and the front-end has
6491 checked that there are no overlapping components. */
6492 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6494 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6496 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6497 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6500 ("offset of& must be beyond parent{, minimum allowed is ^}",
6501 First_Bit (Component_Clause (gnat_field)), gnat_field,
6502 TYPE_SIZE_UNIT (gnu_parent));
6506 /* If this field needs strict alignment, ensure the record is
6507 sufficiently aligned and that that position and size are
6508 consistent with the alignment. */
6509 if (needs_strict_alignment)
6511 TYPE_ALIGN (gnu_record_type)
6512 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6515 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6517 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6519 ("atomic field& must be natural size of type{ (^)}",
6520 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6521 TYPE_SIZE (gnu_field_type));
6523 else if (Is_Aliased (gnat_field))
6525 ("size of aliased field& must be ^ bits",
6526 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6527 TYPE_SIZE (gnu_field_type));
6529 else if (Strict_Alignment (Etype (gnat_field)))
6531 ("size of & with aliased or tagged components not ^ bits",
6532 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6533 TYPE_SIZE (gnu_field_type));
6535 gnu_size = NULL_TREE;
6538 if (!integer_zerop (size_binop
6539 (TRUNC_MOD_EXPR, gnu_pos,
6540 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6542 if (Is_Aliased (gnat_field))
6544 ("position of aliased field& must be multiple of ^ bits",
6545 First_Bit (Component_Clause (gnat_field)), gnat_field,
6546 TYPE_ALIGN (gnu_field_type));
6548 else if (Treat_As_Volatile (gnat_field))
6550 ("position of volatile field& must be multiple of ^ bits",
6551 First_Bit (Component_Clause (gnat_field)), gnat_field,
6552 TYPE_ALIGN (gnu_field_type));
6554 else if (Strict_Alignment (Etype (gnat_field)))
6556 ("position of & with aliased or tagged components not multiple of ^ bits",
6557 First_Bit (Component_Clause (gnat_field)), gnat_field,
6558 TYPE_ALIGN (gnu_field_type));
6563 gnu_pos = NULL_TREE;
6567 if (Is_Atomic (gnat_field))
6568 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6571 /* If the record has rep clauses and this is the tag field, make a rep
6572 clause for it as well. */
6573 else if (Has_Specified_Layout (Scope (gnat_field))
6574 && Chars (gnat_field) == Name_uTag)
6576 gnu_pos = bitsize_zero_node;
6577 gnu_size = TYPE_SIZE (gnu_field_type);
6581 gnu_pos = NULL_TREE;
6583 /* We need to make the size the maximum for the type if it is
6584 self-referential and an unconstrained type. In that case, we can't
6585 pack the field since we can't make a copy to align it. */
6586 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6588 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6589 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6591 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6595 /* If a size is specified, adjust the field's type to it. */
6598 tree orig_field_type;
6600 /* If the field's type is justified modular, we would need to remove
6601 the wrapper to (better) meet the layout requirements. However we
6602 can do so only if the field is not aliased to preserve the unique
6603 layout and if the prescribed size is not greater than that of the
6604 packed array to preserve the justification. */
6605 if (!needs_strict_alignment
6606 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6607 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6608 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6610 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6613 = make_type_from_size (gnu_field_type, gnu_size,
6614 Has_Biased_Representation (gnat_field));
6616 orig_field_type = gnu_field_type;
6617 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6618 false, false, definition, true);
6620 /* If a padding record was made, declare it now since it will never be
6621 declared otherwise. This is necessary to ensure that its subtrees
6622 are properly marked. */
6623 if (gnu_field_type != orig_field_type
6624 && !DECL_P (TYPE_NAME (gnu_field_type)))
6625 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6626 true, debug_info_p, gnat_field);
6629 /* Otherwise (or if there was an error), don't specify a position. */
6631 gnu_pos = NULL_TREE;
6633 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6634 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6636 /* Now create the decl for the field. */
6637 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6638 packed, gnu_size, gnu_pos,
6639 Is_Aliased (gnat_field));
6640 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6641 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6643 if (Ekind (gnat_field) == E_Discriminant)
6644 DECL_DISCRIMINANT_NUMBER (gnu_field)
6645 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6650 /* Return true if TYPE is a type with variable size, a padding type with a
6651 field of variable size or is a record that has a field such a field. */
6654 is_variable_size (tree type)
6658 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6661 if (TYPE_IS_PADDING_P (type)
6662 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6665 if (TREE_CODE (type) != RECORD_TYPE
6666 && TREE_CODE (type) != UNION_TYPE
6667 && TREE_CODE (type) != QUAL_UNION_TYPE)
6670 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6671 if (is_variable_size (TREE_TYPE (field)))
6677 /* qsort comparer for the bit positions of two record components. */
6680 compare_field_bitpos (const PTR rt1, const PTR rt2)
6682 const_tree const field1 = * (const_tree const *) rt1;
6683 const_tree const field2 = * (const_tree const *) rt2;
6685 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6687 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6690 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
6691 the result as the field list of GNU_RECORD_TYPE and finish it up. When
6692 called from gnat_to_gnu_entity during the processing of a record type
6693 definition, the GCC node for the parent, if any, will be the single field
6694 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6695 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6696 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6698 PACKED is 1 if this is for a packed record, -1 if this is for a record
6699 with Component_Alignment of Storage_Unit, -2 if this is for a record
6700 with a specified alignment.
6702 DEFINITION is true if we are defining this record.
6704 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6705 with a rep clause is to be added; in this case, that is all that should
6706 be done with such fields.
6708 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6709 laying out the record. This means the alignment only serves to force
6710 fields to be bitfields, but not require the record to be that aligned.
6711 This is used for variants.
6713 ALL_REP, if true, means a rep clause was found for all the fields. This
6714 simplifies the logic since we know we're not in the mixed case.
6716 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6717 modified afterwards so it will not be finalized here.
6719 UNCHECKED_UNION, if true, means that we are building a type for a record
6720 with a Pragma Unchecked_Union.
6722 DEBUG_INFO_P, if true, means that we need to write debug information for
6723 types that we may create in the process. */
6726 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
6727 tree gnu_field_list, int packed, bool definition,
6728 tree *p_gnu_rep_list, bool cancel_alignment,
6729 bool all_rep, bool do_not_finalize,
6730 bool unchecked_union, bool debug_info_p)
6732 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6733 bool layout_with_rep = false;
6734 Node_Id component_decl, variant_part;
6735 tree gnu_our_rep_list = NULL_TREE;
6736 tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
6738 /* For each component referenced in a component declaration create a GCC
6739 field and add it to the list, skipping pragmas in the GNAT list. */
6740 if (Present (Component_Items (gnat_component_list)))
6742 = First_Non_Pragma (Component_Items (gnat_component_list));
6743 Present (component_decl);
6744 component_decl = Next_Non_Pragma (component_decl))
6746 Entity_Id gnat_field = Defining_Entity (component_decl);
6747 Name_Id gnat_name = Chars (gnat_field);
6749 /* If present, the _Parent field must have been created as the single
6750 field of the record type. Put it before any other fields. */
6751 if (gnat_name == Name_uParent)
6753 gnu_field = TYPE_FIELDS (gnu_record_type);
6754 gnu_field_list = chainon (gnu_field_list, gnu_field);
6758 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
6759 definition, debug_info_p);
6761 /* If this is the _Tag field, put it before any other fields. */
6762 if (gnat_name == Name_uTag)
6763 gnu_field_list = chainon (gnu_field_list, gnu_field);
6765 /* If this is the _Controller field, put it before the other
6766 fields except for the _Tag or _Parent field. */
6767 else if (gnat_name == Name_uController && gnu_last)
6769 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
6770 TREE_CHAIN (gnu_last) = gnu_field;
6773 /* If this is a regular field, put it after the other fields. */
6776 TREE_CHAIN (gnu_field) = gnu_field_list;
6777 gnu_field_list = gnu_field;
6779 gnu_last = gnu_field;
6783 save_gnu_tree (gnat_field, gnu_field, false);
6786 /* At the end of the component list there may be a variant part. */
6787 variant_part = Variant_Part (gnat_component_list);
6789 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6790 mutually exclusive and should go in the same memory. To do this we need
6791 to treat each variant as a record whose elements are created from the
6792 component list for the variant. So here we create the records from the
6793 lists for the variants and put them all into the QUAL_UNION_TYPE.
6794 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6795 use GNU_RECORD_TYPE if there are no fields so far. */
6796 if (Present (variant_part))
6798 Node_Id gnat_discr = Name (variant_part), variant;
6799 tree gnu_discr = gnat_to_gnu (gnat_discr);
6800 tree gnu_name = TYPE_NAME (gnu_record_type);
6802 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
6804 tree gnu_union_type, gnu_union_name, gnu_union_field;
6805 tree gnu_variant_list = NULL_TREE;
6807 if (TREE_CODE (gnu_name) == TYPE_DECL)
6808 gnu_name = DECL_NAME (gnu_name);
6811 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
6813 /* Reuse an enclosing union if all fields are in the variant part
6814 and there is no representation clause on the record, to match
6815 the layout of C unions. There is an associated check below. */
6817 && TREE_CODE (gnu_record_type) == UNION_TYPE
6818 && !TYPE_PACKED (gnu_record_type))
6819 gnu_union_type = gnu_record_type;
6823 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6825 TYPE_NAME (gnu_union_type) = gnu_union_name;
6826 TYPE_ALIGN (gnu_union_type) = 0;
6827 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6830 for (variant = First_Non_Pragma (Variants (variant_part));
6832 variant = Next_Non_Pragma (variant))
6834 tree gnu_variant_type = make_node (RECORD_TYPE);
6835 tree gnu_inner_name;
6838 Get_Variant_Encoding (variant);
6839 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
6840 TYPE_NAME (gnu_variant_type)
6841 = concat_name (gnu_union_name,
6842 IDENTIFIER_POINTER (gnu_inner_name));
6844 /* Set the alignment of the inner type in case we need to make
6845 inner objects into bitfields, but then clear it out so the
6846 record actually gets only the alignment required. */
6847 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6848 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6850 /* Similarly, if the outer record has a size specified and all
6851 fields have record rep clauses, we can propagate the size
6852 into the variant part. */
6853 if (all_rep_and_size)
6855 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6856 TYPE_SIZE_UNIT (gnu_variant_type)
6857 = TYPE_SIZE_UNIT (gnu_record_type);
6860 /* Add the fields into the record type for the variant. Note that we
6861 defer finalizing it until after we are sure to really use it. */
6862 components_to_record (gnu_variant_type, Component_List (variant),
6863 NULL_TREE, packed, definition,
6864 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6865 true, unchecked_union, debug_info_p);
6867 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
6869 Set_Present_Expr (variant, annotate_value (gnu_qual));
6871 /* If this is an Unchecked_Union and we have exactly one field,
6872 use this field directly to match the layout of C unions. */
6874 && TYPE_FIELDS (gnu_variant_type)
6875 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6876 gnu_field = TYPE_FIELDS (gnu_variant_type);
6879 /* Deal with packedness like in gnat_to_gnu_field. */
6881 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6883 /* Finalize the record type now. We used to throw away
6884 empty records but we no longer do that because we need
6885 them to generate complete debug info for the variant;
6886 otherwise, the union type definition will be lacking
6887 the fields associated with these empty variants. */
6888 rest_of_record_type_compilation (gnu_variant_type);
6889 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
6890 NULL, true, debug_info_p, gnat_component_list);
6892 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6893 gnu_union_type, field_packed,
6895 ? TYPE_SIZE (gnu_variant_type)
6898 ? bitsize_zero_node : 0),
6901 DECL_INTERNAL_P (gnu_field) = 1;
6903 if (!unchecked_union)
6904 DECL_QUALIFIER (gnu_field) = gnu_qual;
6907 TREE_CHAIN (gnu_field) = gnu_variant_list;
6908 gnu_variant_list = gnu_field;
6911 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
6912 if (gnu_variant_list)
6914 int union_field_packed;
6916 if (all_rep_and_size)
6918 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6919 TYPE_SIZE_UNIT (gnu_union_type)
6920 = TYPE_SIZE_UNIT (gnu_record_type);
6923 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6924 all_rep_and_size ? 1 : 0, false);
6926 /* If GNU_UNION_TYPE is our record type, it means we must have an
6927 Unchecked_Union with no fields. Verify that and, if so, just
6929 if (gnu_union_type == gnu_record_type)
6931 gcc_assert (unchecked_union
6933 && !gnu_our_rep_list);
6937 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
6938 NULL, true, debug_info_p, gnat_component_list);
6940 /* Deal with packedness like in gnat_to_gnu_field. */
6942 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6945 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6947 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6948 all_rep ? bitsize_zero_node : 0, 0);
6950 DECL_INTERNAL_P (gnu_union_field) = 1;
6951 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6952 gnu_field_list = gnu_union_field;
6956 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6957 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do
6958 this in a separate pass since we want to handle the discriminants but
6959 can't play with them until we've used them in debugging data above.
6961 ??? If we then reorder them, debugging information will be wrong but
6962 there's nothing that can be done about this at the moment. */
6963 gnu_last = NULL_TREE;
6964 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
6966 gnu_next = TREE_CHAIN (gnu_field);
6968 if (DECL_FIELD_OFFSET (gnu_field))
6971 gnu_field_list = gnu_next;
6973 TREE_CHAIN (gnu_last) = gnu_next;
6975 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6976 gnu_our_rep_list = gnu_field;
6979 gnu_last = gnu_field;
6982 /* If we have any fields in our rep'ed field list and it is not the case that
6983 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
6984 set it and ignore these fields. */
6985 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6986 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6988 /* Otherwise, sort the fields by bit position and put them into their own
6989 record, before the others, if we also have fields without rep clauses. */
6990 else if (gnu_our_rep_list)
6993 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6994 int i, len = list_length (gnu_our_rep_list);
6995 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6997 for (gnu_field = gnu_our_rep_list, i = 0;
6999 gnu_field = TREE_CHAIN (gnu_field), i++)
7000 gnu_arr[i] = gnu_field;
7002 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7004 /* Put the fields in the list in order of increasing position, which
7005 means we start from the end. */
7006 gnu_our_rep_list = NULL_TREE;
7007 for (i = len - 1; i >= 0; i--)
7009 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
7010 gnu_our_rep_list = gnu_arr[i];
7011 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7016 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
7018 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7019 gnu_record_type, 0, NULL_TREE, NULL_TREE, 1);
7020 DECL_INTERNAL_P (gnu_field) = 1;
7021 gnu_field_list = chainon (gnu_field_list, gnu_field);
7025 layout_with_rep = true;
7026 gnu_field_list = nreverse (gnu_our_rep_list);
7030 if (cancel_alignment)
7031 TYPE_ALIGN (gnu_record_type) = 0;
7033 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7034 layout_with_rep ? 1 : 0, do_not_finalize);
7037 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7038 placed into an Esize, Component_Bit_Offset, or Component_Size value
7039 in the GNAT tree. */
7042 annotate_value (tree gnu_size)
7044 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
7046 Node_Ref_Or_Val ops[3], ret;
7049 struct tree_int_map **h = NULL;
7051 /* See if we've already saved the value for this node. */
7052 if (EXPR_P (gnu_size))
7054 struct tree_int_map in;
7055 if (!annotate_value_cache)
7056 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7057 tree_int_map_eq, 0);
7058 in.base.from = gnu_size;
7059 h = (struct tree_int_map **)
7060 htab_find_slot (annotate_value_cache, &in, INSERT);
7063 return (Node_Ref_Or_Val) (*h)->to;
7066 /* If we do not return inside this switch, TCODE will be set to the
7067 code to use for a Create_Node operand and LEN (set above) will be
7068 the number of recursive calls for us to make. */
7070 switch (TREE_CODE (gnu_size))
7073 if (TREE_OVERFLOW (gnu_size))
7076 /* This may have come from a conversion from some smaller type,
7077 so ensure this is in bitsizetype. */
7078 gnu_size = convert (bitsizetype, gnu_size);
7080 /* For negative values, use NEGATE_EXPR of the supplied value. */
7081 if (tree_int_cst_sgn (gnu_size) < 0)
7083 /* The ridiculous code below is to handle the case of the largest
7084 negative integer. */
7085 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
7086 bool adjust = false;
7089 if (TREE_OVERFLOW (negative_size))
7092 = size_binop (MINUS_EXPR, bitsize_zero_node,
7093 size_binop (PLUS_EXPR, gnu_size,
7098 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
7100 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
7102 return annotate_value (temp);
7105 if (!host_integerp (gnu_size, 1))
7108 size = tree_low_cst (gnu_size, 1);
7110 /* This peculiar test is to make sure that the size fits in an int
7111 on machines where HOST_WIDE_INT is not "int". */
7112 if (tree_low_cst (gnu_size, 1) == size)
7113 return UI_From_Int (size);
7118 /* The only case we handle here is a simple discriminant reference. */
7119 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7120 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7121 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7122 return Create_Node (Discrim_Val,
7123 annotate_value (DECL_DISCRIMINANT_NUMBER
7124 (TREE_OPERAND (gnu_size, 1))),
7129 CASE_CONVERT: case NON_LVALUE_EXPR:
7130 return annotate_value (TREE_OPERAND (gnu_size, 0));
7132 /* Now just list the operations we handle. */
7133 case COND_EXPR: tcode = Cond_Expr; break;
7134 case PLUS_EXPR: tcode = Plus_Expr; break;
7135 case MINUS_EXPR: tcode = Minus_Expr; break;
7136 case MULT_EXPR: tcode = Mult_Expr; break;
7137 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7138 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7139 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7140 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7141 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7142 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7143 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7144 case NEGATE_EXPR: tcode = Negate_Expr; break;
7145 case MIN_EXPR: tcode = Min_Expr; break;
7146 case MAX_EXPR: tcode = Max_Expr; break;
7147 case ABS_EXPR: tcode = Abs_Expr; break;
7148 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7149 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7150 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7151 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7152 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7153 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7154 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7155 case LT_EXPR: tcode = Lt_Expr; break;
7156 case LE_EXPR: tcode = Le_Expr; break;
7157 case GT_EXPR: tcode = Gt_Expr; break;
7158 case GE_EXPR: tcode = Ge_Expr; break;
7159 case EQ_EXPR: tcode = Eq_Expr; break;
7160 case NE_EXPR: tcode = Ne_Expr; break;
7164 tree t = maybe_inline_call_in_expr (gnu_size);
7166 return annotate_value (t);
7169 /* Fall through... */
7175 /* Now get each of the operands that's relevant for this code. If any
7176 cannot be expressed as a repinfo node, say we can't. */
7177 for (i = 0; i < 3; i++)
7180 for (i = 0; i < len; i++)
7182 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7183 if (ops[i] == No_Uint)
7187 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7189 /* Save the result in the cache. */
7192 *h = GGC_NEW (struct tree_int_map);
7193 (*h)->base.from = gnu_size;
7200 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7201 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7202 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7203 BY_REF is true if the object is used by reference. */
7206 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7210 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7211 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7213 gnu_type = TREE_TYPE (gnu_type);
7216 if (Unknown_Esize (gnat_entity))
7218 if (TREE_CODE (gnu_type) == RECORD_TYPE
7219 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7220 size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
7222 size = TYPE_SIZE (gnu_type);
7225 Set_Esize (gnat_entity, annotate_value (size));
7228 if (Unknown_Alignment (gnat_entity))
7229 Set_Alignment (gnat_entity,
7230 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7233 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7234 set Component_Bit_Offset and Esize of the components to the position and
7235 size used by Gigi. */
7238 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7240 Entity_Id gnat_field;
7243 /* We operate by first making a list of all fields and their position (we
7244 can get the size easily) and then update all the sizes in the tree. */
7246 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7247 BIGGEST_ALIGNMENT, NULL_TREE);
7249 for (gnat_field = First_Entity (gnat_entity);
7250 Present (gnat_field);
7251 gnat_field = Next_Entity (gnat_field))
7252 if (Ekind (gnat_field) == E_Component
7253 || (Ekind (gnat_field) == E_Discriminant
7254 && !Is_Unchecked_Union (Scope (gnat_field))))
7256 tree parent_offset, t;
7258 t = purpose_member (gnat_to_gnu_field_decl (gnat_field), gnu_list);
7261 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7263 /* In this mode the tag and parent components are not
7264 generated, so we add the appropriate offset to each
7265 component. For a component appearing in the current
7266 extension, the offset is the size of the parent. */
7267 if (Is_Derived_Type (gnat_entity)
7268 && Original_Record_Component (gnat_field) == gnat_field)
7270 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7273 parent_offset = bitsize_int (POINTER_SIZE);
7276 parent_offset = bitsize_zero_node;
7278 Set_Component_Bit_Offset
7281 (size_binop (PLUS_EXPR,
7282 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7283 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7286 Set_Esize (gnat_field,
7287 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7289 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7291 /* If there is no entry, this is an inherited component whose
7292 position is the same as in the parent type. */
7293 Set_Component_Bit_Offset
7295 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7297 Set_Esize (gnat_field,
7298 Esize (Original_Record_Component (gnat_field)));
7303 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7304 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7305 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7306 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7307 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7308 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7309 pre-existing list to be chained to the newly created entries. */
7312 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7313 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7317 for (gnu_field = TYPE_FIELDS (gnu_type);
7319 gnu_field = TREE_CHAIN (gnu_field))
7321 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7322 DECL_FIELD_BIT_OFFSET (gnu_field));
7323 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7324 DECL_FIELD_OFFSET (gnu_field));
7325 unsigned int our_offset_align
7326 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7327 tree v = make_tree_vec (3);
7329 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7330 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7331 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7332 gnu_list = tree_cons (gnu_field, v, gnu_list);
7334 /* Recurse on internal fields, flattening the nested fields except for
7335 those in the variant part, if requested. */
7336 if (DECL_INTERNAL_P (gnu_field))
7338 tree gnu_field_type = TREE_TYPE (gnu_field);
7339 if (do_not_flatten_variant
7340 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7342 = build_position_list (gnu_field_type, do_not_flatten_variant,
7343 size_zero_node, bitsize_zero_node,
7344 BIGGEST_ALIGNMENT, gnu_list);
7347 = build_position_list (gnu_field_type, do_not_flatten_variant,
7348 gnu_our_offset, gnu_our_bitpos,
7349 our_offset_align, gnu_list);
7356 /* Return a TREE_LIST describing the substitutions needed to reflect the
7357 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7358 be in any order. TREE_PURPOSE gives the tree for the discriminant and
7359 TREE_VALUE is the replacement value. They are in the form of operands
7360 to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
7364 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7366 tree gnu_list = NULL_TREE;
7367 Entity_Id gnat_discrim;
7370 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7371 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7372 Present (gnat_discrim);
7373 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7374 gnat_value = Next_Elmt (gnat_value))
7375 /* Ignore access discriminants. */
7376 if (!Is_Access_Type (Etype (Node (gnat_value))))
7378 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7379 gnu_list = tree_cons (gnu_field,
7380 convert (TREE_TYPE (gnu_field),
7381 elaborate_expression
7382 (Node (gnat_value), gnat_subtype,
7383 get_entity_name (gnat_discrim),
7384 definition, true, false)),
7391 /* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
7392 variants of QUAL_UNION_TYPE that are still relevant after applying the
7393 substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
7394 variant and TREE_VALUE is a TREE_VEC containing the field, the new value
7395 of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
7396 list to be chained to the newly created entries. */
7399 build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
7403 for (gnu_field = TYPE_FIELDS (qual_union_type);
7405 gnu_field = TREE_CHAIN (gnu_field))
7407 tree t, qual = DECL_QUALIFIER (gnu_field);
7409 for (t = subst_list; t; t = TREE_CHAIN (t))
7410 qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
7412 /* If the new qualifier is not unconditionally false, its variant may
7413 still be accessed. */
7414 if (!integer_zerop (qual))
7416 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7417 tree v = make_tree_vec (3);
7418 TREE_VEC_ELT (v, 0) = gnu_field;
7419 TREE_VEC_ELT (v, 1) = qual;
7420 TREE_VEC_ELT (v, 2) = NULL_TREE;
7421 gnu_list = tree_cons (variant_type, v, gnu_list);
7423 /* Recurse on the variant subpart of the variant, if any. */
7424 variant_subpart = get_variant_part (variant_type);
7425 if (variant_subpart)
7426 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
7427 subst_list, gnu_list);
7429 /* If the new qualifier is unconditionally true, the subsequent
7430 variants cannot be accessed. */
7431 if (integer_onep (qual))
7439 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7440 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
7441 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
7442 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7443 for the size of a field. COMPONENT_P is true if we are being called
7444 to process the Component_Size of GNAT_OBJECT. This is used for error
7445 message handling and to indicate to use the object size of GNU_TYPE.
7446 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7447 it means that a size of zero should be treated as an unspecified size. */
7450 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7451 enum tree_code kind, bool component_p, bool zero_ok)
7453 Node_Id gnat_error_node;
7454 tree type_size, size;
7456 if (kind == VAR_DECL
7457 /* If a type needs strict alignment, a component of this type in
7458 a packed record cannot be packed and thus uses the type size. */
7459 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7460 type_size = TYPE_SIZE (gnu_type);
7462 type_size = rm_size (gnu_type);
7464 /* Find the node to use for errors. */
7465 if ((Ekind (gnat_object) == E_Component
7466 || Ekind (gnat_object) == E_Discriminant)
7467 && Present (Component_Clause (gnat_object)))
7468 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7469 else if (Present (Size_Clause (gnat_object)))
7470 gnat_error_node = Expression (Size_Clause (gnat_object));
7472 gnat_error_node = gnat_object;
7474 /* Return 0 if no size was specified, either because Esize was not Present
7475 or the specified size was zero. */
7476 if (No (uint_size) || uint_size == No_Uint)
7479 /* Get the size as a tree. Issue an error if a size was specified but
7480 cannot be represented in sizetype. */
7481 size = UI_To_gnu (uint_size, bitsizetype);
7482 if (TREE_OVERFLOW (size))
7484 post_error_ne (component_p ? "component size of & is too large"
7485 : "size of & is too large",
7486 gnat_error_node, gnat_object);
7490 /* Ignore a negative size since that corresponds to our back-annotation.
7491 Also ignore a zero size if it is not permitted. */
7492 if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
7495 /* The size of objects is always a multiple of a byte. */
7496 if (kind == VAR_DECL
7497 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7500 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7501 gnat_error_node, gnat_object);
7503 post_error_ne ("size for& is not a multiple of Storage_Unit",
7504 gnat_error_node, gnat_object);
7508 /* If this is an integral type or a packed array type, the front-end has
7509 verified the size, so we need not do it here (which would entail
7510 checking against the bounds). However, if this is an aliased object,
7511 it may not be smaller than the type of the object. */
7512 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7513 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7516 /* If the object is a record that contains a template, add the size of
7517 the template to the specified size. */
7518 if (TREE_CODE (gnu_type) == RECORD_TYPE
7519 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7520 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7522 /* Modify the size of the type to be that of the maximum size if it has a
7524 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7525 type_size = max_size (type_size, true);
7527 /* If this is an access type or a fat pointer, the minimum size is that given
7528 by the smallest integral mode that's valid for pointers. */
7529 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7531 enum machine_mode p_mode;
7533 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7534 !targetm.valid_pointer_mode (p_mode);
7535 p_mode = GET_MODE_WIDER_MODE (p_mode))
7538 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7541 /* If the size of the object is a constant, the new size must not be
7543 if (TREE_CODE (type_size) != INTEGER_CST
7544 || TREE_OVERFLOW (type_size)
7545 || tree_int_cst_lt (size, type_size))
7549 ("component size for& too small{, minimum allowed is ^}",
7550 gnat_error_node, gnat_object, type_size);
7552 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7553 gnat_error_node, gnat_object, type_size);
7555 if (kind == VAR_DECL && !component_p
7556 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7557 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7558 post_error_ne_tree_2
7559 ("\\size of ^ is not a multiple of alignment (^ bits)",
7560 gnat_error_node, gnat_object, rm_size (gnu_type),
7561 TYPE_ALIGN (gnu_type));
7563 else if (INTEGRAL_TYPE_P (gnu_type))
7564 post_error_ne ("\\size would be legal if & were not aliased!",
7565 gnat_error_node, gnat_object);
7573 /* Similarly, but both validate and process a value of RM size. This
7574 routine is only called for types. */
7577 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7579 /* Only issue an error if a Value_Size clause was explicitly given.
7580 Otherwise, we'd be duplicating an error on the Size clause. */
7581 Node_Id gnat_attr_node
7582 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7583 tree old_size = rm_size (gnu_type), size;
7585 /* Do nothing if no size was specified, either because RM size was not
7586 Present or if the specified size was zero. */
7587 if (No (uint_size) || uint_size == No_Uint)
7590 /* Get the size as a tree. Issue an error if a size was specified but
7591 cannot be represented in sizetype. */
7592 size = UI_To_gnu (uint_size, bitsizetype);
7593 if (TREE_OVERFLOW (size))
7595 if (Present (gnat_attr_node))
7596 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7601 /* Ignore a negative size since that corresponds to our back-annotation.
7602 Also ignore a zero size unless a Value_Size clause exists, or a size
7603 clause exists, or this is an integer type, in which case the front-end
7604 will have always set it. */
7605 if (tree_int_cst_sgn (size) < 0
7606 || (integer_zerop (size)
7607 && No (gnat_attr_node)
7608 && !Has_Size_Clause (gnat_entity)
7609 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7612 /* If the old size is self-referential, get the maximum size. */
7613 if (CONTAINS_PLACEHOLDER_P (old_size))
7614 old_size = max_size (old_size, true);
7616 /* If the size of the object is a constant, the new size must not be smaller
7617 (the front-end has verified this for scalar and packed array types). */
7618 if (TREE_CODE (old_size) != INTEGER_CST
7619 || TREE_OVERFLOW (old_size)
7620 || (AGGREGATE_TYPE_P (gnu_type)
7621 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
7622 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
7623 && !(TYPE_IS_PADDING_P (gnu_type)
7624 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
7625 && TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
7626 && tree_int_cst_lt (size, old_size)))
7628 if (Present (gnat_attr_node))
7630 ("Value_Size for& too small{, minimum allowed is ^}",
7631 gnat_attr_node, gnat_entity, old_size);
7635 /* Otherwise, set the RM size proper for integral types... */
7636 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
7637 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7638 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7639 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
7640 SET_TYPE_RM_SIZE (gnu_type, size);
7642 /* ...or the Ada size for record and union types. */
7643 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7644 || TREE_CODE (gnu_type) == UNION_TYPE
7645 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7646 && !TYPE_FAT_POINTER_P (gnu_type))
7647 SET_TYPE_ADA_SIZE (gnu_type, size);
7650 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7651 If TYPE is the best type, return it. Otherwise, make a new type. We
7652 only support new integral and pointer types. FOR_BIASED is true if
7653 we are making a biased type. */
7656 make_type_from_size (tree type, tree size_tree, bool for_biased)
7658 unsigned HOST_WIDE_INT size;
7662 /* If size indicates an error, just return TYPE to avoid propagating
7663 the error. Likewise if it's too large to represent. */
7664 if (!size_tree || !host_integerp (size_tree, 1))
7667 size = tree_low_cst (size_tree, 1);
7669 switch (TREE_CODE (type))
7674 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7675 && TYPE_BIASED_REPRESENTATION_P (type));
7677 /* Only do something if the type is not a packed array type and
7678 doesn't already have the proper size. */
7679 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7680 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7683 biased_p |= for_biased;
7684 if (size > LONG_LONG_TYPE_SIZE)
7685 size = LONG_LONG_TYPE_SIZE;
7687 if (TYPE_UNSIGNED (type) || biased_p)
7688 new_type = make_unsigned_type (size);
7690 new_type = make_signed_type (size);
7691 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7692 SET_TYPE_RM_MIN_VALUE (new_type,
7693 convert (TREE_TYPE (new_type),
7694 TYPE_MIN_VALUE (type)));
7695 SET_TYPE_RM_MAX_VALUE (new_type,
7696 convert (TREE_TYPE (new_type),
7697 TYPE_MAX_VALUE (type)));
7698 /* Propagate the name to avoid creating a fake subrange type. */
7699 if (TYPE_NAME (type))
7701 if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL)
7702 TYPE_NAME (new_type) = DECL_NAME (TYPE_NAME (type));
7704 TYPE_NAME (new_type) = TYPE_NAME (type);
7706 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7707 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
7711 /* Do something if this is a fat pointer, in which case we
7712 may need to return the thin pointer. */
7713 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7715 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7716 if (!targetm.valid_pointer_mode (p_mode))
7719 build_pointer_type_for_mode
7720 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7726 /* Only do something if this is a thin pointer, in which case we
7727 may need to return the fat pointer. */
7728 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7730 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7740 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7741 a type or object whose present alignment is ALIGN. If this alignment is
7742 valid, return it. Otherwise, give an error and return ALIGN. */
7745 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7747 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7748 unsigned int new_align;
7749 Node_Id gnat_error_node;
7751 /* Don't worry about checking alignment if alignment was not specified
7752 by the source program and we already posted an error for this entity. */
7753 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7756 /* Post the error on the alignment clause if any. Note, for the implicit
7757 base type of an array type, the alignment clause is on the first
7759 if (Present (Alignment_Clause (gnat_entity)))
7760 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7762 else if (Is_Itype (gnat_entity)
7763 && Is_Array_Type (gnat_entity)
7764 && Etype (gnat_entity) == gnat_entity
7765 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
7767 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
7770 gnat_error_node = gnat_entity;
7772 /* Within GCC, an alignment is an integer, so we must make sure a value is
7773 specified that fits in that range. Also, there is an upper bound to
7774 alignments we can support/allow. */
7775 if (!UI_Is_In_Int_Range (alignment)
7776 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7777 post_error_ne_num ("largest supported alignment for& is ^",
7778 gnat_error_node, gnat_entity, max_allowed_alignment);
7779 else if (!(Present (Alignment_Clause (gnat_entity))
7780 && From_At_Mod (Alignment_Clause (gnat_entity)))
7781 && new_align * BITS_PER_UNIT < align)
7783 unsigned int double_align;
7784 bool is_capped_double, align_clause;
7786 /* If the default alignment of "double" or larger scalar types is
7787 specifically capped and the new alignment is above the cap, do
7788 not post an error and change the alignment only if there is an
7789 alignment clause; this makes it possible to have the associated
7790 GCC type overaligned by default for performance reasons. */
7791 if ((double_align = double_float_alignment) > 0)
7794 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7796 = is_double_float_or_array (gnat_type, &align_clause);
7798 else if ((double_align = double_scalar_alignment) > 0)
7801 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7803 = is_double_scalar_or_array (gnat_type, &align_clause);
7806 is_capped_double = align_clause = false;
7808 if (is_capped_double && new_align >= double_align)
7811 align = new_align * BITS_PER_UNIT;
7815 if (is_capped_double)
7816 align = double_align * BITS_PER_UNIT;
7818 post_error_ne_num ("alignment for& must be at least ^",
7819 gnat_error_node, gnat_entity,
7820 align / BITS_PER_UNIT);
7825 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7826 if (new_align > align)
7833 /* Return the smallest alignment not less than SIZE. */
7836 ceil_alignment (unsigned HOST_WIDE_INT size)
7838 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7841 /* Verify that OBJECT, a type or decl, is something we can implement
7842 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7843 if we require atomic components. */
7846 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7848 Node_Id gnat_error_point = gnat_entity;
7850 enum machine_mode mode;
7854 /* There are three case of what OBJECT can be. It can be a type, in which
7855 case we take the size, alignment and mode from the type. It can be a
7856 declaration that was indirect, in which case the relevant values are
7857 that of the type being pointed to, or it can be a normal declaration,
7858 in which case the values are of the decl. The code below assumes that
7859 OBJECT is either a type or a decl. */
7860 if (TYPE_P (object))
7862 /* If this is an anonymous base type, nothing to check. Error will be
7863 reported on the source type. */
7864 if (!Comes_From_Source (gnat_entity))
7867 mode = TYPE_MODE (object);
7868 align = TYPE_ALIGN (object);
7869 size = TYPE_SIZE (object);
7871 else if (DECL_BY_REF_P (object))
7873 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7874 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7875 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7879 mode = DECL_MODE (object);
7880 align = DECL_ALIGN (object);
7881 size = DECL_SIZE (object);
7884 /* Consider all floating-point types atomic and any types that that are
7885 represented by integers no wider than a machine word. */
7886 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7887 || ((GET_MODE_CLASS (mode) == MODE_INT
7888 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7889 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7892 /* For the moment, also allow anything that has an alignment equal
7893 to its size and which is smaller than a word. */
7894 if (size && TREE_CODE (size) == INTEGER_CST
7895 && compare_tree_int (size, align) == 0
7896 && align <= BITS_PER_WORD)
7899 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7900 gnat_node = Next_Rep_Item (gnat_node))
7902 if (!comp_p && Nkind (gnat_node) == N_Pragma
7903 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7905 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7906 else if (comp_p && Nkind (gnat_node) == N_Pragma
7907 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7908 == Pragma_Atomic_Components))
7909 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7913 post_error_ne ("atomic access to component of & cannot be guaranteed",
7914 gnat_error_point, gnat_entity);
7916 post_error_ne ("atomic access to & cannot be guaranteed",
7917 gnat_error_point, gnat_entity);
7920 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7921 have compatible signatures so that a call using one type may be safely
7922 issued if the actual target function type is the other. Return 1 if it is
7923 the case, 0 otherwise, and post errors on the incompatibilities.
7925 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7926 that calls to the subprogram will have arguments suitable for the later
7927 underlying builtin expansion. */
7930 compatible_signatures_p (tree ftype1, tree ftype2)
7932 /* As of now, we only perform very trivial tests and consider it's the
7933 programmer's responsibility to ensure the type correctness in the Ada
7934 declaration, as in the regular Import cases.
7936 Mismatches typically result in either error messages from the builtin
7937 expander, internal compiler errors, or in a real call sequence. This
7938 should be refined to issue diagnostics helping error detection and
7941 /* Almost fake test, ensuring a use of each argument. */
7942 if (ftype1 == ftype2)
7948 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
7949 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
7950 specified size for this field. POS_LIST is a position list describing
7951 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
7955 create_field_decl_from (tree old_field, tree field_type, tree record_type,
7956 tree size, tree pos_list, tree subst_list)
7958 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
7959 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
7960 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
7961 tree new_pos, new_field;
7963 if (CONTAINS_PLACEHOLDER_P (pos))
7964 for (t = subst_list; t; t = TREE_CHAIN (t))
7965 pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
7967 /* If the position is now a constant, we can set it as the position of the
7968 field when we make it. Otherwise, we need to deal with it specially. */
7969 if (TREE_CONSTANT (pos))
7970 new_pos = bit_from_pos (pos, bitpos);
7972 new_pos = NULL_TREE;
7975 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
7976 DECL_PACKED (old_field), size, new_pos,
7977 !DECL_NONADDRESSABLE_P (old_field));
7981 normalize_offset (&pos, &bitpos, offset_align);
7982 DECL_FIELD_OFFSET (new_field) = pos;
7983 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
7984 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
7985 DECL_SIZE (new_field) = size;
7986 DECL_SIZE_UNIT (new_field)
7987 = convert (sizetype,
7988 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
7989 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
7992 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
7993 t = DECL_ORIGINAL_FIELD (old_field);
7994 SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
7995 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
7996 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8001 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8004 get_rep_part (tree record_type)
8006 tree field = TYPE_FIELDS (record_type);
8008 /* The REP part is the first field, internal, another record, and its name
8009 doesn't start with an underscore (i.e. is not generated by the FE). */
8010 if (DECL_INTERNAL_P (field)
8011 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8012 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8018 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8021 get_variant_part (tree record_type)
8025 /* The variant part is the only internal field that is a qualified union. */
8026 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
8027 if (DECL_INTERNAL_P (field)
8028 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8034 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8035 the list of variants to be used and RECORD_TYPE is the type of the parent.
8036 POS_LIST is a position list describing the layout of fields present in
8037 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8041 create_variant_part_from (tree old_variant_part, tree variant_list,
8042 tree record_type, tree pos_list, tree subst_list)
8044 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8045 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8046 tree old_union_type = TREE_TYPE (old_variant_part);
8047 tree new_union_type, new_variant_part, t;
8048 tree union_field_list = NULL_TREE;
8050 /* First create the type of the variant part from that of the old one. */
8051 new_union_type = make_node (QUAL_UNION_TYPE);
8052 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8054 /* If the position of the variant part is constant, subtract it from the
8055 size of the type of the parent to get the new size. This manual CSE
8056 reduces the code size when not optimizing. */
8057 if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
8059 tree first_bit = bit_from_pos (offset, bitpos);
8060 TYPE_SIZE (new_union_type)
8061 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8062 TYPE_SIZE_UNIT (new_union_type)
8063 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8064 byte_from_pos (offset, bitpos));
8065 SET_TYPE_ADA_SIZE (new_union_type,
8066 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8068 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8069 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8072 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8074 /* Now finish up the new variants and populate the union type. */
8075 for (t = variant_list; t; t = TREE_CHAIN (t))
8077 tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
8078 tree old_variant, old_variant_subpart, new_variant, field_list;
8080 /* Skip variants that don't belong to this nesting level. */
8081 if (DECL_CONTEXT (old_field) != old_union_type)
8084 /* Retrieve the list of fields already added to the new variant. */
8085 new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
8086 field_list = TYPE_FIELDS (new_variant);
8088 /* If the old variant had a variant subpart, we need to create a new
8089 variant subpart and add it to the field list. */
8090 old_variant = TREE_PURPOSE (t);
8091 old_variant_subpart = get_variant_part (old_variant);
8092 if (old_variant_subpart)
8094 tree new_variant_subpart
8095 = create_variant_part_from (old_variant_subpart, variant_list,
8096 new_variant, pos_list, subst_list);
8097 TREE_CHAIN (new_variant_subpart) = field_list;
8098 field_list = new_variant_subpart;
8101 /* Finish up the new variant and create the field. */
8102 finish_record_type (new_variant, nreverse (field_list), 2, true);
8103 compute_record_mode (new_variant);
8104 rest_of_record_type_compilation (new_variant);
8106 /* No need for debug info thanks to the XVS type. */
8107 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8108 true, false, Empty);
8111 = create_field_decl_from (old_field, new_variant, new_union_type,
8112 TYPE_SIZE (new_variant),
8113 pos_list, subst_list);
8114 DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
8115 DECL_INTERNAL_P (new_field) = 1;
8116 TREE_CHAIN (new_field) = union_field_list;
8117 union_field_list = new_field;
8120 /* Finish up the union type and create the variant part. */
8121 finish_record_type (new_union_type, union_field_list, 2, true);
8122 compute_record_mode (new_union_type);
8123 rest_of_record_type_compilation (new_union_type);
8125 /* No need for debug info thanks to the XVS type. */
8126 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8127 true, false, Empty);
8130 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8131 TYPE_SIZE (new_union_type),
8132 pos_list, subst_list);
8133 DECL_INTERNAL_P (new_variant_part) = 1;
8135 /* With multiple discriminants it is possible for an inner variant to be
8136 statically selected while outer ones are not; in this case, the list
8137 of fields of the inner variant is not flattened and we end up with a
8138 qualified union with a single member. Drop the useless container. */
8139 if (!TREE_CHAIN (union_field_list))
8141 DECL_CONTEXT (union_field_list) = record_type;
8142 DECL_FIELD_OFFSET (union_field_list)
8143 = DECL_FIELD_OFFSET (new_variant_part);
8144 DECL_FIELD_BIT_OFFSET (union_field_list)
8145 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8146 SET_DECL_OFFSET_ALIGN (union_field_list,
8147 DECL_OFFSET_ALIGN (new_variant_part));
8148 new_variant_part = union_field_list;
8151 return new_variant_part;
8154 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8155 which are both RECORD_TYPE, after applying the substitutions described
8159 copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
8163 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8164 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8165 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8166 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8167 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8169 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8170 for (t = subst_list; t; t = TREE_CHAIN (t))
8171 TYPE_SIZE (new_type)
8172 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8176 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8177 for (t = subst_list; t; t = TREE_CHAIN (t))
8178 TYPE_SIZE_UNIT (new_type)
8179 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8183 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8184 for (t = subst_list; t; t = TREE_CHAIN (t))
8186 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8190 /* Finalize the size. */
8191 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8192 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8195 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8196 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8197 updated by replacing F with R.
8199 The function doesn't update the layout of the type, i.e. it assumes
8200 that the substitution is purely formal. That's why the replacement
8201 value R must itself contain a PLACEHOLDER_EXPR. */
8204 substitute_in_type (tree t, tree f, tree r)
8208 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8210 switch (TREE_CODE (t))
8217 /* First the domain types of arrays. */
8218 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8219 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8221 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8222 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8224 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8228 TYPE_GCC_MIN_VALUE (nt) = low;
8229 TYPE_GCC_MAX_VALUE (nt) = high;
8231 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8233 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8238 /* Then the subtypes. */
8239 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8240 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8242 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8243 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8245 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8249 SET_TYPE_RM_MIN_VALUE (nt, low);
8250 SET_TYPE_RM_MAX_VALUE (nt, high);
8258 nt = substitute_in_type (TREE_TYPE (t), f, r);
8259 if (nt == TREE_TYPE (t))
8262 return build_complex_type (nt);
8268 /* These should never show up here. */
8273 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8274 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8276 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8279 nt = build_array_type (component, domain);
8280 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8281 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8282 SET_TYPE_MODE (nt, TYPE_MODE (t));
8283 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8284 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8285 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8286 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8287 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8293 case QUAL_UNION_TYPE:
8295 bool changed_field = false;
8298 /* Start out with no fields, make new fields, and chain them
8299 in. If we haven't actually changed the type of any field,
8300 discard everything we've done and return the old type. */
8302 TYPE_FIELDS (nt) = NULL_TREE;
8304 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
8306 tree new_field = copy_node (field), new_n;
8308 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8309 if (new_n != TREE_TYPE (field))
8311 TREE_TYPE (new_field) = new_n;
8312 changed_field = true;
8315 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8316 if (new_n != DECL_FIELD_OFFSET (field))
8318 DECL_FIELD_OFFSET (new_field) = new_n;
8319 changed_field = true;
8322 /* Do the substitution inside the qualifier, if any. */
8323 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8325 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8326 if (new_n != DECL_QUALIFIER (field))
8328 DECL_QUALIFIER (new_field) = new_n;
8329 changed_field = true;
8333 DECL_CONTEXT (new_field) = nt;
8334 SET_DECL_ORIGINAL_FIELD (new_field,
8335 (DECL_ORIGINAL_FIELD (field)
8336 ? DECL_ORIGINAL_FIELD (field) : field));
8338 TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
8339 TYPE_FIELDS (nt) = new_field;
8345 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8346 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8347 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8348 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8357 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8358 needed to represent the object. */
8361 rm_size (tree gnu_type)
8363 /* For integral types, we store the RM size explicitly. */
8364 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8365 return TYPE_RM_SIZE (gnu_type);
8367 /* Return the RM size of the actual data plus the size of the template. */
8368 if (TREE_CODE (gnu_type) == RECORD_TYPE
8369 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8371 size_binop (PLUS_EXPR,
8372 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
8373 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8375 /* For record types, we store the size explicitly. */
8376 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8377 || TREE_CODE (gnu_type) == UNION_TYPE
8378 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8379 && !TYPE_FAT_POINTER_P (gnu_type)
8380 && TYPE_ADA_SIZE (gnu_type))
8381 return TYPE_ADA_SIZE (gnu_type);
8383 /* For other types, this is just the size. */
8384 return TYPE_SIZE (gnu_type);
8387 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8388 fully-qualified name, possibly with type information encoding.
8389 Otherwise, return the name. */
8392 get_entity_name (Entity_Id gnat_entity)
8394 Get_Encoded_Name (gnat_entity);
8395 return get_identifier_with_length (Name_Buffer, Name_Len);
8398 /* Return an identifier representing the external name to be used for
8399 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8400 and the specified suffix. */
8403 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8405 Entity_Kind kind = Ekind (gnat_entity);
8409 String_Template temp = {1, strlen (suffix)};
8410 Fat_Pointer fp = {suffix, &temp};
8411 Get_External_Name_With_Suffix (gnat_entity, fp);
8414 Get_External_Name (gnat_entity, 0);
8416 /* A variable using the Stdcall convention lives in a DLL. We adjust
8417 its name to use the jump table, the _imp__NAME contains the address
8418 for the NAME variable. */
8419 if ((kind == E_Variable || kind == E_Constant)
8420 && Has_Stdcall_Convention (gnat_entity))
8422 const int len = 6 + Name_Len;
8423 char *new_name = (char *) alloca (len + 1);
8424 strcpy (new_name, "_imp__");
8425 strcat (new_name, Name_Buffer);
8426 return get_identifier_with_length (new_name, len);
8429 return get_identifier_with_length (Name_Buffer, Name_Len);
8432 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8433 string, return a new IDENTIFIER_NODE that is the concatenation of
8434 the name followed by "___" and the specified suffix. */
8437 concat_name (tree gnu_name, const char *suffix)
8439 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8440 char *new_name = (char *) alloca (len + 1);
8441 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8442 strcat (new_name, "___");
8443 strcat (new_name, suffix);
8444 return get_identifier_with_length (new_name, len);
8447 #include "gt-ada-decl.h"
OSDN Git Service
