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 (tree, Entity_Id);
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, attr_list,
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 (tem, gnat_entity))
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 (gnu_type, gnat_entity))
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 (gnu_type, gnat_entity))
2567 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2568 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2572 /* Record Types and Subtypes
2574 The following fields are defined on record types:
2576 Has_Discriminants True if the record has discriminants
2577 First_Discriminant Points to head of list of discriminants
2578 First_Entity Points to head of list of fields
2579 Is_Tagged_Type True if the record is tagged
2581 Implementation of Ada records and discriminated records:
2583 A record type definition is transformed into the equivalent of a C
2584 struct definition. The fields that are the discriminants which are
2585 found in the Full_Type_Declaration node and the elements of the
2586 Component_List found in the Record_Type_Definition node. The
2587 Component_List can be a recursive structure since each Variant of
2588 the Variant_Part of the Component_List has a Component_List.
2590 Processing of a record type definition comprises starting the list of
2591 field declarations here from the discriminants and the calling the
2592 function components_to_record to add the rest of the fields from the
2593 component list and return the gnu type node. The function
2594 components_to_record will call itself recursively as it traverses
2598 if (Has_Complex_Representation (gnat_entity))
2601 = build_complex_type
2603 (Etype (Defining_Entity
2604 (First (Component_Items
2607 (Declaration_Node (gnat_entity)))))))));
2613 Node_Id full_definition = Declaration_Node (gnat_entity);
2614 Node_Id record_definition = Type_Definition (full_definition);
2615 Entity_Id gnat_field;
2616 tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
2617 /* Set PACKED in keeping with gnat_to_gnu_field. */
2619 = Is_Packed (gnat_entity)
2621 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2623 : (Known_Alignment (gnat_entity)
2624 || (Strict_Alignment (gnat_entity)
2625 && Known_Static_Esize (gnat_entity)))
2628 bool has_discr = Has_Discriminants (gnat_entity);
2629 bool has_rep = Has_Specified_Layout (gnat_entity);
2630 bool all_rep = has_rep;
2632 = (Is_Tagged_Type (gnat_entity)
2633 && Nkind (record_definition) == N_Derived_Type_Definition);
2634 bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
2636 /* See if all fields have a rep clause. Stop when we find one
2639 for (gnat_field = First_Entity (gnat_entity);
2640 Present (gnat_field);
2641 gnat_field = Next_Entity (gnat_field))
2642 if ((Ekind (gnat_field) == E_Component
2643 || Ekind (gnat_field) == E_Discriminant)
2644 && No (Component_Clause (gnat_field)))
2650 /* If this is a record extension, go a level further to find the
2651 record definition. Also, verify we have a Parent_Subtype. */
2654 if (!type_annotate_only
2655 || Present (Record_Extension_Part (record_definition)))
2656 record_definition = Record_Extension_Part (record_definition);
2658 gcc_assert (type_annotate_only
2659 || Present (Parent_Subtype (gnat_entity)));
2662 /* Make a node for the record. If we are not defining the record,
2663 suppress expanding incomplete types. */
2664 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2665 TYPE_NAME (gnu_type) = gnu_entity_name;
2666 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2670 defer_incomplete_level++;
2671 this_deferred = true;
2674 /* If both a size and rep clause was specified, put the size in
2675 the record type now so that it can get the proper mode. */
2676 if (has_rep && Known_Esize (gnat_entity))
2677 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2679 /* Always set the alignment here so that it can be used to
2680 set the mode, if it is making the alignment stricter. If
2681 it is invalid, it will be checked again below. If this is to
2682 be Atomic, choose a default alignment of a word unless we know
2683 the size and it's smaller. */
2684 if (Known_Alignment (gnat_entity))
2685 TYPE_ALIGN (gnu_type)
2686 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2687 else if (Is_Atomic (gnat_entity))
2688 TYPE_ALIGN (gnu_type)
2689 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2690 /* If a type needs strict alignment, the minimum size will be the
2691 type size instead of the RM size (see validate_size). Cap the
2692 alignment, lest it causes this type size to become too large. */
2693 else if (Strict_Alignment (gnat_entity)
2694 && Known_Static_Esize (gnat_entity))
2696 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2697 unsigned int raw_align = raw_size & -raw_size;
2698 if (raw_align < BIGGEST_ALIGNMENT)
2699 TYPE_ALIGN (gnu_type) = raw_align;
2702 TYPE_ALIGN (gnu_type) = 0;
2704 /* If we have a Parent_Subtype, make a field for the parent. If
2705 this record has rep clauses, force the position to zero. */
2706 if (Present (Parent_Subtype (gnat_entity)))
2708 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2711 /* A major complexity here is that the parent subtype will
2712 reference our discriminants in its Discriminant_Constraint
2713 list. But those must reference the parent component of this
2714 record which is of the parent subtype we have not built yet!
2715 To break the circle we first build a dummy COMPONENT_REF which
2716 represents the "get to the parent" operation and initialize
2717 each of those discriminants to a COMPONENT_REF of the above
2718 dummy parent referencing the corresponding discriminant of the
2719 base type of the parent subtype. */
2720 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2721 build0 (PLACEHOLDER_EXPR, gnu_type),
2722 build_decl (input_location,
2723 FIELD_DECL, NULL_TREE,
2728 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2729 Present (gnat_field);
2730 gnat_field = Next_Stored_Discriminant (gnat_field))
2731 if (Present (Corresponding_Discriminant (gnat_field)))
2734 = gnat_to_gnu_field_decl (Corresponding_Discriminant
2738 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2739 gnu_get_parent, gnu_field, NULL_TREE),
2743 /* Then we build the parent subtype. If it has discriminants but
2744 the type itself has unknown discriminants, this means that it
2745 doesn't contain information about how the discriminants are
2746 derived from those of the ancestor type, so it cannot be used
2747 directly. Instead it is built by cloning the parent subtype
2748 of the underlying record view of the type, for which the above
2749 derivation of discriminants has been made explicit. */
2750 if (Has_Discriminants (gnat_parent)
2751 && Has_Unknown_Discriminants (gnat_entity))
2753 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2755 /* If we are defining the type, the underlying record
2756 view must already have been elaborated at this point.
2757 Otherwise do it now as its parent subtype cannot be
2758 technically elaborated on its own. */
2760 gcc_assert (present_gnu_tree (gnat_uview));
2762 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2764 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2766 /* Substitute the "get to the parent" of the type for that
2767 of its underlying record view in the cloned type. */
2768 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2769 Present (gnat_field);
2770 gnat_field = Next_Stored_Discriminant (gnat_field))
2771 if (Present (Corresponding_Discriminant (gnat_field)))
2773 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2775 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2776 gnu_get_parent, gnu_field, NULL_TREE);
2778 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2782 gnu_parent = gnat_to_gnu_type (gnat_parent);
2784 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2785 initially built. The discriminants must reference the fields
2786 of the parent subtype and not those of its base type for the
2787 placeholder machinery to properly work. */
2790 /* The actual parent subtype is the full view. */
2791 if (IN (Ekind (gnat_parent), Private_Kind))
2793 if (Present (Full_View (gnat_parent)))
2794 gnat_parent = Full_View (gnat_parent);
2796 gnat_parent = Underlying_Full_View (gnat_parent);
2799 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2800 Present (gnat_field);
2801 gnat_field = Next_Stored_Discriminant (gnat_field))
2802 if (Present (Corresponding_Discriminant (gnat_field)))
2804 Entity_Id field = Empty;
2805 for (field = First_Stored_Discriminant (gnat_parent);
2807 field = Next_Stored_Discriminant (field))
2808 if (same_discriminant_p (gnat_field, field))
2810 gcc_assert (Present (field));
2811 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2812 = gnat_to_gnu_field_decl (field);
2816 /* The "get to the parent" COMPONENT_REF must be given its
2818 TREE_TYPE (gnu_get_parent) = gnu_parent;
2820 /* ...and reference the _Parent field of this record. */
2822 = create_field_decl (get_identifier
2823 (Get_Name_String (Name_uParent)),
2824 gnu_parent, gnu_type, 0,
2826 ? TYPE_SIZE (gnu_parent) : NULL_TREE,
2828 ? bitsize_zero_node : NULL_TREE, 1);
2829 DECL_INTERNAL_P (gnu_field) = 1;
2830 TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
2831 TYPE_FIELDS (gnu_type) = gnu_field;
2834 /* Make the fields for the discriminants and put them into the record
2835 unless it's an Unchecked_Union. */
2837 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2838 Present (gnat_field);
2839 gnat_field = Next_Stored_Discriminant (gnat_field))
2841 /* If this is a record extension and this discriminant is the
2842 renaming of another discriminant, we've handled it above. */
2843 if (Present (Parent_Subtype (gnat_entity))
2844 && Present (Corresponding_Discriminant (gnat_field)))
2848 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
2851 /* Make an expression using a PLACEHOLDER_EXPR from the
2852 FIELD_DECL node just created and link that with the
2853 corresponding GNAT defining identifier. */
2854 save_gnu_tree (gnat_field,
2855 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2856 build0 (PLACEHOLDER_EXPR, gnu_type),
2857 gnu_field, NULL_TREE),
2860 if (!is_unchecked_union)
2862 TREE_CHAIN (gnu_field) = gnu_field_list;
2863 gnu_field_list = gnu_field;
2867 /* Add the fields into the record type and finish it up. */
2868 components_to_record (gnu_type, Component_List (record_definition),
2869 gnu_field_list, packed, definition, NULL,
2870 false, all_rep, false, is_unchecked_union,
2873 /* If it is a tagged record force the type to BLKmode to insure that
2874 these objects will always be put in memory. Likewise for limited
2876 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2877 SET_TYPE_MODE (gnu_type, BLKmode);
2879 /* We used to remove the associations of the discriminants and _Parent
2880 for validity checking but we may need them if there's a Freeze_Node
2881 for a subtype used in this record. */
2882 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2884 /* Fill in locations of fields. */
2885 annotate_rep (gnat_entity, gnu_type);
2887 /* If there are any entities in the chain corresponding to components
2888 that we did not elaborate, ensure we elaborate their types if they
2890 for (gnat_temp = First_Entity (gnat_entity);
2891 Present (gnat_temp);
2892 gnat_temp = Next_Entity (gnat_temp))
2893 if ((Ekind (gnat_temp) == E_Component
2894 || Ekind (gnat_temp) == E_Discriminant)
2895 && Is_Itype (Etype (gnat_temp))
2896 && !present_gnu_tree (gnat_temp))
2897 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2901 case E_Class_Wide_Subtype:
2902 /* If an equivalent type is present, that is what we should use.
2903 Otherwise, fall through to handle this like a record subtype
2904 since it may have constraints. */
2905 if (gnat_equiv_type != gnat_entity)
2907 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2908 maybe_present = true;
2912 /* ... fall through ... */
2914 case E_Record_Subtype:
2915 /* If Cloned_Subtype is Present it means this record subtype has
2916 identical layout to that type or subtype and we should use
2917 that GCC type for this one. The front end guarantees that
2918 the component list is shared. */
2919 if (Present (Cloned_Subtype (gnat_entity)))
2921 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2923 maybe_present = true;
2927 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2928 changing the type, make a new type with each field having the type of
2929 the field in the new subtype but the position computed by transforming
2930 every discriminant reference according to the constraints. We don't
2931 see any difference between private and non-private type here since
2932 derivations from types should have been deferred until the completion
2933 of the private type. */
2936 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2941 defer_incomplete_level++;
2942 this_deferred = true;
2945 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2947 if (present_gnu_tree (gnat_entity))
2949 maybe_present = true;
2953 /* When the subtype has discriminants and these discriminants affect
2954 the initial shape it has inherited, factor them in. But for an
2955 Unchecked_Union (it must be an Itype), just return the type.
2956 We can't just test Is_Constrained because private subtypes without
2957 discriminants of types with discriminants with default expressions
2958 are Is_Constrained but aren't constrained! */
2959 if (IN (Ekind (gnat_base_type), Record_Kind)
2960 && !Is_Unchecked_Union (gnat_base_type)
2961 && !Is_For_Access_Subtype (gnat_entity)
2962 && Is_Constrained (gnat_entity)
2963 && Has_Discriminants (gnat_entity)
2964 && Present (Discriminant_Constraint (gnat_entity))
2965 && Stored_Constraint (gnat_entity) != No_Elist)
2968 = build_subst_list (gnat_entity, gnat_base_type, definition);
2969 tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
2970 tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
2971 bool selected_variant = false;
2972 Entity_Id gnat_field;
2974 gnu_type = make_node (RECORD_TYPE);
2975 TYPE_NAME (gnu_type) = gnu_entity_name;
2977 /* Set the size, alignment and alias set of the new type to
2978 match that of the old one, doing required substitutions. */
2979 copy_and_substitute_in_size (gnu_type, gnu_base_type,
2982 if (TYPE_IS_PADDING_P (gnu_base_type))
2983 gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2985 gnu_unpad_base_type = gnu_base_type;
2987 /* Look for a REP part in the base type. */
2988 gnu_rep_part = get_rep_part (gnu_unpad_base_type);
2990 /* Look for a variant part in the base type. */
2991 gnu_variant_part = get_variant_part (gnu_unpad_base_type);
2993 /* If there is a variant part, we must compute whether the
2994 constraints statically select a particular variant. If
2995 so, we simply drop the qualified union and flatten the
2996 list of fields. Otherwise we'll build a new qualified
2997 union for the variants that are still relevant. */
2998 if (gnu_variant_part)
3001 = build_variant_list (TREE_TYPE (gnu_variant_part),
3002 gnu_subst_list, NULL_TREE);
3004 /* If all the qualifiers are unconditionally true, the
3005 innermost variant is statically selected. */
3006 selected_variant = true;
3007 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3008 if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
3010 selected_variant = false;
3014 /* Otherwise, create the new variants. */
3015 if (!selected_variant)
3016 for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
3018 tree old_variant = TREE_PURPOSE (t);
3019 tree new_variant = make_node (RECORD_TYPE);
3020 TYPE_NAME (new_variant)
3021 = DECL_NAME (TYPE_NAME (old_variant));
3022 copy_and_substitute_in_size (new_variant, old_variant,
3024 TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
3029 gnu_variant_list = NULL_TREE;
3030 selected_variant = false;
3034 = build_position_list (gnu_unpad_base_type,
3035 gnu_variant_list && !selected_variant,
3036 size_zero_node, bitsize_zero_node,
3037 BIGGEST_ALIGNMENT, NULL_TREE);
3039 for (gnat_field = First_Entity (gnat_entity);
3040 Present (gnat_field);
3041 gnat_field = Next_Entity (gnat_field))
3042 if ((Ekind (gnat_field) == E_Component
3043 || Ekind (gnat_field) == E_Discriminant)
3044 && !(Present (Corresponding_Discriminant (gnat_field))
3045 && Is_Tagged_Type (gnat_base_type))
3046 && Underlying_Type (Scope (Original_Record_Component
3050 Name_Id gnat_name = Chars (gnat_field);
3051 Entity_Id gnat_old_field
3052 = Original_Record_Component (gnat_field);
3054 = gnat_to_gnu_field_decl (gnat_old_field);
3055 tree gnu_context = DECL_CONTEXT (gnu_old_field);
3056 tree gnu_field, gnu_field_type, gnu_size;
3057 tree gnu_cont_type, gnu_last = NULL_TREE;
3059 /* If the type is the same, retrieve the GCC type from the
3060 old field to take into account possible adjustments. */
3061 if (Etype (gnat_field) == Etype (gnat_old_field))
3062 gnu_field_type = TREE_TYPE (gnu_old_field);
3064 gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
3066 /* If there was a component clause, the field types must be
3067 the same for the type and subtype, so copy the data from
3068 the old field to avoid recomputation here. Also if the
3069 field is justified modular and the optimization in
3070 gnat_to_gnu_field was applied. */
3071 if (Present (Component_Clause (gnat_old_field))
3072 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3073 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3074 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3075 == TREE_TYPE (gnu_old_field)))
3077 gnu_size = DECL_SIZE (gnu_old_field);
3078 gnu_field_type = TREE_TYPE (gnu_old_field);
3081 /* If the old field was packed and of constant size, we
3082 have to get the old size here, as it might differ from
3083 what the Etype conveys and the latter might overlap
3084 onto the following field. Try to arrange the type for
3085 possible better packing along the way. */
3086 else if (DECL_PACKED (gnu_old_field)
3087 && TREE_CODE (DECL_SIZE (gnu_old_field))
3090 gnu_size = DECL_SIZE (gnu_old_field);
3091 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3092 && !TYPE_FAT_POINTER_P (gnu_field_type)
3093 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3095 = make_packable_type (gnu_field_type, true);
3099 gnu_size = TYPE_SIZE (gnu_field_type);
3101 /* If the context of the old field is the base type or its
3102 REP part (if any), put the field directly in the new
3103 type; otherwise look up the context in the variant list
3104 and put the field either in the new type if there is a
3105 selected variant or in one of the new variants. */
3106 if (gnu_context == gnu_unpad_base_type
3108 && gnu_context == TREE_TYPE (gnu_rep_part)))
3109 gnu_cont_type = gnu_type;
3112 t = purpose_member (gnu_context, gnu_variant_list);
3115 if (selected_variant)
3116 gnu_cont_type = gnu_type;
3118 gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
3121 /* The front-end may pass us "ghost" components if
3122 it fails to recognize that a constrained subtype
3123 is statically constrained. Discard them. */
3127 /* Now create the new field modeled on the old one. */
3129 = create_field_decl_from (gnu_old_field, gnu_field_type,
3130 gnu_cont_type, gnu_size,
3131 gnu_pos_list, gnu_subst_list);
3133 /* Put it in one of the new variants directly. */
3134 if (gnu_cont_type != gnu_type)
3136 TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
3137 TYPE_FIELDS (gnu_cont_type) = gnu_field;
3140 /* To match the layout crafted in components_to_record,
3141 if this is the _Tag or _Parent field, put it before
3142 any other fields. */
3143 else if (gnat_name == Name_uTag
3144 || gnat_name == Name_uParent)
3145 gnu_field_list = chainon (gnu_field_list, gnu_field);
3147 /* Similarly, if this is the _Controller field, put
3148 it before the other fields except for the _Tag or
3150 else if (gnat_name == Name_uController && gnu_last)
3152 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
3153 TREE_CHAIN (gnu_last) = gnu_field;
3156 /* Otherwise, if this is a regular field, put it after
3157 the other fields. */
3160 TREE_CHAIN (gnu_field) = gnu_field_list;
3161 gnu_field_list = gnu_field;
3163 gnu_last = gnu_field;
3166 save_gnu_tree (gnat_field, gnu_field, false);
3169 /* If there is a variant list and no selected variant, we need
3170 to create the nest of variant parts from the old nest. */
3171 if (gnu_variant_list && !selected_variant)
3173 tree new_variant_part
3174 = create_variant_part_from (gnu_variant_part,
3175 gnu_variant_list, gnu_type,
3176 gnu_pos_list, gnu_subst_list);
3177 TREE_CHAIN (new_variant_part) = gnu_field_list;
3178 gnu_field_list = new_variant_part;
3181 /* Now go through the entities again looking for Itypes that
3182 we have not elaborated but should (e.g., Etypes of fields
3183 that have Original_Components). */
3184 for (gnat_field = First_Entity (gnat_entity);
3185 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3186 if ((Ekind (gnat_field) == E_Discriminant
3187 || Ekind (gnat_field) == E_Component)
3188 && !present_gnu_tree (Etype (gnat_field)))
3189 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3191 /* Do not finalize it since we're going to modify it below. */
3192 gnu_field_list = nreverse (gnu_field_list);
3193 finish_record_type (gnu_type, gnu_field_list, 2, true);
3195 /* See the E_Record_Type case for the rationale. */
3196 if (Is_Tagged_Type (gnat_entity)
3197 || Is_Limited_Record (gnat_entity))
3198 SET_TYPE_MODE (gnu_type, BLKmode);
3200 compute_record_mode (gnu_type);
3202 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3204 /* Fill in locations of fields. */
3205 annotate_rep (gnat_entity, gnu_type);
3207 /* If debugging information is being written for the type, write
3208 a record that shows what we are a subtype of and also make a
3209 variable that indicates our size, if still variable. */
3212 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3213 tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
3214 tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
3216 if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
3217 gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
3219 TYPE_NAME (gnu_subtype_marker)
3220 = create_concat_name (gnat_entity, "XVS");
3221 finish_record_type (gnu_subtype_marker,
3222 create_field_decl (gnu_unpad_base_name,
3223 build_reference_type
3224 (gnu_unpad_base_type),
3230 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3231 gnu_subtype_marker);
3234 && TREE_CODE (gnu_size_unit) != INTEGER_CST
3235 && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
3236 create_var_decl (create_concat_name (gnat_entity, "XVZ"),
3237 NULL_TREE, sizetype, gnu_size_unit, false,
3238 false, false, false, NULL, gnat_entity);
3241 /* Now we can finalize it. */
3242 rest_of_record_type_compilation (gnu_type);
3245 /* Otherwise, go down all the components in the new type and make
3246 them equivalent to those in the base type. */
3249 gnu_type = gnu_base_type;
3251 for (gnat_temp = First_Entity (gnat_entity);
3252 Present (gnat_temp);
3253 gnat_temp = Next_Entity (gnat_temp))
3254 if ((Ekind (gnat_temp) == E_Discriminant
3255 && !Is_Unchecked_Union (gnat_base_type))
3256 || Ekind (gnat_temp) == E_Component)
3257 save_gnu_tree (gnat_temp,
3258 gnat_to_gnu_field_decl
3259 (Original_Record_Component (gnat_temp)),
3265 case E_Access_Subprogram_Type:
3266 /* Use the special descriptor type for dispatch tables if needed,
3267 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3268 Note that we are only required to do so for static tables in
3269 order to be compatible with the C++ ABI, but Ada 2005 allows
3270 to extend library level tagged types at the local level so
3271 we do it in the non-static case as well. */
3272 if (TARGET_VTABLE_USES_DESCRIPTORS
3273 && Is_Dispatch_Table_Entity (gnat_entity))
3275 gnu_type = fdesc_type_node;
3276 gnu_size = TYPE_SIZE (gnu_type);
3280 /* ... fall through ... */
3282 case E_Anonymous_Access_Subprogram_Type:
3283 /* If we are not defining this entity, and we have incomplete
3284 entities being processed above us, make a dummy type and
3285 fill it in later. */
3286 if (!definition && defer_incomplete_level != 0)
3288 struct incomplete *p
3289 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3292 = build_pointer_type
3293 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3294 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3295 !Comes_From_Source (gnat_entity),
3296 debug_info_p, gnat_entity);
3297 this_made_decl = true;
3298 gnu_type = TREE_TYPE (gnu_decl);
3299 save_gnu_tree (gnat_entity, gnu_decl, false);
3302 p->old_type = TREE_TYPE (gnu_type);
3303 p->full_type = Directly_Designated_Type (gnat_entity);
3304 p->next = defer_incomplete_list;
3305 defer_incomplete_list = p;
3309 /* ... fall through ... */
3311 case E_Allocator_Type:
3313 case E_Access_Attribute_Type:
3314 case E_Anonymous_Access_Type:
3315 case E_General_Access_Type:
3317 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3318 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3319 bool is_from_limited_with
3320 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3321 && From_With_Type (gnat_desig_equiv));
3323 /* Get the "full view" of this entity. If this is an incomplete
3324 entity from a limited with, treat its non-limited view as the full
3325 view. Otherwise, if this is an incomplete or private type, use the
3326 full view. In the former case, we might point to a private type,
3327 in which case, we need its full view. Also, we want to look at the
3328 actual type used for the representation, so this takes a total of
3330 Entity_Id gnat_desig_full_direct_first
3331 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3332 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3333 ? Full_View (gnat_desig_equiv) : Empty));
3334 Entity_Id gnat_desig_full_direct
3335 = ((is_from_limited_with
3336 && Present (gnat_desig_full_direct_first)
3337 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3338 ? Full_View (gnat_desig_full_direct_first)
3339 : gnat_desig_full_direct_first);
3340 Entity_Id gnat_desig_full
3341 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3343 /* This the type actually used to represent the designated type,
3344 either gnat_desig_full or gnat_desig_equiv. */
3345 Entity_Id gnat_desig_rep;
3347 /* True if this is a pointer to an unconstrained array. */
3348 bool is_unconstrained_array;
3350 /* We want to know if we'll be seeing the freeze node for any
3351 incomplete type we may be pointing to. */
3353 = (Present (gnat_desig_full)
3354 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3355 : In_Extended_Main_Code_Unit (gnat_desig_type));
3357 /* True if we make a dummy type here. */
3358 bool got_fat_p = false;
3359 /* True if the dummy is a fat pointer. */
3360 bool made_dummy = false;
3361 tree gnu_desig_type = NULL_TREE;
3362 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3364 if (!targetm.valid_pointer_mode (p_mode))
3367 /* If either the designated type or its full view is an unconstrained
3368 array subtype, replace it with the type it's a subtype of. This
3369 avoids problems with multiple copies of unconstrained array types.
3370 Likewise, if the designated type is a subtype of an incomplete
3371 record type, use the parent type to avoid order of elaboration
3372 issues. This can lose some code efficiency, but there is no
3374 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3375 && ! Is_Constrained (gnat_desig_equiv))
3376 gnat_desig_equiv = Etype (gnat_desig_equiv);
3377 if (Present (gnat_desig_full)
3378 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3379 && ! Is_Constrained (gnat_desig_full))
3380 || (Ekind (gnat_desig_full) == E_Record_Subtype
3381 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3382 gnat_desig_full = Etype (gnat_desig_full);
3384 /* Now set the type that actually marks the representation of
3385 the designated type and also flag whether we have a unconstrained
3387 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3388 is_unconstrained_array
3389 = (Is_Array_Type (gnat_desig_rep)
3390 && ! Is_Constrained (gnat_desig_rep));
3392 /* If we are pointing to an incomplete type whose completion is an
3393 unconstrained array, make a fat pointer type. The two types in our
3394 fields will be pointers to dummy nodes and will be replaced in
3395 update_pointer_to. Similarly, if the type itself is a dummy type or
3396 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3397 in case we have any thin pointers to it. */
3398 if (is_unconstrained_array
3399 && (Present (gnat_desig_full)
3400 || (present_gnu_tree (gnat_desig_equiv)
3401 && TYPE_IS_DUMMY_P (TREE_TYPE
3402 (get_gnu_tree (gnat_desig_equiv))))
3403 || (No (gnat_desig_full) && ! in_main_unit
3404 && defer_incomplete_level != 0
3405 && ! present_gnu_tree (gnat_desig_equiv))
3406 || (in_main_unit && is_from_limited_with
3407 && Present (Freeze_Node (gnat_desig_rep)))))
3411 if (present_gnu_tree (gnat_desig_rep))
3412 gnu_old = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
3415 gnu_old = make_dummy_type (gnat_desig_rep);
3417 /* Show the dummy we get will be a fat pointer. */
3418 got_fat_p = made_dummy = true;
3421 /* If the call above got something that has a pointer, that
3422 pointer is our type. This could have happened either
3423 because the type was elaborated or because somebody
3424 else executed the code below. */
3425 gnu_type = TYPE_POINTER_TO (gnu_old);
3428 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3429 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3430 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3431 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3434 TYPE_NAME (gnu_template_type)
3435 = create_concat_name (gnat_desig_equiv, "XUB");
3436 TYPE_DUMMY_P (gnu_template_type) = 1;
3438 TYPE_NAME (gnu_array_type)
3439 = create_concat_name (gnat_desig_equiv, "XUA");
3440 TYPE_DUMMY_P (gnu_array_type) = 1;
3442 gnu_type = make_node (RECORD_TYPE);
3443 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3444 TYPE_POINTER_TO (gnu_old) = gnu_type;
3446 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3448 = chainon (chainon (NULL_TREE,
3450 (get_identifier ("P_ARRAY"),
3452 gnu_type, 0, 0, 0, 0)),
3453 create_field_decl (get_identifier ("P_BOUNDS"),
3455 gnu_type, 0, 0, 0, 0));
3457 /* Make sure we can place this into a register. */
3458 TYPE_ALIGN (gnu_type)
3459 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3460 TYPE_FAT_POINTER_P (gnu_type) = 1;
3462 /* Do not finalize this record type since the types of
3463 its fields are incomplete. */
3464 finish_record_type (gnu_type, fields, 0, true);
3466 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3467 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3468 = create_concat_name (gnat_desig_equiv, "XUT");
3469 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3473 /* If we already know what the full type is, use it. */
3474 else if (Present (gnat_desig_full)
3475 && present_gnu_tree (gnat_desig_full))
3476 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3478 /* Get the type of the thing we are to point to and build a pointer
3479 to it. If it is a reference to an incomplete or private type with a
3480 full view that is a record, make a dummy type node and get the
3481 actual type later when we have verified it is safe. */
3482 else if ((! in_main_unit
3483 && ! present_gnu_tree (gnat_desig_equiv)
3484 && Present (gnat_desig_full)
3485 && ! present_gnu_tree (gnat_desig_full)
3486 && Is_Record_Type (gnat_desig_full))
3487 /* Likewise if we are pointing to a record or array and we
3488 are to defer elaborating incomplete types. We do this
3489 since this access type may be the full view of some
3490 private type. Note that the unconstrained array case is
3492 || ((! in_main_unit || imported_p)
3493 && defer_incomplete_level != 0
3494 && ! present_gnu_tree (gnat_desig_equiv)
3495 && ((Is_Record_Type (gnat_desig_rep)
3496 || Is_Array_Type (gnat_desig_rep))))
3497 /* If this is a reference from a limited_with type back to our
3498 main unit and there's a Freeze_Node for it, either we have
3499 already processed the declaration and made the dummy type,
3500 in which case we just reuse the latter, or we have not yet,
3501 in which case we make the dummy type and it will be reused
3502 when the declaration is processed. In both cases, the
3503 pointer eventually created below will be automatically
3504 adjusted when the Freeze_Node is processed. Note that the
3505 unconstrained array case is handled above. */
3506 || (in_main_unit && is_from_limited_with
3507 && Present (Freeze_Node (gnat_desig_rep))))
3509 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3513 /* Otherwise handle the case of a pointer to itself. */
3514 else if (gnat_desig_equiv == gnat_entity)
3517 = build_pointer_type_for_mode (void_type_node, p_mode,
3518 No_Strict_Aliasing (gnat_entity));
3519 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3522 /* If expansion is disabled, the equivalent type of a concurrent
3523 type is absent, so build a dummy pointer type. */
3524 else if (type_annotate_only && No (gnat_desig_equiv))
3525 gnu_type = ptr_void_type_node;
3527 /* Finally, handle the straightforward case where we can just
3528 elaborate our designated type and point to it. */
3530 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3532 /* It is possible that a call to gnat_to_gnu_type above resolved our
3533 type. If so, just return it. */
3534 if (present_gnu_tree (gnat_entity))
3536 maybe_present = true;
3540 /* If we have a GCC type for the designated type, possibly modify it
3541 if we are pointing only to constant objects and then make a pointer
3542 to it. Don't do this for unconstrained arrays. */
3543 if (!gnu_type && gnu_desig_type)
3545 if (Is_Access_Constant (gnat_entity)
3546 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3549 = build_qualified_type
3551 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3553 /* Some extra processing is required if we are building a
3554 pointer to an incomplete type (in the GCC sense). We might
3555 have such a type if we just made a dummy, or directly out
3556 of the call to gnat_to_gnu_type above if we are processing
3557 an access type for a record component designating the
3558 record type itself. */
3559 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3561 /* We must ensure that the pointer to variant we make will
3562 be processed by update_pointer_to when the initial type
3563 is completed. Pretend we made a dummy and let further
3564 processing act as usual. */
3567 /* We must ensure that update_pointer_to will not retrieve
3568 the dummy variant when building a properly qualified
3569 version of the complete type. We take advantage of the
3570 fact that get_qualified_type is requiring TYPE_NAMEs to
3571 match to influence build_qualified_type and then also
3572 update_pointer_to here. */
3573 TYPE_NAME (gnu_desig_type)
3574 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3579 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3580 No_Strict_Aliasing (gnat_entity));
3583 /* If we are not defining this object and we made a dummy pointer,
3584 save our current definition, evaluate the actual type, and replace
3585 the tentative type we made with the actual one. If we are to defer
3586 actually looking up the actual type, make an entry in the
3587 deferred list. If this is from a limited with, we have to defer
3588 to the end of the current spec in two cases: first if the
3589 designated type is in the current unit and second if the access
3591 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3594 = TYPE_IS_FAT_POINTER_P (gnu_type)
3595 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3597 if (esize == POINTER_SIZE
3598 && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
3600 = build_pointer_type
3601 (TYPE_OBJECT_RECORD_TYPE
3602 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3604 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3605 !Comes_From_Source (gnat_entity),
3606 debug_info_p, gnat_entity);
3607 this_made_decl = true;
3608 gnu_type = TREE_TYPE (gnu_decl);
3609 save_gnu_tree (gnat_entity, gnu_decl, false);
3612 if (defer_incomplete_level == 0
3613 && ! (is_from_limited_with
3615 || In_Extended_Main_Code_Unit (gnat_entity))))
3616 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3617 gnat_to_gnu_type (gnat_desig_equiv));
3619 /* Note that the call to gnat_to_gnu_type here might have
3620 updated gnu_old_type directly, in which case it is not a
3621 dummy type any more when we get into update_pointer_to.
3623 This may happen for instance when the designated type is a
3624 record type, because their elaboration starts with an
3625 initial node from make_dummy_type, which may yield the same
3626 node as the one we got.
3628 Besides, variants of this non-dummy type might have been
3629 created along the way. update_pointer_to is expected to
3630 properly take care of those situations. */
3633 struct incomplete *p
3634 = (struct incomplete *) xmalloc (sizeof
3635 (struct incomplete));
3636 struct incomplete **head
3637 = (is_from_limited_with
3639 || In_Extended_Main_Code_Unit (gnat_entity))
3640 ? &defer_limited_with : &defer_incomplete_list);
3642 p->old_type = gnu_old_type;
3643 p->full_type = gnat_desig_equiv;
3651 case E_Access_Protected_Subprogram_Type:
3652 case E_Anonymous_Access_Protected_Subprogram_Type:
3653 if (type_annotate_only && No (gnat_equiv_type))
3654 gnu_type = ptr_void_type_node;
3657 /* The runtime representation is the equivalent type. */
3658 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3659 maybe_present = true;
3662 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3663 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3664 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3665 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3666 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3671 case E_Access_Subtype:
3673 /* We treat this as identical to its base type; any constraint is
3674 meaningful only to the front end.
3676 The designated type must be elaborated as well, if it does
3677 not have its own freeze node. Designated (sub)types created
3678 for constrained components of records with discriminants are
3679 not frozen by the front end and thus not elaborated by gigi,
3680 because their use may appear before the base type is frozen,
3681 and because it is not clear that they are needed anywhere in
3682 Gigi. With the current model, there is no correct place where
3683 they could be elaborated. */
3685 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3686 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3687 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3688 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3689 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3691 /* If we are not defining this entity, and we have incomplete
3692 entities being processed above us, make a dummy type and
3693 elaborate it later. */
3694 if (!definition && defer_incomplete_level != 0)
3696 struct incomplete *p
3697 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3699 = build_pointer_type
3700 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3702 p->old_type = TREE_TYPE (gnu_ptr_type);
3703 p->full_type = Directly_Designated_Type (gnat_entity);
3704 p->next = defer_incomplete_list;
3705 defer_incomplete_list = p;
3707 else if (!IN (Ekind (Base_Type
3708 (Directly_Designated_Type (gnat_entity))),
3709 Incomplete_Or_Private_Kind))
3710 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3714 maybe_present = true;
3717 /* Subprogram Entities
3719 The following access functions are defined for subprograms (functions
3722 First_Formal The first formal parameter.
3723 Is_Imported Indicates that the subprogram has appeared in
3724 an INTERFACE or IMPORT pragma. For now we
3725 assume that the external language is C.
3726 Is_Exported Likewise but for an EXPORT pragma.
3727 Is_Inlined True if the subprogram is to be inlined.
3729 In addition for function subprograms we have:
3731 Etype Return type of the function.
3733 Each parameter is first checked by calling must_pass_by_ref on its
3734 type to determine if it is passed by reference. For parameters which
3735 are copied in, if they are Ada In Out or Out parameters, their return
3736 value becomes part of a record which becomes the return type of the
3737 function (C function - note that this applies only to Ada procedures
3738 so there is no Ada return type). Additional code to store back the
3739 parameters will be generated on the caller side. This transformation
3740 is done here, not in the front-end.
3742 The intended result of the transformation can be seen from the
3743 equivalent source rewritings that follow:
3745 struct temp {int a,b};
3746 procedure P (A,B: In Out ...) is temp P (int A,B)
3749 end P; return {A,B};
3756 For subprogram types we need to perform mainly the same conversions to
3757 GCC form that are needed for procedures and function declarations. The
3758 only difference is that at the end, we make a type declaration instead
3759 of a function declaration. */
3761 case E_Subprogram_Type:
3765 /* The first GCC parameter declaration (a PARM_DECL node). The
3766 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3767 actually is the head of this parameter list. */
3768 tree gnu_param_list = NULL_TREE;
3769 /* Likewise for the stub associated with an exported procedure. */
3770 tree gnu_stub_param_list = NULL_TREE;
3771 /* The type returned by a function. If the subprogram is a procedure
3772 this type should be void_type_node. */
3773 tree gnu_return_type = void_type_node;
3774 /* List of fields in return type of procedure with copy-in copy-out
3776 tree gnu_field_list = NULL_TREE;
3777 /* Non-null for subprograms containing parameters passed by copy-in
3778 copy-out (Ada In Out or Out parameters not passed by reference),
3779 in which case it is the list of nodes used to specify the values of
3780 the in out/out parameters that are returned as a record upon
3781 procedure return. The TREE_PURPOSE of an element of this list is
3782 a field of the record and the TREE_VALUE is the PARM_DECL
3783 corresponding to that field. This list will be saved in the
3784 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3785 tree gnu_return_list = NULL_TREE;
3786 /* If an import pragma asks to map this subprogram to a GCC builtin,
3787 this is the builtin DECL node. */
3788 tree gnu_builtin_decl = NULL_TREE;
3789 /* For the stub associated with an exported procedure. */
3790 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3791 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3792 Entity_Id gnat_param;
3793 bool inline_flag = Is_Inlined (gnat_entity);
3794 bool public_flag = Is_Public (gnat_entity) || imported_p;
3796 = (Is_Public (gnat_entity) && !definition) || imported_p;
3798 /* The semantics of "pure" in Ada essentially matches that of "const"
3799 in the back-end. In particular, both properties are orthogonal to
3800 the "nothrow" property if the EH circuitry is explicit in the
3801 internal representation of the back-end. If we are to completely
3802 hide the EH circuitry from it, we need to declare that calls to pure
3803 Ada subprograms that can throw have side effects since they can
3804 trigger an "abnormal" transfer of control flow; thus they can be
3805 neither "const" nor "pure" in the back-end sense. */
3807 = (Exception_Mechanism == Back_End_Exceptions
3808 && Is_Pure (gnat_entity));
3810 bool volatile_flag = No_Return (gnat_entity);
3811 bool returns_by_ref = false;
3812 bool returns_unconstrained = false;
3813 bool returns_by_target_ptr = false;
3814 bool has_copy_in_out = false;
3815 bool has_stub = false;
3818 /* A parameter may refer to this type, so defer completion of any
3819 incomplete types. */
3820 if (kind == E_Subprogram_Type && !definition)
3822 defer_incomplete_level++;
3823 this_deferred = true;
3826 /* If the subprogram has an alias, it is probably inherited, so
3827 we can use the original one. If the original "subprogram"
3828 is actually an enumeration literal, it may be the first use
3829 of its type, so we must elaborate that type now. */
3830 if (Present (Alias (gnat_entity)))
3832 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3833 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3835 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3838 /* Elaborate any Itypes in the parameters of this entity. */
3839 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3840 Present (gnat_temp);
3841 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3842 if (Is_Itype (Etype (gnat_temp)))
3843 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3848 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3849 corresponding DECL node.
3851 We still want the parameter associations to take place because the
3852 proper generation of calls depends on it (a GNAT parameter without
3853 a corresponding GCC tree has a very specific meaning), so we don't
3855 if (Convention (gnat_entity) == Convention_Intrinsic)
3856 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3858 /* ??? What if we don't find the builtin node above ? warn ? err ?
3859 In the current state we neither warn nor err, and calls will just
3860 be handled as for regular subprograms. */
3862 if (kind == E_Function || kind == E_Subprogram_Type)
3863 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3865 /* If this function returns by reference, make the actual
3866 return type of this function the pointer and mark the decl. */
3867 if (Returns_By_Ref (gnat_entity))
3869 returns_by_ref = true;
3870 gnu_return_type = build_pointer_type (gnu_return_type);
3873 /* If the Mechanism is By_Reference, ensure the return type uses
3874 the machine's by-reference mechanism, which may not the same
3875 as above (e.g., it might be by passing a fake parameter). */
3876 else if (kind == E_Function
3877 && Mechanism (gnat_entity) == By_Reference)
3879 TREE_ADDRESSABLE (gnu_return_type) = 1;
3881 /* We expect this bit to be reset by gigi shortly, so can avoid a
3882 type node copy here. This actually also prevents troubles with
3883 the generation of debug information for the function, because
3884 we might have issued such info for this type already, and would
3885 be attaching a distinct type node to the function if we made a
3889 /* If we are supposed to return an unconstrained array,
3890 actually return a fat pointer and make a note of that. Return
3891 a pointer to an unconstrained record of variable size. */
3892 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3894 gnu_return_type = TREE_TYPE (gnu_return_type);
3895 returns_unconstrained = true;
3898 /* If the type requires a transient scope, the result is allocated
3899 on the secondary stack, so the result type of the function is
3901 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3903 gnu_return_type = build_pointer_type (gnu_return_type);
3904 returns_unconstrained = true;
3907 /* If the type is a padded type and the underlying type would not
3908 be passed by reference or this function has a foreign convention,
3909 return the underlying type. */
3910 else if (TYPE_IS_PADDING_P (gnu_return_type)
3911 && (!default_pass_by_ref (TREE_TYPE
3912 (TYPE_FIELDS (gnu_return_type)))
3913 || Has_Foreign_Convention (gnat_entity)))
3914 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3916 /* If the return type has a non-constant size, we convert the function
3917 into a procedure and its caller will pass a pointer to an object as
3918 the first parameter when we call the function. This can happen for
3919 an unconstrained type with a maximum size or a constrained type with
3920 a size not known at compile time. */
3921 if (TYPE_SIZE_UNIT (gnu_return_type)
3922 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3924 returns_by_target_ptr = true;
3926 = create_param_decl (get_identifier ("TARGET"),
3927 build_reference_type (gnu_return_type),
3929 gnu_return_type = void_type_node;
3932 /* If the return type has a size that overflows, we cannot have
3933 a function that returns that type. This usage doesn't make
3934 sense anyway, so give an error here. */
3935 if (TYPE_SIZE_UNIT (gnu_return_type)
3936 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3937 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3939 post_error ("cannot return type whose size overflows",
3941 gnu_return_type = copy_node (gnu_return_type);
3942 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3943 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3944 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3945 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3948 /* Look at all our parameters and get the type of
3949 each. While doing this, build a copy-out structure if
3952 /* Loop over the parameters and get their associated GCC tree.
3953 While doing this, build a copy-out structure if we need one. */
3954 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3955 Present (gnat_param);
3956 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3958 tree gnu_param_name = get_entity_name (gnat_param);
3959 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3960 tree gnu_param, gnu_field;
3961 bool copy_in_copy_out = false;
3962 Mechanism_Type mech = Mechanism (gnat_param);
3964 /* Builtins are expanded inline and there is no real call sequence
3965 involved. So the type expected by the underlying expander is
3966 always the type of each argument "as is". */
3967 if (gnu_builtin_decl)
3969 /* Handle the first parameter of a valued procedure specially. */
3970 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3971 mech = By_Copy_Return;
3972 /* Otherwise, see if a Mechanism was supplied that forced this
3973 parameter to be passed one way or another. */
3974 else if (mech == Default
3975 || mech == By_Copy || mech == By_Reference)
3977 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3978 mech = By_Descriptor;
3980 else if (By_Short_Descriptor_Last <= mech &&
3981 mech <= By_Short_Descriptor)
3982 mech = By_Short_Descriptor;
3986 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3987 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3988 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3990 mech = By_Reference;
3996 post_error ("unsupported mechanism for&", gnat_param);
4001 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
4002 Has_Foreign_Convention (gnat_entity),
4005 /* We are returned either a PARM_DECL or a type if no parameter
4006 needs to be passed; in either case, adjust the type. */
4007 if (DECL_P (gnu_param))
4008 gnu_param_type = TREE_TYPE (gnu_param);
4011 gnu_param_type = gnu_param;
4012 gnu_param = NULL_TREE;
4017 /* If it's an exported subprogram, we build a parameter list
4018 in parallel, in case we need to emit a stub for it. */
4019 if (Is_Exported (gnat_entity))
4022 = chainon (gnu_param, gnu_stub_param_list);
4023 /* Change By_Descriptor parameter to By_Reference for
4024 the internal version of an exported subprogram. */
4025 if (mech == By_Descriptor || mech == By_Short_Descriptor)
4028 = gnat_to_gnu_param (gnat_param, By_Reference,
4034 gnu_param = copy_node (gnu_param);
4037 gnu_param_list = chainon (gnu_param, gnu_param_list);
4038 Sloc_to_locus (Sloc (gnat_param),
4039 &DECL_SOURCE_LOCATION (gnu_param));
4040 save_gnu_tree (gnat_param, gnu_param, false);
4042 /* If a parameter is a pointer, this function may modify
4043 memory through it and thus shouldn't be considered
4044 a const function. Also, the memory may be modified
4045 between two calls, so they can't be CSE'ed. The latter
4046 case also handles by-ref parameters. */
4047 if (POINTER_TYPE_P (gnu_param_type)
4048 || TYPE_IS_FAT_POINTER_P (gnu_param_type))
4052 if (copy_in_copy_out)
4054 if (!has_copy_in_out)
4056 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
4057 gnu_return_type = make_node (RECORD_TYPE);
4058 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4059 has_copy_in_out = true;
4062 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
4063 gnu_return_type, 0, 0, 0, 0);
4064 Sloc_to_locus (Sloc (gnat_param),
4065 &DECL_SOURCE_LOCATION (gnu_field));
4066 TREE_CHAIN (gnu_field) = gnu_field_list;
4067 gnu_field_list = gnu_field;
4068 gnu_return_list = tree_cons (gnu_field, gnu_param,
4073 /* Do not compute record for out parameters if subprogram is
4074 stubbed since structures are incomplete for the back-end. */
4075 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
4076 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4079 /* If we have a CICO list but it has only one entry, we convert
4080 this function into a function that simply returns that one
4082 if (list_length (gnu_return_list) == 1)
4083 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
4085 if (Has_Stdcall_Convention (gnat_entity))
4086 prepend_one_attribute_to
4087 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4088 get_identifier ("stdcall"), NULL_TREE,
4091 /* If we are on a target where stack realignment is needed for 'main'
4092 to honor GCC's implicit expectations (stack alignment greater than
4093 what the base ABI guarantees), ensure we do the same for foreign
4094 convention subprograms as they might be used as callbacks from code
4095 breaking such expectations. Note that this applies to task entry
4096 points in particular. */
4097 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4098 && Has_Foreign_Convention (gnat_entity))
4099 prepend_one_attribute_to
4100 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4101 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4104 /* The lists have been built in reverse. */
4105 gnu_param_list = nreverse (gnu_param_list);
4107 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4108 gnu_return_list = nreverse (gnu_return_list);
4110 if (Ekind (gnat_entity) == E_Function)
4111 Set_Mechanism (gnat_entity,
4112 (returns_by_ref || returns_unconstrained
4113 ? By_Reference : By_Copy));
4115 = create_subprog_type (gnu_return_type, gnu_param_list,
4116 gnu_return_list, returns_unconstrained,
4117 returns_by_ref, returns_by_target_ptr);
4121 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4122 gnu_return_list, returns_unconstrained,
4123 returns_by_ref, returns_by_target_ptr);
4125 /* A subprogram (something that doesn't return anything) shouldn't
4126 be considered const since there would be no reason for such a
4127 subprogram. Note that procedures with Out (or In Out) parameters
4128 have already been converted into a function with a return type. */
4129 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4133 = build_qualified_type (gnu_type,
4134 TYPE_QUALS (gnu_type)
4135 | (TYPE_QUAL_CONST * const_flag)
4136 | (TYPE_QUAL_VOLATILE * volatile_flag));
4138 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4142 = build_qualified_type (gnu_stub_type,
4143 TYPE_QUALS (gnu_stub_type)
4144 | (TYPE_QUAL_CONST * const_flag)
4145 | (TYPE_QUAL_VOLATILE * volatile_flag));
4147 /* If we have a builtin decl for that function, check the signatures
4148 compatibilities. If the signatures are compatible, use the builtin
4149 decl. If they are not, we expect the checker predicate to have
4150 posted the appropriate errors, and just continue with what we have
4152 if (gnu_builtin_decl)
4154 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4156 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4158 gnu_decl = gnu_builtin_decl;
4159 gnu_type = gnu_builtin_type;
4164 /* If there was no specified Interface_Name and the external and
4165 internal names of the subprogram are the same, only use the
4166 internal name to allow disambiguation of nested subprograms. */
4167 if (No (Interface_Name (gnat_entity))
4168 && gnu_ext_name == gnu_entity_name)
4169 gnu_ext_name = NULL_TREE;
4171 /* If we are defining the subprogram and it has an Address clause
4172 we must get the address expression from the saved GCC tree for the
4173 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4174 the address expression here since the front-end has guaranteed
4175 in that case that the elaboration has no effects. If there is
4176 an Address clause and we are not defining the object, just
4177 make it a constant. */
4178 if (Present (Address_Clause (gnat_entity)))
4180 tree gnu_address = NULL_TREE;
4184 = (present_gnu_tree (gnat_entity)
4185 ? get_gnu_tree (gnat_entity)
4186 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4188 save_gnu_tree (gnat_entity, NULL_TREE, false);
4190 /* Convert the type of the object to a reference type that can
4191 alias everything as per 13.3(19). */
4193 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4195 gnu_address = convert (gnu_type, gnu_address);
4198 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4199 gnu_address, false, Is_Public (gnat_entity),
4200 extern_flag, false, NULL, gnat_entity);
4201 DECL_BY_REF_P (gnu_decl) = 1;
4204 else if (kind == E_Subprogram_Type)
4205 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4206 !Comes_From_Source (gnat_entity),
4207 debug_info_p, gnat_entity);
4212 gnu_stub_name = gnu_ext_name;
4213 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4214 public_flag = false;
4217 gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4218 gnu_type, gnu_param_list,
4219 inline_flag, public_flag,
4220 extern_flag, attr_list,
4225 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4226 gnu_stub_type, gnu_stub_param_list,
4228 extern_flag, attr_list,
4230 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4233 /* This is unrelated to the stub built right above. */
4234 DECL_STUBBED_P (gnu_decl)
4235 = Convention (gnat_entity) == Convention_Stubbed;
4240 case E_Incomplete_Type:
4241 case E_Incomplete_Subtype:
4242 case E_Private_Type:
4243 case E_Private_Subtype:
4244 case E_Limited_Private_Type:
4245 case E_Limited_Private_Subtype:
4246 case E_Record_Type_With_Private:
4247 case E_Record_Subtype_With_Private:
4249 /* Get the "full view" of this entity. If this is an incomplete
4250 entity from a limited with, treat its non-limited view as the
4251 full view. Otherwise, use either the full view or the underlying
4252 full view, whichever is present. This is used in all the tests
4255 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4256 && From_With_Type (gnat_entity))
4257 ? Non_Limited_View (gnat_entity)
4258 : Present (Full_View (gnat_entity))
4259 ? Full_View (gnat_entity)
4260 : Underlying_Full_View (gnat_entity);
4262 /* If this is an incomplete type with no full view, it must be a Taft
4263 Amendment type, in which case we return a dummy type. Otherwise,
4264 just get the type from its Etype. */
4267 if (kind == E_Incomplete_Type)
4269 gnu_type = make_dummy_type (gnat_entity);
4270 gnu_decl = TYPE_STUB_DECL (gnu_type);
4274 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4276 maybe_present = true;
4281 /* If we already made a type for the full view, reuse it. */
4282 else if (present_gnu_tree (full_view))
4284 gnu_decl = get_gnu_tree (full_view);
4288 /* Otherwise, if we are not defining the type now, get the type
4289 from the full view. But always get the type from the full view
4290 for define on use types, since otherwise we won't see them! */
4291 else if (!definition
4292 || (Is_Itype (full_view)
4293 && No (Freeze_Node (gnat_entity)))
4294 || (Is_Itype (gnat_entity)
4295 && No (Freeze_Node (full_view))))
4297 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4298 maybe_present = true;
4302 /* For incomplete types, make a dummy type entry which will be
4303 replaced later. Save it as the full declaration's type so
4304 we can do any needed updates when we see it. */
4305 gnu_type = make_dummy_type (gnat_entity);
4306 gnu_decl = TYPE_STUB_DECL (gnu_type);
4307 save_gnu_tree (full_view, gnu_decl, 0);
4311 /* Simple class_wide types are always viewed as their root_type
4312 by Gigi unless an Equivalent_Type is specified. */
4313 case E_Class_Wide_Type:
4314 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4315 maybe_present = true;
4319 case E_Task_Subtype:
4320 case E_Protected_Type:
4321 case E_Protected_Subtype:
4322 if (type_annotate_only && No (gnat_equiv_type))
4323 gnu_type = void_type_node;
4325 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4327 maybe_present = true;
4331 gnu_decl = create_label_decl (gnu_entity_name);
4336 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4337 we've already saved it, so we don't try to. */
4338 gnu_decl = error_mark_node;
4346 /* If we had a case where we evaluated another type and it might have
4347 defined this one, handle it here. */
4348 if (maybe_present && present_gnu_tree (gnat_entity))
4350 gnu_decl = get_gnu_tree (gnat_entity);
4354 /* If we are processing a type and there is either no decl for it or
4355 we just made one, do some common processing for the type, such as
4356 handling alignment and possible padding. */
4357 if (is_type && (!gnu_decl || this_made_decl))
4359 if (Is_Tagged_Type (gnat_entity)
4360 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4361 TYPE_ALIGN_OK (gnu_type) = 1;
4363 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4364 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4366 /* ??? Don't set the size for a String_Literal since it is either
4367 confirming or we don't handle it properly (if the low bound is
4369 if (!gnu_size && kind != E_String_Literal_Subtype)
4370 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4372 Has_Size_Clause (gnat_entity));
4374 /* If a size was specified, see if we can make a new type of that size
4375 by rearranging the type, for example from a fat to a thin pointer. */
4379 = make_type_from_size (gnu_type, gnu_size,
4380 Has_Biased_Representation (gnat_entity));
4382 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4383 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4387 /* If the alignment hasn't already been processed and this is
4388 not an unconstrained array, see if an alignment is specified.
4389 If not, we pick a default alignment for atomic objects. */
4390 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4392 else if (Known_Alignment (gnat_entity))
4394 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4395 TYPE_ALIGN (gnu_type));
4397 /* Warn on suspiciously large alignments. This should catch
4398 errors about the (alignment,byte)/(size,bit) discrepancy. */
4399 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4403 /* If a size was specified, take it into account. Otherwise
4404 use the RM size for records as the type size has already
4405 been adjusted to the alignment. */
4408 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4409 || TREE_CODE (gnu_type) == UNION_TYPE
4410 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4411 && !TYPE_FAT_POINTER_P (gnu_type))
4412 size = rm_size (gnu_type);
4414 size = TYPE_SIZE (gnu_type);
4416 /* Consider an alignment as suspicious if the alignment/size
4417 ratio is greater or equal to the byte/bit ratio. */
4418 if (host_integerp (size, 1)
4419 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4420 post_error_ne ("?suspiciously large alignment specified for&",
4421 Expression (Alignment_Clause (gnat_entity)),
4425 else if (Is_Atomic (gnat_entity) && !gnu_size
4426 && host_integerp (TYPE_SIZE (gnu_type), 1)
4427 && integer_pow2p (TYPE_SIZE (gnu_type)))
4428 align = MIN (BIGGEST_ALIGNMENT,
4429 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4430 else if (Is_Atomic (gnat_entity) && gnu_size
4431 && host_integerp (gnu_size, 1)
4432 && integer_pow2p (gnu_size))
4433 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4435 /* See if we need to pad the type. If we did, and made a record,
4436 the name of the new type may be changed. So get it back for
4437 us when we make the new TYPE_DECL below. */
4438 if (gnu_size || align > 0)
4439 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4440 false, !gnu_decl, definition, false);
4442 if (TYPE_IS_PADDING_P (gnu_type))
4444 gnu_entity_name = TYPE_NAME (gnu_type);
4445 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4446 gnu_entity_name = DECL_NAME (gnu_entity_name);
4449 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4451 /* If we are at global level, GCC will have applied variable_size to
4452 the type, but that won't have done anything. So, if it's not
4453 a constant or self-referential, call elaborate_expression_1 to
4454 make a variable for the size rather than calculating it each time.
4455 Handle both the RM size and the actual size. */
4456 if (global_bindings_p ()
4457 && TYPE_SIZE (gnu_type)
4458 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4459 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4461 if (TREE_CODE (gnu_type) == RECORD_TYPE
4462 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4463 TYPE_SIZE (gnu_type), 0))
4465 TYPE_SIZE (gnu_type)
4466 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4467 gnat_entity, get_identifier ("SIZE"),
4469 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4473 TYPE_SIZE (gnu_type)
4474 = elaborate_expression_1 (TYPE_SIZE (gnu_type),
4475 gnat_entity, get_identifier ("SIZE"),
4478 /* ??? For now, store the size as a multiple of the alignment
4479 in bytes so that we can see the alignment from the tree. */
4480 TYPE_SIZE_UNIT (gnu_type)
4482 (MULT_EXPR, sizetype,
4483 elaborate_expression_1
4484 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4485 TYPE_SIZE_UNIT (gnu_type),
4486 size_int (TYPE_ALIGN (gnu_type)
4488 gnat_entity, get_identifier ("SIZE_A_UNIT"),
4490 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4492 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4495 elaborate_expression_1 (TYPE_ADA_SIZE (gnu_type),
4497 get_identifier ("RM_SIZE"),
4498 definition, false));
4502 /* If this is a record type or subtype, call elaborate_expression_1 on
4503 any field position. Do this for both global and local types.
4504 Skip any fields that we haven't made trees for to avoid problems with
4505 class wide types. */
4506 if (IN (kind, Record_Kind))
4507 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4508 gnat_temp = Next_Entity (gnat_temp))
4509 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4511 tree gnu_field = get_gnu_tree (gnat_temp);
4513 /* ??? Unfortunately, GCC needs to be able to prove the
4514 alignment of this offset and if it's a variable, it can't.
4515 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4516 right now, we have to put in an explicit multiply and
4517 divide by that value. */
4518 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4520 DECL_FIELD_OFFSET (gnu_field)
4522 (MULT_EXPR, sizetype,
4523 elaborate_expression_1
4524 (build_binary_op (EXACT_DIV_EXPR, sizetype,
4525 DECL_FIELD_OFFSET (gnu_field),
4526 size_int (DECL_OFFSET_ALIGN (gnu_field)
4528 gnat_temp, get_identifier ("OFFSET"),
4530 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4532 /* ??? The context of gnu_field is not necessarily gnu_type so
4533 the MULT_EXPR node built above may not be marked by the call
4534 to create_type_decl below. */
4535 if (global_bindings_p ())
4536 MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
4540 if (Treat_As_Volatile (gnat_entity))
4542 = build_qualified_type (gnu_type,
4543 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
4545 if (Is_Atomic (gnat_entity))
4546 check_ok_for_atomic (gnu_type, gnat_entity, false);
4548 if (Present (Alignment_Clause (gnat_entity)))
4549 TYPE_USER_ALIGN (gnu_type) = 1;
4551 if (Universal_Aliasing (gnat_entity))
4552 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4555 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4556 !Comes_From_Source (gnat_entity),
4557 debug_info_p, gnat_entity);
4560 TREE_TYPE (gnu_decl) = gnu_type;
4561 TYPE_STUB_DECL (gnu_type) = gnu_decl;
4565 if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4567 gnu_type = TREE_TYPE (gnu_decl);
4569 /* If this is a derived type, relate its alias set to that of its parent
4570 to avoid troubles when a call to an inherited primitive is inlined in
4571 a context where a derived object is accessed. The inlined code works
4572 on the parent view so the resulting code may access the same object
4573 using both the parent and the derived alias sets, which thus have to
4574 conflict. As the same issue arises with component references, the
4575 parent alias set also has to conflict with composite types enclosing
4576 derived components. For instance, if we have:
4583 we want T to conflict with both D and R, in addition to R being a
4584 superset of D by record/component construction.
4586 One way to achieve this is to perform an alias set copy from the
4587 parent to the derived type. This is not quite appropriate, though,
4588 as we don't want separate derived types to conflict with each other:
4590 type I1 is new Integer;
4591 type I2 is new Integer;
4593 We want I1 and I2 to both conflict with Integer but we do not want
4594 I1 to conflict with I2, and an alias set copy on derivation would
4597 The option chosen is to make the alias set of the derived type a
4598 superset of that of its parent type. It trivially fulfills the
4599 simple requirement for the Integer derivation example above, and
4600 the component case as well by superset transitivity:
4603 R ----------> D ----------> T
4605 However, for composite types, conversions between derived types are
4606 translated into VIEW_CONVERT_EXPRs so a sequence like:
4608 type Comp1 is new Comp;
4609 type Comp2 is new Comp;
4610 procedure Proc (C : Comp1);
4618 Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
4620 and gimplified into:
4627 i.e. generates code involving type punning. Therefore, Comp1 needs
4628 to conflict with Comp2 and an alias set copy is required.
4630 The language rules ensure the parent type is already frozen here. */
4631 if (Is_Derived_Type (gnat_entity))
4633 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4634 relate_alias_sets (gnu_type, gnu_parent_type,
4635 Is_Composite_Type (gnat_entity)
4636 ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
4639 /* Back-annotate the Alignment of the type if not already in the
4640 tree. Likewise for sizes. */
4641 if (Unknown_Alignment (gnat_entity))
4643 unsigned int double_align, align;
4644 bool is_capped_double, align_clause;
4646 /* If the default alignment of "double" or larger scalar types is
4647 specifically capped and this is not an array with an alignment
4648 clause on the component type, return the cap. */
4649 if ((double_align = double_float_alignment) > 0)
4651 = is_double_float_or_array (gnat_entity, &align_clause);
4652 else if ((double_align = double_scalar_alignment) > 0)
4654 = is_double_scalar_or_array (gnat_entity, &align_clause);
4656 is_capped_double = align_clause = false;
4658 if (is_capped_double && !align_clause)
4659 align = double_align;
4661 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
4663 Set_Alignment (gnat_entity, UI_From_Int (align));
4666 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4668 /* If the size is self-referential, we annotate the maximum
4669 value of that size. */
4670 tree gnu_size = TYPE_SIZE (gnu_type);
4672 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4673 gnu_size = max_size (gnu_size, true);
4675 Set_Esize (gnat_entity, annotate_value (gnu_size));
4677 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4679 /* In this mode the tag and the parent components are not
4680 generated by the front-end, so the sizes must be adjusted
4682 int size_offset, new_size;
4684 if (Is_Derived_Type (gnat_entity))
4687 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4688 Set_Alignment (gnat_entity,
4689 Alignment (Etype (Base_Type (gnat_entity))));
4692 size_offset = POINTER_SIZE;
4694 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4695 Set_Esize (gnat_entity,
4696 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4697 / POINTER_SIZE) * POINTER_SIZE));
4698 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4702 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4703 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4706 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4707 DECL_ARTIFICIAL (gnu_decl) = 1;
4709 if (!debug_info_p && DECL_P (gnu_decl)
4710 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4711 && No (Renamed_Object (gnat_entity)))
4712 DECL_IGNORED_P (gnu_decl) = 1;
4714 /* If we haven't already, associate the ..._DECL node that we just made with
4715 the input GNAT entity node. */
4717 save_gnu_tree (gnat_entity, gnu_decl, false);
4719 /* If this is an enumeration or floating-point type, we were not able to set
4720 the bounds since they refer to the type. These are always static. */
4721 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4722 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4724 tree gnu_scalar_type = gnu_type;
4725 tree gnu_low_bound, gnu_high_bound;
4727 /* If this is a padded type, we need to use the underlying type. */
4728 if (TYPE_IS_PADDING_P (gnu_scalar_type))
4729 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4731 /* If this is a floating point type and we haven't set a floating
4732 point type yet, use this in the evaluation of the bounds. */
4733 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4734 longest_float_type_node = gnu_scalar_type;
4736 gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4737 gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
4739 if (kind == E_Enumeration_Type)
4741 /* Enumeration types have specific RM bounds. */
4742 SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
4743 SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
4745 /* Write full debugging information. Since this has both a
4746 typedef and a tag, avoid outputting the name twice. */
4747 DECL_ARTIFICIAL (gnu_decl) = 1;
4748 rest_of_type_decl_compilation (gnu_decl);
4753 /* Floating-point types don't have specific RM bounds. */
4754 TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
4755 TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
4759 /* If we deferred processing of incomplete types, re-enable it. If there
4760 were no other disables and we have some to process, do so. */
4761 if (this_deferred && --defer_incomplete_level == 0)
4763 if (defer_incomplete_list)
4765 struct incomplete *incp, *next;
4767 /* We are back to level 0 for the deferring of incomplete types.
4768 But processing these incomplete types below may itself require
4769 deferring, so preserve what we have and restart from scratch. */
4770 incp = defer_incomplete_list;
4771 defer_incomplete_list = NULL;
4773 /* For finalization, however, all types must be complete so we
4774 cannot do the same because deferred incomplete types may end up
4775 referencing each other. Process them all recursively first. */
4776 defer_finalize_level++;
4778 for (; incp; incp = next)
4783 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4784 gnat_to_gnu_type (incp->full_type));
4788 defer_finalize_level--;
4791 /* All the deferred incomplete types have been processed so we can
4792 now proceed with the finalization of the deferred types. */
4793 if (defer_finalize_level == 0 && defer_finalize_list)
4798 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4799 rest_of_type_decl_compilation_no_defer (t);
4801 VEC_free (tree, heap, defer_finalize_list);
4805 /* If we are not defining this type, see if it's in the incomplete list.
4806 If so, handle that list entry now. */
4807 else if (!definition)
4809 struct incomplete *incp;
4811 for (incp = defer_incomplete_list; incp; incp = incp->next)
4812 if (incp->old_type && incp->full_type == gnat_entity)
4814 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4815 TREE_TYPE (gnu_decl));
4816 incp->old_type = NULL_TREE;
4823 /* If this is a packed array type whose original array type is itself
4824 an Itype without freeze node, make sure the latter is processed. */
4825 if (Is_Packed_Array_Type (gnat_entity)
4826 && Is_Itype (Original_Array_Type (gnat_entity))
4827 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4828 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4829 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
4834 /* Similar, but if the returned value is a COMPONENT_REF, return the
4838 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4840 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4842 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4843 gnu_field = TREE_OPERAND (gnu_field, 1);
4848 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4849 the GCC type corresponding to that entity. */
4852 gnat_to_gnu_type (Entity_Id gnat_entity)
4856 /* The back end never attempts to annotate generic types. */
4857 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4858 return void_type_node;
4860 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4861 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4863 return TREE_TYPE (gnu_decl);
4866 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4867 the unpadded version of the GCC type corresponding to that entity. */
4870 get_unpadded_type (Entity_Id gnat_entity)
4872 tree type = gnat_to_gnu_type (gnat_entity);
4874 if (TYPE_IS_PADDING_P (type))
4875 type = TREE_TYPE (TYPE_FIELDS (type));
4880 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4881 Every TYPE_DECL generated for a type definition must be passed
4882 to this function once everything else has been done for it. */
4885 rest_of_type_decl_compilation (tree decl)
4887 /* We need to defer finalizing the type if incomplete types
4888 are being deferred or if they are being processed. */
4889 if (defer_incomplete_level || defer_finalize_level)
4890 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4892 rest_of_type_decl_compilation_no_defer (decl);
4895 /* Same as above but without deferring the compilation. This
4896 function should not be invoked directly on a TYPE_DECL. */
4899 rest_of_type_decl_compilation_no_defer (tree decl)
4901 const int toplev = global_bindings_p ();
4902 tree t = TREE_TYPE (decl);
4904 rest_of_decl_compilation (decl, toplev, 0);
4906 /* Now process all the variants. This is needed for STABS. */
4907 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4909 if (t == TREE_TYPE (decl))
4912 if (!TYPE_STUB_DECL (t))
4913 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
4915 rest_of_type_compilation (t, toplev);
4919 /* Finalize any From_With_Type incomplete types. We do this after processing
4920 our compilation unit and after processing its spec, if this is a body. */
4923 finalize_from_with_types (void)
4925 struct incomplete *incp = defer_limited_with;
4926 struct incomplete *next;
4928 defer_limited_with = 0;
4929 for (; incp; incp = next)
4933 if (incp->old_type != 0)
4934 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4935 gnat_to_gnu_type (incp->full_type));
4940 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4941 kind of type (such E_Task_Type) that has a different type which Gigi
4942 uses for its representation. If the type does not have a special type
4943 for its representation, return GNAT_ENTITY. If a type is supposed to
4944 exist, but does not, abort unless annotating types, in which case
4945 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4948 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4950 Entity_Id gnat_equiv = gnat_entity;
4952 if (No (gnat_entity))
4955 switch (Ekind (gnat_entity))
4957 case E_Class_Wide_Subtype:
4958 if (Present (Equivalent_Type (gnat_entity)))
4959 gnat_equiv = Equivalent_Type (gnat_entity);
4962 case E_Access_Protected_Subprogram_Type:
4963 case E_Anonymous_Access_Protected_Subprogram_Type:
4964 gnat_equiv = Equivalent_Type (gnat_entity);
4967 case E_Class_Wide_Type:
4968 gnat_equiv = Root_Type (gnat_entity);
4972 case E_Task_Subtype:
4973 case E_Protected_Type:
4974 case E_Protected_Subtype:
4975 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4982 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4986 /* Return a GCC tree for a type corresponding to the component type of the
4987 array type or subtype GNAT_ARRAY. DEFINITION is true if this component
4988 is for an array being defined. DEBUG_INFO_P is true if we need to write
4989 debug information for other types that we may create in the process. */
4992 gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
4995 tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
4998 /* Try to get a smaller form of the component if needed. */
4999 if ((Is_Packed (gnat_array)
5000 || Has_Component_Size_Clause (gnat_array))
5001 && !Is_Bit_Packed_Array (gnat_array)
5002 && !Has_Aliased_Components (gnat_array)
5003 && !Strict_Alignment (Component_Type (gnat_array))
5004 && TREE_CODE (gnu_type) == RECORD_TYPE
5005 && !TYPE_FAT_POINTER_P (gnu_type)
5006 && host_integerp (TYPE_SIZE (gnu_type), 1))
5007 gnu_type = make_packable_type (gnu_type, false);
5009 if (Has_Atomic_Components (gnat_array))
5010 check_ok_for_atomic (gnu_type, gnat_array, true);
5012 /* Get and validate any specified Component_Size. */
5014 = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
5015 Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
5016 true, Has_Component_Size_Clause (gnat_array));
5018 /* If the array has aliased components and the component size can be zero,
5019 force at least unit size to ensure that the components have distinct
5022 && Has_Aliased_Components (gnat_array)
5023 && (integer_zerop (TYPE_SIZE (gnu_type))
5024 || (TREE_CODE (gnu_type) == ARRAY_TYPE
5025 && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
5027 = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
5029 /* If the component type is a RECORD_TYPE that has a self-referential size,
5030 then use the maximum size for the component size. */
5032 && TREE_CODE (gnu_type) == RECORD_TYPE
5033 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
5034 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
5036 /* Honor the component size. This is not needed for bit-packed arrays. */
5037 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
5039 tree orig_type = gnu_type;
5040 unsigned int max_align;
5042 /* If an alignment is specified, use it as a cap on the component type
5043 so that it can be honored for the whole type. But ignore it for the
5044 original type of packed array types. */
5045 if (No (Packed_Array_Type (gnat_array)) && Known_Alignment (gnat_array))
5046 max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
5050 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
5051 if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
5052 gnu_type = orig_type;
5054 orig_type = gnu_type;
5056 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
5057 true, false, definition, true);
5059 /* If a padding record was made, declare it now since it will never be
5060 declared otherwise. This is necessary to ensure that its subtrees
5061 are properly marked. */
5062 if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
5063 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
5064 debug_info_p, gnat_array);
5067 if (Has_Volatile_Components (Base_Type (gnat_array)))
5069 = build_qualified_type (gnu_type,
5070 TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
5075 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
5076 using MECH as its passing mechanism, to be placed in the parameter
5077 list built for GNAT_SUBPROG. Assume a foreign convention for the
5078 latter if FOREIGN is true. Also set CICO to true if the parameter
5079 must use the copy-in copy-out implementation mechanism.
5081 The returned tree is a PARM_DECL, except for those cases where no
5082 parameter needs to be actually passed to the subprogram; the type
5083 of this "shadow" parameter is then returned instead. */
5086 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
5087 Entity_Id gnat_subprog, bool foreign, bool *cico)
5089 tree gnu_param_name = get_entity_name (gnat_param);
5090 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
5091 tree gnu_param_type_alt = NULL_TREE;
5092 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
5093 /* The parameter can be indirectly modified if its address is taken. */
5094 bool ro_param = in_param && !Address_Taken (gnat_param);
5095 bool by_return = false, by_component_ptr = false, by_ref = false;
5098 /* Copy-return is used only for the first parameter of a valued procedure.
5099 It's a copy mechanism for which a parameter is never allocated. */
5100 if (mech == By_Copy_Return)
5102 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
5107 /* If this is either a foreign function or if the underlying type won't
5108 be passed by reference, strip off possible padding type. */
5109 if (TYPE_IS_PADDING_P (gnu_param_type))
5111 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
5113 if (mech == By_Reference
5115 || (!must_pass_by_ref (unpadded_type)
5116 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
5117 gnu_param_type = unpadded_type;
5120 /* If this is a read-only parameter, make a variant of the type that is
5121 read-only. ??? However, if this is an unconstrained array, that type
5122 can be very complex, so skip it for now. Likewise for any other
5123 self-referential type. */
5125 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
5126 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
5127 gnu_param_type = build_qualified_type (gnu_param_type,
5128 (TYPE_QUALS (gnu_param_type)
5129 | TYPE_QUAL_CONST));
5131 /* For foreign conventions, pass arrays as pointers to the element type.
5132 First check for unconstrained array and get the underlying array. */
5133 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
5135 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
5137 /* VMS descriptors are themselves passed by reference. */
5138 if (mech == By_Short_Descriptor ||
5139 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
5141 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5142 Mechanism (gnat_param),
5144 else if (mech == By_Descriptor)
5146 /* Build both a 32-bit and 64-bit descriptor, one of which will be
5147 chosen in fill_vms_descriptor. */
5149 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
5150 Mechanism (gnat_param),
5153 = build_pointer_type (build_vms_descriptor (gnu_param_type,
5154 Mechanism (gnat_param),
5158 /* Arrays are passed as pointers to element type for foreign conventions. */
5161 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
5163 /* Strip off any multi-dimensional entries, then strip
5164 off the last array to get the component type. */
5165 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
5166 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
5167 gnu_param_type = TREE_TYPE (gnu_param_type);
5169 by_component_ptr = true;
5170 gnu_param_type = TREE_TYPE (gnu_param_type);
5173 gnu_param_type = build_qualified_type (gnu_param_type,
5174 (TYPE_QUALS (gnu_param_type)
5175 | TYPE_QUAL_CONST));
5177 gnu_param_type = build_pointer_type (gnu_param_type);
5180 /* Fat pointers are passed as thin pointers for foreign conventions. */
5181 else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
5183 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5185 /* If we must pass or were requested to pass by reference, do so.
5186 If we were requested to pass by copy, do so.
5187 Otherwise, for foreign conventions, pass In Out or Out parameters
5188 or aggregates by reference. For COBOL and Fortran, pass all
5189 integer and FP types that way too. For Convention Ada, use
5190 the standard Ada default. */
5191 else if (must_pass_by_ref (gnu_param_type)
5192 || mech == By_Reference
5195 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5197 && (Convention (gnat_subprog) == Convention_Fortran
5198 || Convention (gnat_subprog) == Convention_COBOL)
5199 && (INTEGRAL_TYPE_P (gnu_param_type)
5200 || FLOAT_TYPE_P (gnu_param_type)))
5202 && default_pass_by_ref (gnu_param_type)))))
5204 gnu_param_type = build_reference_type (gnu_param_type);
5208 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5212 if (mech == By_Copy && (by_ref || by_component_ptr))
5213 post_error ("?cannot pass & by copy", gnat_param);
5215 /* If this is an Out parameter that isn't passed by reference and isn't
5216 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5217 it will be a VAR_DECL created when we process the procedure, so just
5218 return its type. For the special parameter of a valued procedure,
5221 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5222 Out parameters with discriminants or implicit initial values to be
5223 handled like In Out parameters. These type are normally built as
5224 aggregates, hence passed by reference, except for some packed arrays
5225 which end up encoded in special integer types.
5227 The exception we need to make is then for packed arrays of records
5228 with discriminants or implicit initial values. We have no light/easy
5229 way to check for the latter case, so we merely check for packed arrays
5230 of records. This may lead to useless copy-in operations, but in very
5231 rare cases only, as these would be exceptions in a set of already
5232 exceptional situations. */
5233 if (Ekind (gnat_param) == E_Out_Parameter
5236 || (mech != By_Descriptor
5237 && mech != By_Short_Descriptor
5238 && !POINTER_TYPE_P (gnu_param_type)
5239 && !AGGREGATE_TYPE_P (gnu_param_type)))
5240 && !(Is_Array_Type (Etype (gnat_param))
5241 && Is_Packed (Etype (gnat_param))
5242 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5243 return gnu_param_type;
5245 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5246 ro_param || by_ref || by_component_ptr);
5247 DECL_BY_REF_P (gnu_param) = by_ref;
5248 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5249 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5250 mech == By_Short_Descriptor);
5251 DECL_POINTS_TO_READONLY_P (gnu_param)
5252 = (ro_param && (by_ref || by_component_ptr));
5254 /* Save the alternate descriptor type, if any. */
5255 if (gnu_param_type_alt)
5256 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5258 /* If no Mechanism was specified, indicate what we're using, then
5259 back-annotate it. */
5260 if (mech == Default)
5261 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5263 Set_Mechanism (gnat_param, mech);
5267 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5270 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5272 while (Present (Corresponding_Discriminant (discr1)))
5273 discr1 = Corresponding_Discriminant (discr1);
5275 while (Present (Corresponding_Discriminant (discr2)))
5276 discr2 = Corresponding_Discriminant (discr2);
5279 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5282 /* Return true if the array type GNU_TYPE, which represents a dimension of
5283 GNAT_TYPE, has a non-aliased component in the back-end sense. */
5286 array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
5288 /* If the array type is not the innermost dimension of the GNAT type,
5289 then it has a non-aliased component. */
5290 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5291 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5294 /* If the array type has an aliased component in the front-end sense,
5295 then it also has an aliased component in the back-end sense. */
5296 if (Has_Aliased_Components (gnat_type))
5299 /* If this is a derived type, then it has a non-aliased component if
5300 and only if its parent type also has one. */
5301 if (Is_Derived_Type (gnat_type))
5303 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
5305 if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
5307 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
5308 for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
5309 gnu_parent_type = TREE_TYPE (gnu_parent_type);
5310 return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
5313 /* Otherwise, rely exclusively on properties of the element type. */
5314 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5317 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5320 compile_time_known_address_p (Node_Id gnat_address)
5322 /* Catch System'To_Address. */
5323 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5324 gnat_address = Expression (gnat_address);
5326 return Compile_Time_Known_Value (gnat_address);
5329 /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e.
5330 cannot verify HB < LB-1 when LB and HB are the low and high bounds. */
5333 cannot_be_superflat_p (Node_Id gnat_range)
5335 Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
5336 Node_Id scalar_range;
5338 tree gnu_lb, gnu_hb;
5340 /* If the low bound is not constant, try to find an upper bound. */
5341 while (Nkind (gnat_lb) != N_Integer_Literal
5342 && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
5343 || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
5344 && (scalar_range = Scalar_Range (Etype (gnat_lb)))
5345 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5346 || Nkind (scalar_range) == N_Range))
5347 gnat_lb = High_Bound (scalar_range);
5349 /* If the high bound is not constant, try to find a lower bound. */
5350 while (Nkind (gnat_hb) != N_Integer_Literal
5351 && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
5352 || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
5353 && (scalar_range = Scalar_Range (Etype (gnat_hb)))
5354 && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
5355 || Nkind (scalar_range) == N_Range))
5356 gnat_hb = Low_Bound (scalar_range);
5358 if (!(Nkind (gnat_lb) == N_Integer_Literal
5359 && Nkind (gnat_hb) == N_Integer_Literal))
5362 gnu_lb = UI_To_gnu (Intval (gnat_lb), bitsizetype);
5363 gnu_hb = UI_To_gnu (Intval (gnat_hb), bitsizetype);
5365 /* If the low bound is the smallest integer, nothing can be smaller. */
5366 gnu_lb = size_binop (MINUS_EXPR, gnu_lb, bitsize_one_node);
5367 if (TREE_OVERFLOW (gnu_lb))
5370 return (tree_int_cst_lt (gnu_hb, gnu_lb) == 0);
5373 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5374 be elaborated at the point of its definition, but do nothing else. */
5377 elaborate_entity (Entity_Id gnat_entity)
5379 switch (Ekind (gnat_entity))
5381 case E_Signed_Integer_Subtype:
5382 case E_Modular_Integer_Subtype:
5383 case E_Enumeration_Subtype:
5384 case E_Ordinary_Fixed_Point_Subtype:
5385 case E_Decimal_Fixed_Point_Subtype:
5386 case E_Floating_Point_Subtype:
5388 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5389 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5391 /* ??? Tests to avoid Constraint_Error in static expressions
5392 are needed until after the front stops generating bogus
5393 conversions on bounds of real types. */
5394 if (!Raises_Constraint_Error (gnat_lb))
5395 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5396 true, false, Needs_Debug_Info (gnat_entity));
5397 if (!Raises_Constraint_Error (gnat_hb))
5398 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5399 true, false, Needs_Debug_Info (gnat_entity));
5405 Node_Id full_definition = Declaration_Node (gnat_entity);
5406 Node_Id record_definition = Type_Definition (full_definition);
5408 /* If this is a record extension, go a level further to find the
5409 record definition. */
5410 if (Nkind (record_definition) == N_Derived_Type_Definition)
5411 record_definition = Record_Extension_Part (record_definition);
5415 case E_Record_Subtype:
5416 case E_Private_Subtype:
5417 case E_Limited_Private_Subtype:
5418 case E_Record_Subtype_With_Private:
5419 if (Is_Constrained (gnat_entity)
5420 && Has_Discriminants (gnat_entity)
5421 && Present (Discriminant_Constraint (gnat_entity)))
5423 Node_Id gnat_discriminant_expr;
5424 Entity_Id gnat_field;
5427 = First_Discriminant (Implementation_Base_Type (gnat_entity)),
5428 gnat_discriminant_expr
5429 = First_Elmt (Discriminant_Constraint (gnat_entity));
5430 Present (gnat_field);
5431 gnat_field = Next_Discriminant (gnat_field),
5432 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5433 /* ??? For now, ignore access discriminants. */
5434 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5435 elaborate_expression (Node (gnat_discriminant_expr),
5436 gnat_entity, get_entity_name (gnat_field),
5437 true, false, false);
5444 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5445 any entities on its entity chain similarly. */
5448 mark_out_of_scope (Entity_Id gnat_entity)
5450 Entity_Id gnat_sub_entity;
5451 unsigned int kind = Ekind (gnat_entity);
5453 /* If this has an entity list, process all in the list. */
5454 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5455 || IN (kind, Private_Kind)
5456 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5457 || kind == E_Function || kind == E_Generic_Function
5458 || kind == E_Generic_Package || kind == E_Generic_Procedure
5459 || kind == E_Loop || kind == E_Operator || kind == E_Package
5460 || kind == E_Package_Body || kind == E_Procedure
5461 || kind == E_Record_Type || kind == E_Record_Subtype
5462 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5463 for (gnat_sub_entity = First_Entity (gnat_entity);
5464 Present (gnat_sub_entity);
5465 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5466 if (Scope (gnat_sub_entity) == gnat_entity
5467 && gnat_sub_entity != gnat_entity)
5468 mark_out_of_scope (gnat_sub_entity);
5470 /* Now clear this if it has been defined, but only do so if it isn't
5471 a subprogram or parameter. We could refine this, but it isn't
5472 worth it. If this is statically allocated, it is supposed to
5473 hang around out of cope. */
5474 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5475 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5477 save_gnu_tree (gnat_entity, NULL_TREE, true);
5478 save_gnu_tree (gnat_entity, error_mark_node, true);
5482 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5483 If this is a multi-dimensional array type, do this recursively.
5486 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5487 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5488 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5491 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5493 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5494 of a one-dimensional array, since the padding has the same alias set
5495 as the field type, but if it's a multi-dimensional array, we need to
5496 see the inner types. */
5497 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5498 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5499 || TYPE_PADDING_P (gnu_old_type)))
5500 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5502 /* Unconstrained array types are deemed incomplete and would thus be given
5503 alias set 0. Retrieve the underlying array type. */
5504 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5506 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5507 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5509 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5511 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5512 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5513 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5514 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5518 case ALIAS_SET_COPY:
5519 /* The alias set shouldn't be copied between array types with different
5520 aliasing settings because this can break the aliasing relationship
5521 between the array type and its element type. */
5522 #ifndef ENABLE_CHECKING
5523 if (flag_strict_aliasing)
5525 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5526 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5527 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5528 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5530 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5533 case ALIAS_SET_SUBSET:
5534 case ALIAS_SET_SUPERSET:
5536 alias_set_type old_set = get_alias_set (gnu_old_type);
5537 alias_set_type new_set = get_alias_set (gnu_new_type);
5539 /* Do nothing if the alias sets conflict. This ensures that we
5540 never call record_alias_subset several times for the same pair
5541 or at all for alias set 0. */
5542 if (!alias_sets_conflict_p (old_set, new_set))
5544 if (op == ALIAS_SET_SUBSET)
5545 record_alias_subset (old_set, new_set);
5547 record_alias_subset (new_set, old_set);
5556 record_component_aliases (gnu_new_type);
5559 /* Return true if the size represented by GNU_SIZE can be handled by an
5560 allocation. If STATIC_P is true, consider only what can be done with a
5561 static allocation. */
5564 allocatable_size_p (tree gnu_size, bool static_p)
5566 HOST_WIDE_INT our_size;
5568 /* If this is not a static allocation, the only case we want to forbid
5569 is an overflowing size. That will be converted into a raise a
5572 return !(TREE_CODE (gnu_size) == INTEGER_CST
5573 && TREE_OVERFLOW (gnu_size));
5575 /* Otherwise, we need to deal with both variable sizes and constant
5576 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5577 since assemblers may not like very large sizes. */
5578 if (!host_integerp (gnu_size, 1))
5581 our_size = tree_low_cst (gnu_size, 1);
5582 return (int) our_size == our_size;
5585 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5586 NAME, ARGS and ERROR_POINT. */
5589 prepend_one_attribute_to (struct attrib ** attr_list,
5590 enum attr_type attr_type,
5593 Node_Id attr_error_point)
5595 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5597 attr->type = attr_type;
5598 attr->name = attr_name;
5599 attr->args = attr_args;
5600 attr->error_point = attr_error_point;
5602 attr->next = *attr_list;
5606 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5609 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5613 /* Attributes are stored as Representation Item pragmas. */
5615 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5616 gnat_temp = Next_Rep_Item (gnat_temp))
5617 if (Nkind (gnat_temp) == N_Pragma)
5619 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5620 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5621 enum attr_type etype;
5623 /* Map the kind of pragma at hand. Skip if this is not one
5624 we know how to handle. */
5626 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5628 case Pragma_Machine_Attribute:
5629 etype = ATTR_MACHINE_ATTRIBUTE;
5632 case Pragma_Linker_Alias:
5633 etype = ATTR_LINK_ALIAS;
5636 case Pragma_Linker_Section:
5637 etype = ATTR_LINK_SECTION;
5640 case Pragma_Linker_Constructor:
5641 etype = ATTR_LINK_CONSTRUCTOR;
5644 case Pragma_Linker_Destructor:
5645 etype = ATTR_LINK_DESTRUCTOR;
5648 case Pragma_Weak_External:
5649 etype = ATTR_WEAK_EXTERNAL;
5652 case Pragma_Thread_Local_Storage:
5653 etype = ATTR_THREAD_LOCAL_STORAGE;
5660 /* See what arguments we have and turn them into GCC trees for
5661 attribute handlers. These expect identifier for strings. We
5662 handle at most two arguments, static expressions only. */
5664 if (Present (gnat_assoc) && Present (First (gnat_assoc)))
5666 Node_Id gnat_arg0 = Next (First (gnat_assoc));
5667 Node_Id gnat_arg1 = Empty;
5669 if (Present (gnat_arg0)
5670 && Is_Static_Expression (Expression (gnat_arg0)))
5672 gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
5674 if (TREE_CODE (gnu_arg0) == STRING_CST)
5675 gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
5677 gnat_arg1 = Next (gnat_arg0);
5680 if (Present (gnat_arg1)
5681 && Is_Static_Expression (Expression (gnat_arg1)))
5683 gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
5685 if (TREE_CODE (gnu_arg1) == STRING_CST)
5686 gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
5690 /* Prepend to the list now. Make a list of the argument we might
5691 have, as GCC expects it. */
5692 prepend_one_attribute_to
5695 (gnu_arg1 != NULL_TREE)
5696 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5697 Present (Next (First (gnat_assoc)))
5698 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5702 /* Called when we need to protect a variable object using a SAVE_EXPR. */
5705 maybe_variable (tree gnu_operand)
5707 if (TREE_CONSTANT (gnu_operand)
5708 || TREE_READONLY (gnu_operand)
5709 || TREE_CODE (gnu_operand) == SAVE_EXPR
5710 || TREE_CODE (gnu_operand) == NULL_EXPR)
5713 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5716 = build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
5717 variable_size (TREE_OPERAND (gnu_operand, 0)));
5719 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5720 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5724 return variable_size (gnu_operand);
5727 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5728 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5729 return the GCC tree to use for that expression. GNU_NAME is the suffix
5730 to use if a variable needs to be created and DEFINITION is true if this
5731 is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
5732 otherwise, we are just elaborating the expression for side-effects. If
5733 NEED_DEBUG is true, we need a variable for debugging purposes even if it
5734 isn't needed for code generation. */
5737 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
5738 bool definition, bool need_value, bool need_debug)
5742 /* If we already elaborated this expression (e.g. it was involved
5743 in the definition of a private type), use the old value. */
5744 if (present_gnu_tree (gnat_expr))
5745 return get_gnu_tree (gnat_expr);
5747 /* If we don't need a value and this is static or a discriminant,
5748 we don't need to do anything. */
5750 && (Is_OK_Static_Expression (gnat_expr)
5751 || (Nkind (gnat_expr) == N_Identifier
5752 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5755 /* If it's a static expression, we don't need a variable for debugging. */
5756 if (need_debug && Is_OK_Static_Expression (gnat_expr))
5759 /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
5760 gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
5761 gnu_name, definition, need_debug);
5763 /* Save the expression in case we try to elaborate this entity again. Since
5764 it's not a DECL, don't check it. Don't save if it's a discriminant. */
5765 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5766 save_gnu_tree (gnat_expr, gnu_expr, true);
5768 return need_value ? gnu_expr : error_mark_node;
5771 /* Similar, but take a GNU expression and always return a result. */
5774 elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
5775 bool definition, bool need_debug)
5777 /* Skip any conversions and simple arithmetics to see if the expression
5778 is a read-only variable.
5779 ??? This really should remain read-only, but we have to think about
5780 the typing of the tree here. */
5782 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5783 tree gnu_decl = NULL_TREE;
5784 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5787 /* In most cases, we won't see a naked FIELD_DECL because a discriminant
5788 reference will have been replaced with a COMPONENT_REF when the type
5789 is being elaborated. However, there are some cases involving child
5790 types where we will. So convert it to a COMPONENT_REF. We hope it
5791 will be at the highest level of the expression in these cases. */
5792 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5793 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5794 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5795 gnu_expr, NULL_TREE);
5797 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5798 that is read-only, make a variable that is initialized to contain the
5799 bound when the package containing the definition is elaborated. If
5800 this entity is defined at top level and a bound or discriminant value
5801 isn't a constant or a reference to a discriminant, replace the bound
5802 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5803 rely here on the fact that an expression cannot contain both the
5804 discriminant and some other variable. */
5805 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5806 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5807 && (TREE_READONLY (gnu_inner_expr)
5808 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5809 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5811 /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */
5812 if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
5815 /* Now create the variable if we need it. */
5816 if (need_debug || (expr_variable && expr_global))
5818 = create_var_decl (create_concat_name (gnat_entity,
5819 IDENTIFIER_POINTER (gnu_name)),
5820 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5821 !need_debug, Is_Public (gnat_entity),
5822 !definition, false, NULL, gnat_entity);
5824 /* We only need to use this variable if we are in global context since GCC
5825 can do the right thing in the local case. */
5826 if (expr_global && expr_variable)
5829 return expr_variable ? maybe_variable (gnu_expr) : gnu_expr;
5832 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5833 starting bit position so that it is aligned to ALIGN bits, and leaving at
5834 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5835 record is guaranteed to get. */
5838 make_aligning_type (tree type, unsigned int align, tree size,
5839 unsigned int base_align, int room)
5841 /* We will be crafting a record type with one field at a position set to be
5842 the next multiple of ALIGN past record'address + room bytes. We use a
5843 record placeholder to express record'address. */
5845 tree record_type = make_node (RECORD_TYPE);
5846 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5849 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5851 /* The diagram below summarizes the shape of what we manipulate:
5853 <--------- pos ---------->
5854 { +------------+-------------+-----------------+
5855 record =>{ |############| ... | field (type) |
5856 { +------------+-------------+-----------------+
5857 |<-- room -->|<- voffset ->|<---- size ----->|
5860 record_addr vblock_addr
5862 Every length is in sizetype bytes there, except "pos" which has to be
5863 set as a bit position in the GCC tree for the record. */
5865 tree room_st = size_int (room);
5866 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5867 tree voffset_st, pos, field;
5869 tree name = TYPE_NAME (type);
5871 if (TREE_CODE (name) == TYPE_DECL)
5872 name = DECL_NAME (name);
5874 TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
5876 /* Compute VOFFSET and then POS. The next byte position multiple of some
5877 alignment after some address is obtained by "and"ing the alignment minus
5878 1 with the two's complement of the address. */
5880 voffset_st = size_binop (BIT_AND_EXPR,
5881 size_diffop (size_zero_node, vblock_addr_st),
5882 ssize_int ((align / BITS_PER_UNIT) - 1));
5884 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5886 pos = size_binop (MULT_EXPR,
5887 convert (bitsizetype,
5888 size_binop (PLUS_EXPR, room_st, voffset_st)),
5891 /* Craft the GCC record representation. We exceptionally do everything
5892 manually here because 1) our generic circuitry is not quite ready to
5893 handle the complex position/size expressions we are setting up, 2) we
5894 have a strong simplifying factor at hand: we know the maximum possible
5895 value of voffset, and 3) we have to set/reset at least the sizes in
5896 accordance with this maximum value anyway, as we need them to convey
5897 what should be "alloc"ated for this type.
5899 Use -1 as the 'addressable' indication for the field to prevent the
5900 creation of a bitfield. We don't need one, it would have damaging
5901 consequences on the alignment computation, and create_field_decl would
5902 make one without this special argument, for instance because of the
5903 complex position expression. */
5905 field = create_field_decl (get_identifier ("F"), type, record_type,
5907 TYPE_FIELDS (record_type) = field;
5909 TYPE_ALIGN (record_type) = base_align;
5910 TYPE_USER_ALIGN (record_type) = 1;
5912 TYPE_SIZE (record_type)
5913 = size_binop (PLUS_EXPR,
5914 size_binop (MULT_EXPR, convert (bitsizetype, size),
5916 bitsize_int (align + room * BITS_PER_UNIT));
5917 TYPE_SIZE_UNIT (record_type)
5918 = size_binop (PLUS_EXPR, size,
5919 size_int (room + align / BITS_PER_UNIT));
5921 SET_TYPE_MODE (record_type, BLKmode);
5923 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
5927 /* Return the result of rounding T up to ALIGN. */
5929 static inline unsigned HOST_WIDE_INT
5930 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5938 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5939 as the field type of a packed record if IN_RECORD is true, or as the
5940 component type of a packed array if IN_RECORD is false. See if we can
5941 rewrite it either as a type that has a non-BLKmode, which we can pack
5942 tighter in the packed record case, or as a smaller type. If so, return
5943 the new type. If not, return the original type. */
5946 make_packable_type (tree type, bool in_record)
5948 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5949 unsigned HOST_WIDE_INT new_size;
5950 tree new_type, old_field, field_list = NULL_TREE;
5952 /* No point in doing anything if the size is zero. */
5956 new_type = make_node (TREE_CODE (type));
5958 /* Copy the name and flags from the old type to that of the new.
5959 Note that we rely on the pointer equality created here for
5960 TYPE_NAME to look through conversions in various places. */
5961 TYPE_NAME (new_type) = TYPE_NAME (type);
5962 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5963 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5964 if (TREE_CODE (type) == RECORD_TYPE)
5965 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
5967 /* If we are in a record and have a small size, set the alignment to
5968 try for an integral mode. Otherwise set it to try for a smaller
5969 type with BLKmode. */
5970 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5972 TYPE_ALIGN (new_type) = ceil_alignment (size);
5973 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5977 unsigned HOST_WIDE_INT align;
5979 /* Do not try to shrink the size if the RM size is not constant. */
5980 if (TYPE_CONTAINS_TEMPLATE_P (type)
5981 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5984 /* Round the RM size up to a unit boundary to get the minimal size
5985 for a BLKmode record. Give up if it's already the size. */
5986 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5987 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5988 if (new_size == size)
5991 align = new_size & -new_size;
5992 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5995 TYPE_USER_ALIGN (new_type) = 1;
5997 /* Now copy the fields, keeping the position and size as we don't want
5998 to change the layout by propagating the packedness downwards. */
5999 for (old_field = TYPE_FIELDS (type); old_field;
6000 old_field = TREE_CHAIN (old_field))
6002 tree new_field_type = TREE_TYPE (old_field);
6003 tree new_field, new_size;
6005 if ((TREE_CODE (new_field_type) == RECORD_TYPE
6006 || TREE_CODE (new_field_type) == UNION_TYPE
6007 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6008 && !TYPE_FAT_POINTER_P (new_field_type)
6009 && host_integerp (TYPE_SIZE (new_field_type), 1))
6010 new_field_type = make_packable_type (new_field_type, true);
6012 /* However, for the last field in a not already packed record type
6013 that is of an aggregate type, we need to use the RM size in the
6014 packable version of the record type, see finish_record_type. */
6015 if (!TREE_CHAIN (old_field)
6016 && !TYPE_PACKED (type)
6017 && (TREE_CODE (new_field_type) == RECORD_TYPE
6018 || TREE_CODE (new_field_type) == UNION_TYPE
6019 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
6020 && !TYPE_FAT_POINTER_P (new_field_type)
6021 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
6022 && TYPE_ADA_SIZE (new_field_type))
6023 new_size = TYPE_ADA_SIZE (new_field_type);
6025 new_size = DECL_SIZE (old_field);
6027 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
6028 new_type, TYPE_PACKED (type), new_size,
6029 bit_position (old_field),
6030 !DECL_NONADDRESSABLE_P (old_field));
6032 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
6033 SET_DECL_ORIGINAL_FIELD
6034 (new_field, (DECL_ORIGINAL_FIELD (old_field)
6035 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
6037 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
6038 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
6040 TREE_CHAIN (new_field) = field_list;
6041 field_list = new_field;
6044 finish_record_type (new_type, nreverse (field_list), 2, true);
6045 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
6047 /* If this is a padding record, we never want to make the size smaller
6048 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
6049 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
6051 TYPE_SIZE (new_type) = TYPE_SIZE (type);
6052 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
6057 TYPE_SIZE (new_type) = bitsize_int (new_size);
6058 TYPE_SIZE_UNIT (new_type)
6059 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
6062 if (!TYPE_CONTAINS_TEMPLATE_P (type))
6063 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
6065 compute_record_mode (new_type);
6067 /* Try harder to get a packable type if necessary, for example
6068 in case the record itself contains a BLKmode field. */
6069 if (in_record && TYPE_MODE (new_type) == BLKmode)
6070 SET_TYPE_MODE (new_type,
6071 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
6073 /* If neither the mode nor the size has shrunk, return the old type. */
6074 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
6080 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
6081 if needed. We have already verified that SIZE and TYPE are large enough.
6082 GNAT_ENTITY is used to name the resulting record and to issue a warning.
6083 IS_COMPONENT_TYPE is true if this is being done for the component type
6084 of an array. IS_USER_TYPE is true if we must complete the original type.
6085 DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
6086 if the RM size of the resulting type is to be set to SIZE too; otherwise,
6087 it's set to the RM size of the original type. */
6090 maybe_pad_type (tree type, tree size, unsigned int align,
6091 Entity_Id gnat_entity, bool is_component_type,
6092 bool is_user_type, bool definition, bool same_rm_size)
6094 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
6095 tree orig_size = TYPE_SIZE (type);
6098 /* If TYPE is a padded type, see if it agrees with any size and alignment
6099 we were given. If so, return the original type. Otherwise, strip
6100 off the padding, since we will either be returning the inner type
6101 or repadding it. If no size or alignment is specified, use that of
6102 the original padded type. */
6103 if (TYPE_IS_PADDING_P (type))
6106 || operand_equal_p (round_up (size,
6107 MAX (align, TYPE_ALIGN (type))),
6108 round_up (TYPE_SIZE (type),
6109 MAX (align, TYPE_ALIGN (type))),
6111 && (align == 0 || align == TYPE_ALIGN (type)))
6115 size = TYPE_SIZE (type);
6117 align = TYPE_ALIGN (type);
6119 type = TREE_TYPE (TYPE_FIELDS (type));
6120 orig_size = TYPE_SIZE (type);
6123 /* If the size is either not being changed or is being made smaller (which
6124 is not done here and is only valid for bitfields anyway), show the size
6125 isn't changing. Likewise, clear the alignment if it isn't being
6126 changed. Then return if we aren't doing anything. */
6128 && (operand_equal_p (size, orig_size, 0)
6129 || (TREE_CODE (orig_size) == INTEGER_CST
6130 && tree_int_cst_lt (size, orig_size))))
6133 if (align == TYPE_ALIGN (type))
6136 if (align == 0 && !size)
6139 /* If requested, complete the original type and give it a name. */
6141 create_type_decl (get_entity_name (gnat_entity), type,
6142 NULL, !Comes_From_Source (gnat_entity),
6144 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6145 && DECL_IGNORED_P (TYPE_NAME (type))),
6148 /* We used to modify the record in place in some cases, but that could
6149 generate incorrect debugging information. So make a new record
6151 record = make_node (RECORD_TYPE);
6152 TYPE_PADDING_P (record) = 1;
6154 if (Present (gnat_entity))
6155 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
6157 TYPE_VOLATILE (record)
6158 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
6160 TYPE_ALIGN (record) = align;
6161 TYPE_SIZE (record) = size ? size : orig_size;
6162 TYPE_SIZE_UNIT (record)
6163 = convert (sizetype,
6164 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
6165 bitsize_unit_node));
6167 /* If we are changing the alignment and the input type is a record with
6168 BLKmode and a small constant size, try to make a form that has an
6169 integral mode. This might allow the padding record to also have an
6170 integral mode, which will be much more efficient. There is no point
6171 in doing so if a size is specified unless it is also a small constant
6172 size and it is incorrect to do so if we cannot guarantee that the mode
6173 will be naturally aligned since the field must always be addressable.
6175 ??? This might not always be a win when done for a stand-alone object:
6176 since the nominal and the effective type of the object will now have
6177 different modes, a VIEW_CONVERT_EXPR will be required for converting
6178 between them and it might be hard to overcome afterwards, including
6179 at the RTL level when the stand-alone object is accessed as a whole. */
6181 && TREE_CODE (type) == RECORD_TYPE
6182 && TYPE_MODE (type) == BLKmode
6183 && TREE_CODE (orig_size) == INTEGER_CST
6184 && !TREE_OVERFLOW (orig_size)
6185 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
6187 || (TREE_CODE (size) == INTEGER_CST
6188 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
6190 tree packable_type = make_packable_type (type, true);
6191 if (TYPE_MODE (packable_type) != BLKmode
6192 && align >= TYPE_ALIGN (packable_type))
6193 type = packable_type;
6196 /* Now create the field with the original size. */
6197 field = create_field_decl (get_identifier ("F"), type, record, 0,
6198 orig_size, bitsize_zero_node, 1);
6199 DECL_INTERNAL_P (field) = 1;
6201 /* Do not finalize it until after the auxiliary record is built. */
6202 finish_record_type (record, field, 1, true);
6204 /* Set the same size for its RM size if requested; otherwise reuse
6205 the RM size of the original type. */
6206 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6208 /* Unless debugging information isn't being written for the input type,
6209 write a record that shows what we are a subtype of and also make a
6210 variable that indicates our size, if still variable. */
6211 if (TYPE_NAME (record)
6212 && AGGREGATE_TYPE_P (type)
6213 && TREE_CODE (orig_size) != INTEGER_CST
6214 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6215 && DECL_IGNORED_P (TYPE_NAME (type))))
6217 tree marker = make_node (RECORD_TYPE);
6218 tree name = TYPE_NAME (record);
6219 tree orig_name = TYPE_NAME (type);
6221 if (TREE_CODE (name) == TYPE_DECL)
6222 name = DECL_NAME (name);
6224 if (TREE_CODE (orig_name) == TYPE_DECL)
6225 orig_name = DECL_NAME (orig_name);
6227 TYPE_NAME (marker) = concat_name (name, "XVS");
6228 finish_record_type (marker,
6229 create_field_decl (orig_name,
6230 build_reference_type (type),
6231 marker, 0, NULL_TREE, NULL_TREE,
6235 add_parallel_type (TYPE_STUB_DECL (record), marker);
6237 if (definition && size && TREE_CODE (size) != INTEGER_CST)
6238 create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6239 TYPE_SIZE_UNIT (record), false, false, false,
6240 false, NULL, gnat_entity);
6243 rest_of_record_type_compilation (record);
6245 /* If the size was widened explicitly, maybe give a warning. Take the
6246 original size as the maximum size of the input if there was an
6247 unconstrained record involved and round it up to the specified alignment,
6248 if one was specified. */
6249 if (CONTAINS_PLACEHOLDER_P (orig_size))
6250 orig_size = max_size (orig_size, true);
6253 orig_size = round_up (orig_size, align);
6255 if (Present (gnat_entity)
6257 && TREE_CODE (size) != MAX_EXPR
6258 && !operand_equal_p (size, orig_size, 0)
6259 && !(TREE_CODE (size) == INTEGER_CST
6260 && TREE_CODE (orig_size) == INTEGER_CST
6261 && tree_int_cst_lt (size, orig_size)))
6263 Node_Id gnat_error_node = Empty;
6265 if (Is_Packed_Array_Type (gnat_entity))
6266 gnat_entity = Original_Array_Type (gnat_entity);
6268 if ((Ekind (gnat_entity) == E_Component
6269 || Ekind (gnat_entity) == E_Discriminant)
6270 && Present (Component_Clause (gnat_entity)))
6271 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6272 else if (Present (Size_Clause (gnat_entity)))
6273 gnat_error_node = Expression (Size_Clause (gnat_entity));
6275 /* Generate message only for entities that come from source, since
6276 if we have an entity created by expansion, the message will be
6277 generated for some other corresponding source entity. */
6278 if (Comes_From_Source (gnat_entity))
6280 if (Present (gnat_error_node))
6281 post_error_ne_tree ("{^ }bits of & unused?",
6282 gnat_error_node, gnat_entity,
6283 size_diffop (size, orig_size));
6284 else if (is_component_type)
6285 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6286 gnat_entity, gnat_entity,
6287 size_diffop (size, orig_size));
6294 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6295 the value passed against the list of choices. */
6298 choices_to_gnu (tree operand, Node_Id choices)
6302 tree result = integer_zero_node;
6303 tree this_test, low = 0, high = 0, single = 0;
6305 for (choice = First (choices); Present (choice); choice = Next (choice))
6307 switch (Nkind (choice))
6310 low = gnat_to_gnu (Low_Bound (choice));
6311 high = gnat_to_gnu (High_Bound (choice));
6313 /* There's no good type to use here, so we might as well use
6314 integer_type_node. */
6316 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6317 build_binary_op (GE_EXPR, integer_type_node,
6319 build_binary_op (LE_EXPR, integer_type_node,
6324 case N_Subtype_Indication:
6325 gnat_temp = Range_Expression (Constraint (choice));
6326 low = gnat_to_gnu (Low_Bound (gnat_temp));
6327 high = gnat_to_gnu (High_Bound (gnat_temp));
6330 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6331 build_binary_op (GE_EXPR, integer_type_node,
6333 build_binary_op (LE_EXPR, integer_type_node,
6338 case N_Expanded_Name:
6339 /* This represents either a subtype range, an enumeration
6340 literal, or a constant Ekind says which. If an enumeration
6341 literal or constant, fall through to the next case. */
6342 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6343 && Ekind (Entity (choice)) != E_Constant)
6345 tree type = gnat_to_gnu_type (Entity (choice));
6347 low = TYPE_MIN_VALUE (type);
6348 high = TYPE_MAX_VALUE (type);
6351 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6352 build_binary_op (GE_EXPR, integer_type_node,
6354 build_binary_op (LE_EXPR, integer_type_node,
6359 /* ... fall through ... */
6361 case N_Character_Literal:
6362 case N_Integer_Literal:
6363 single = gnat_to_gnu (choice);
6364 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
6368 case N_Others_Choice:
6369 this_test = integer_one_node;
6376 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6383 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6384 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6387 adjust_packed (tree field_type, tree record_type, int packed)
6389 /* If the field contains an item of variable size, we cannot pack it
6390 because we cannot create temporaries of non-fixed size in case
6391 we need to take the address of the field. See addressable_p and
6392 the notes on the addressability issues for further details. */
6393 if (is_variable_size (field_type))
6396 /* If the alignment of the record is specified and the field type
6397 is over-aligned, request Storage_Unit alignment for the field. */
6400 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6409 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6410 placed in GNU_RECORD_TYPE.
6412 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6413 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6414 record has a specified alignment.
6416 DEFINITION is true if this field is for a record being defined.
6418 DEBUG_INFO_P is true if we need to write debug information for types
6419 that we may create in the process. */
6422 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6423 bool definition, bool debug_info_p)
6425 tree gnu_field_id = get_entity_name (gnat_field);
6426 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6427 tree gnu_field, gnu_size, gnu_pos;
6428 bool needs_strict_alignment
6429 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6430 || Treat_As_Volatile (gnat_field));
6432 /* If this field requires strict alignment, we cannot pack it because
6433 it would very likely be under-aligned in the record. */
6434 if (needs_strict_alignment)
6437 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6439 /* If a size is specified, use it. Otherwise, if the record type is packed,
6440 use the official RM size. See "Handling of Type'Size Values" in Einfo
6441 for further details. */
6442 if (Known_Static_Esize (gnat_field))
6443 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6444 gnat_field, FIELD_DECL, false, true);
6445 else if (packed == 1)
6446 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6447 gnat_field, FIELD_DECL, false, true);
6449 gnu_size = NULL_TREE;
6451 /* If we have a specified size that is smaller than that of the field's type,
6452 or a position is specified, and the field's type is a record that doesn't
6453 require strict alignment, see if we can get either an integral mode form
6454 of the type or a smaller form. If we can, show a size was specified for
6455 the field if there wasn't one already, so we know to make this a bitfield
6456 and avoid making things wider.
6458 Changing to an integral mode form is useful when the record is packed as
6459 we can then place the field at a non-byte-aligned position and so achieve
6460 tighter packing. This is in addition required if the field shares a byte
6461 with another field and the front-end lets the back-end handle the access
6462 to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
6464 Changing to a smaller form is required if the specified size is smaller
6465 than that of the field's type and the type contains sub-fields that are
6466 padded, in order to avoid generating accesses to these sub-fields that
6467 are wider than the field.
6469 We avoid the transformation if it is not required or potentially useful,
6470 as it might entail an increase of the field's alignment and have ripple
6471 effects on the outer record type. A typical case is a field known to be
6472 byte-aligned and not to share a byte with another field. */
6473 if (!needs_strict_alignment
6474 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6475 && !TYPE_FAT_POINTER_P (gnu_field_type)
6476 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6479 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6480 || (Present (Component_Clause (gnat_field))
6481 && !(UI_To_Int (Component_Bit_Offset (gnat_field))
6482 % BITS_PER_UNIT == 0
6483 && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
6485 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6486 if (gnu_packable_type != gnu_field_type)
6488 gnu_field_type = gnu_packable_type;
6490 gnu_size = rm_size (gnu_field_type);
6494 /* If we are packing the record and the field is BLKmode, round the
6495 size up to a byte boundary. */
6496 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6497 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6499 if (Present (Component_Clause (gnat_field)))
6501 Entity_Id gnat_parent
6502 = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
6504 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6505 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6506 gnat_field, FIELD_DECL, false, true);
6508 /* Ensure the position does not overlap with the parent subtype, if there
6509 is one. This test is omitted if the parent of the tagged type has a
6510 full rep clause since, in this case, component clauses are allowed to
6511 overlay the space allocated for the parent type and the front-end has
6512 checked that there are no overlapping components. */
6513 if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
6515 tree gnu_parent = gnat_to_gnu_type (gnat_parent);
6517 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6518 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6521 ("offset of& must be beyond parent{, minimum allowed is ^}",
6522 First_Bit (Component_Clause (gnat_field)), gnat_field,
6523 TYPE_SIZE_UNIT (gnu_parent));
6527 /* If this field needs strict alignment, ensure the record is
6528 sufficiently aligned and that that position and size are
6529 consistent with the alignment. */
6530 if (needs_strict_alignment)
6532 TYPE_ALIGN (gnu_record_type)
6533 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6536 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6538 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6540 ("atomic field& must be natural size of type{ (^)}",
6541 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6542 TYPE_SIZE (gnu_field_type));
6544 else if (Is_Aliased (gnat_field))
6546 ("size of aliased field& must be ^ bits",
6547 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6548 TYPE_SIZE (gnu_field_type));
6550 else if (Strict_Alignment (Etype (gnat_field)))
6552 ("size of & with aliased or tagged components not ^ bits",
6553 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6554 TYPE_SIZE (gnu_field_type));
6556 gnu_size = NULL_TREE;
6559 if (!integer_zerop (size_binop
6560 (TRUNC_MOD_EXPR, gnu_pos,
6561 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6563 if (Is_Aliased (gnat_field))
6565 ("position of aliased field& must be multiple of ^ bits",
6566 First_Bit (Component_Clause (gnat_field)), gnat_field,
6567 TYPE_ALIGN (gnu_field_type));
6569 else if (Treat_As_Volatile (gnat_field))
6571 ("position of volatile field& must be multiple of ^ bits",
6572 First_Bit (Component_Clause (gnat_field)), gnat_field,
6573 TYPE_ALIGN (gnu_field_type));
6575 else if (Strict_Alignment (Etype (gnat_field)))
6577 ("position of & with aliased or tagged components not multiple of ^ bits",
6578 First_Bit (Component_Clause (gnat_field)), gnat_field,
6579 TYPE_ALIGN (gnu_field_type));
6584 gnu_pos = NULL_TREE;
6588 if (Is_Atomic (gnat_field))
6589 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6592 /* If the record has rep clauses and this is the tag field, make a rep
6593 clause for it as well. */
6594 else if (Has_Specified_Layout (Scope (gnat_field))
6595 && Chars (gnat_field) == Name_uTag)
6597 gnu_pos = bitsize_zero_node;
6598 gnu_size = TYPE_SIZE (gnu_field_type);
6602 gnu_pos = NULL_TREE;
6604 /* We need to make the size the maximum for the type if it is
6605 self-referential and an unconstrained type. In that case, we can't
6606 pack the field since we can't make a copy to align it. */
6607 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6609 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6610 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6612 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6616 /* If a size is specified, adjust the field's type to it. */
6619 tree orig_field_type;
6621 /* If the field's type is justified modular, we would need to remove
6622 the wrapper to (better) meet the layout requirements. However we
6623 can do so only if the field is not aliased to preserve the unique
6624 layout and if the prescribed size is not greater than that of the
6625 packed array to preserve the justification. */
6626 if (!needs_strict_alignment
6627 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6628 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6629 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6631 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6634 = make_type_from_size (gnu_field_type, gnu_size,
6635 Has_Biased_Representation (gnat_field));
6637 orig_field_type = gnu_field_type;
6638 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6639 false, false, definition, true);
6641 /* If a padding record was made, declare it now since it will never be
6642 declared otherwise. This is necessary to ensure that its subtrees
6643 are properly marked. */
6644 if (gnu_field_type != orig_field_type
6645 && !DECL_P (TYPE_NAME (gnu_field_type)))
6646 create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
6647 true, debug_info_p, gnat_field);
6650 /* Otherwise (or if there was an error), don't specify a position. */
6652 gnu_pos = NULL_TREE;
6654 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6655 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6657 /* Now create the decl for the field. */
6658 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6659 packed, gnu_size, gnu_pos,
6660 Is_Aliased (gnat_field));
6661 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6662 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6664 if (Ekind (gnat_field) == E_Discriminant)
6665 DECL_DISCRIMINANT_NUMBER (gnu_field)
6666 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6671 /* Return true if TYPE is a type with variable size, a padding type with a
6672 field of variable size or is a record that has a field such a field. */
6675 is_variable_size (tree type)
6679 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6682 if (TYPE_IS_PADDING_P (type)
6683 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6686 if (TREE_CODE (type) != RECORD_TYPE
6687 && TREE_CODE (type) != UNION_TYPE
6688 && TREE_CODE (type) != QUAL_UNION_TYPE)
6691 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6692 if (is_variable_size (TREE_TYPE (field)))
6698 /* qsort comparer for the bit positions of two record components. */
6701 compare_field_bitpos (const PTR rt1, const PTR rt2)
6703 const_tree const field1 = * (const_tree const *) rt1;
6704 const_tree const field2 = * (const_tree const *) rt2;
6706 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6708 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6711 /* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set
6712 the result as the field list of GNU_RECORD_TYPE and finish it up. When
6713 called from gnat_to_gnu_entity during the processing of a record type
6714 definition, the GCC node for the parent, if any, will be the single field
6715 of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
6716 GNU_FIELD_LIST. The other calls to this function are recursive calls for
6717 the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
6719 PACKED is 1 if this is for a packed record, -1 if this is for a record
6720 with Component_Alignment of Storage_Unit, -2 if this is for a record
6721 with a specified alignment.
6723 DEFINITION is true if we are defining this record.
6725 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6726 with a rep clause is to be added; in this case, that is all that should
6727 be done with such fields.
6729 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6730 laying out the record. This means the alignment only serves to force
6731 fields to be bitfields, but not require the record to be that aligned.
6732 This is used for variants.
6734 ALL_REP, if true, means a rep clause was found for all the fields. This
6735 simplifies the logic since we know we're not in the mixed case.
6737 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6738 modified afterwards so it will not be finalized here.
6740 UNCHECKED_UNION, if true, means that we are building a type for a record
6741 with a Pragma Unchecked_Union.
6743 DEBUG_INFO_P, if true, means that we need to write debug information for
6744 types that we may create in the process. */
6747 components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
6748 tree gnu_field_list, int packed, bool definition,
6749 tree *p_gnu_rep_list, bool cancel_alignment,
6750 bool all_rep, bool do_not_finalize,
6751 bool unchecked_union, bool debug_info_p)
6753 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6754 bool layout_with_rep = false;
6755 Node_Id component_decl, variant_part;
6756 tree gnu_our_rep_list = NULL_TREE;
6757 tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
6759 /* For each component referenced in a component declaration create a GCC
6760 field and add it to the list, skipping pragmas in the GNAT list. */
6761 if (Present (Component_Items (gnat_component_list)))
6763 = First_Non_Pragma (Component_Items (gnat_component_list));
6764 Present (component_decl);
6765 component_decl = Next_Non_Pragma (component_decl))
6767 Entity_Id gnat_field = Defining_Entity (component_decl);
6768 Name_Id gnat_name = Chars (gnat_field);
6770 /* If present, the _Parent field must have been created as the single
6771 field of the record type. Put it before any other fields. */
6772 if (gnat_name == Name_uParent)
6774 gnu_field = TYPE_FIELDS (gnu_record_type);
6775 gnu_field_list = chainon (gnu_field_list, gnu_field);
6779 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
6780 definition, debug_info_p);
6782 /* If this is the _Tag field, put it before any other fields. */
6783 if (gnat_name == Name_uTag)
6784 gnu_field_list = chainon (gnu_field_list, gnu_field);
6786 /* If this is the _Controller field, put it before the other
6787 fields except for the _Tag or _Parent field. */
6788 else if (gnat_name == Name_uController && gnu_last)
6790 TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
6791 TREE_CHAIN (gnu_last) = gnu_field;
6794 /* If this is a regular field, put it after the other fields. */
6797 TREE_CHAIN (gnu_field) = gnu_field_list;
6798 gnu_field_list = gnu_field;
6800 gnu_last = gnu_field;
6804 save_gnu_tree (gnat_field, gnu_field, false);
6807 /* At the end of the component list there may be a variant part. */
6808 variant_part = Variant_Part (gnat_component_list);
6810 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6811 mutually exclusive and should go in the same memory. To do this we need
6812 to treat each variant as a record whose elements are created from the
6813 component list for the variant. So here we create the records from the
6814 lists for the variants and put them all into the QUAL_UNION_TYPE.
6815 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6816 use GNU_RECORD_TYPE if there are no fields so far. */
6817 if (Present (variant_part))
6819 Node_Id gnat_discr = Name (variant_part), variant;
6820 tree gnu_discr = gnat_to_gnu (gnat_discr);
6821 tree gnu_name = TYPE_NAME (gnu_record_type);
6823 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
6825 tree gnu_union_type, gnu_union_name, gnu_union_field;
6826 tree gnu_variant_list = NULL_TREE;
6828 if (TREE_CODE (gnu_name) == TYPE_DECL)
6829 gnu_name = DECL_NAME (gnu_name);
6832 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
6834 /* Reuse an enclosing union if all fields are in the variant part
6835 and there is no representation clause on the record, to match
6836 the layout of C unions. There is an associated check below. */
6838 && TREE_CODE (gnu_record_type) == UNION_TYPE
6839 && !TYPE_PACKED (gnu_record_type))
6840 gnu_union_type = gnu_record_type;
6844 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6846 TYPE_NAME (gnu_union_type) = gnu_union_name;
6847 TYPE_ALIGN (gnu_union_type) = 0;
6848 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6851 for (variant = First_Non_Pragma (Variants (variant_part));
6853 variant = Next_Non_Pragma (variant))
6855 tree gnu_variant_type = make_node (RECORD_TYPE);
6856 tree gnu_inner_name;
6859 Get_Variant_Encoding (variant);
6860 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
6861 TYPE_NAME (gnu_variant_type)
6862 = concat_name (gnu_union_name,
6863 IDENTIFIER_POINTER (gnu_inner_name));
6865 /* Set the alignment of the inner type in case we need to make
6866 inner objects into bitfields, but then clear it out so the
6867 record actually gets only the alignment required. */
6868 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6869 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6871 /* Similarly, if the outer record has a size specified and all
6872 fields have record rep clauses, we can propagate the size
6873 into the variant part. */
6874 if (all_rep_and_size)
6876 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6877 TYPE_SIZE_UNIT (gnu_variant_type)
6878 = TYPE_SIZE_UNIT (gnu_record_type);
6881 /* Add the fields into the record type for the variant. Note that we
6882 defer finalizing it until after we are sure to really use it. */
6883 components_to_record (gnu_variant_type, Component_List (variant),
6884 NULL_TREE, packed, definition,
6885 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6886 true, unchecked_union, debug_info_p);
6888 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
6890 Set_Present_Expr (variant, annotate_value (gnu_qual));
6892 /* If this is an Unchecked_Union and we have exactly one field,
6893 use this field directly to match the layout of C unions. */
6895 && TYPE_FIELDS (gnu_variant_type)
6896 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6897 gnu_field = TYPE_FIELDS (gnu_variant_type);
6900 /* Deal with packedness like in gnat_to_gnu_field. */
6902 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6904 /* Finalize the record type now. We used to throw away
6905 empty records but we no longer do that because we need
6906 them to generate complete debug info for the variant;
6907 otherwise, the union type definition will be lacking
6908 the fields associated with these empty variants. */
6909 rest_of_record_type_compilation (gnu_variant_type);
6910 create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
6911 NULL, true, debug_info_p, gnat_component_list);
6913 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6914 gnu_union_type, field_packed,
6916 ? TYPE_SIZE (gnu_variant_type)
6919 ? bitsize_zero_node : 0),
6922 DECL_INTERNAL_P (gnu_field) = 1;
6924 if (!unchecked_union)
6925 DECL_QUALIFIER (gnu_field) = gnu_qual;
6928 TREE_CHAIN (gnu_field) = gnu_variant_list;
6929 gnu_variant_list = gnu_field;
6932 /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
6933 if (gnu_variant_list)
6935 int union_field_packed;
6937 if (all_rep_and_size)
6939 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6940 TYPE_SIZE_UNIT (gnu_union_type)
6941 = TYPE_SIZE_UNIT (gnu_record_type);
6944 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6945 all_rep_and_size ? 1 : 0, false);
6947 /* If GNU_UNION_TYPE is our record type, it means we must have an
6948 Unchecked_Union with no fields. Verify that and, if so, just
6950 if (gnu_union_type == gnu_record_type)
6952 gcc_assert (unchecked_union
6954 && !gnu_our_rep_list);
6958 create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
6959 NULL, true, debug_info_p, gnat_component_list);
6961 /* Deal with packedness like in gnat_to_gnu_field. */
6963 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6966 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6968 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6969 all_rep ? bitsize_zero_node : 0, 0);
6971 DECL_INTERNAL_P (gnu_union_field) = 1;
6972 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6973 gnu_field_list = gnu_union_field;
6977 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6978 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do
6979 this in a separate pass since we want to handle the discriminants but
6980 can't play with them until we've used them in debugging data above.
6982 ??? If we then reorder them, debugging information will be wrong but
6983 there's nothing that can be done about this at the moment. */
6984 gnu_last = NULL_TREE;
6985 for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
6987 gnu_next = TREE_CHAIN (gnu_field);
6989 if (DECL_FIELD_OFFSET (gnu_field))
6992 gnu_field_list = gnu_next;
6994 TREE_CHAIN (gnu_last) = gnu_next;
6996 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6997 gnu_our_rep_list = gnu_field;
7000 gnu_last = gnu_field;
7003 /* If we have any fields in our rep'ed field list and it is not the case that
7004 all the fields in the record have rep clauses and P_REP_LIST is nonzero,
7005 set it and ignore these fields. */
7006 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
7007 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
7009 /* Otherwise, sort the fields by bit position and put them into their own
7010 record, before the others, if we also have fields without rep clauses. */
7011 else if (gnu_our_rep_list)
7014 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
7015 int i, len = list_length (gnu_our_rep_list);
7016 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
7018 for (gnu_field = gnu_our_rep_list, i = 0;
7020 gnu_field = TREE_CHAIN (gnu_field), i++)
7021 gnu_arr[i] = gnu_field;
7023 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
7025 /* Put the fields in the list in order of increasing position, which
7026 means we start from the end. */
7027 gnu_our_rep_list = NULL_TREE;
7028 for (i = len - 1; i >= 0; i--)
7030 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
7031 gnu_our_rep_list = gnu_arr[i];
7032 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
7037 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
7039 = create_field_decl (get_identifier ("REP"), gnu_rep_type,
7040 gnu_record_type, 0, NULL_TREE, NULL_TREE, 1);
7041 DECL_INTERNAL_P (gnu_field) = 1;
7042 gnu_field_list = chainon (gnu_field_list, gnu_field);
7046 layout_with_rep = true;
7047 gnu_field_list = nreverse (gnu_our_rep_list);
7051 if (cancel_alignment)
7052 TYPE_ALIGN (gnu_record_type) = 0;
7054 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
7055 layout_with_rep ? 1 : 0, do_not_finalize);
7058 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
7059 placed into an Esize, Component_Bit_Offset, or Component_Size value
7060 in the GNAT tree. */
7063 annotate_value (tree gnu_size)
7065 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
7067 Node_Ref_Or_Val ops[3], ret;
7070 struct tree_int_map **h = NULL;
7072 /* See if we've already saved the value for this node. */
7073 if (EXPR_P (gnu_size))
7075 struct tree_int_map in;
7076 if (!annotate_value_cache)
7077 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
7078 tree_int_map_eq, 0);
7079 in.base.from = gnu_size;
7080 h = (struct tree_int_map **)
7081 htab_find_slot (annotate_value_cache, &in, INSERT);
7084 return (Node_Ref_Or_Val) (*h)->to;
7087 /* If we do not return inside this switch, TCODE will be set to the
7088 code to use for a Create_Node operand and LEN (set above) will be
7089 the number of recursive calls for us to make. */
7091 switch (TREE_CODE (gnu_size))
7094 if (TREE_OVERFLOW (gnu_size))
7097 /* This may have come from a conversion from some smaller type,
7098 so ensure this is in bitsizetype. */
7099 gnu_size = convert (bitsizetype, gnu_size);
7101 /* For negative values, use NEGATE_EXPR of the supplied value. */
7102 if (tree_int_cst_sgn (gnu_size) < 0)
7104 /* The ridiculous code below is to handle the case of the largest
7105 negative integer. */
7106 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
7107 bool adjust = false;
7110 if (TREE_OVERFLOW (negative_size))
7113 = size_binop (MINUS_EXPR, bitsize_zero_node,
7114 size_binop (PLUS_EXPR, gnu_size,
7119 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
7121 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
7123 return annotate_value (temp);
7126 if (!host_integerp (gnu_size, 1))
7129 size = tree_low_cst (gnu_size, 1);
7131 /* This peculiar test is to make sure that the size fits in an int
7132 on machines where HOST_WIDE_INT is not "int". */
7133 if (tree_low_cst (gnu_size, 1) == size)
7134 return UI_From_Int (size);
7139 /* The only case we handle here is a simple discriminant reference. */
7140 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
7141 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
7142 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
7143 return Create_Node (Discrim_Val,
7144 annotate_value (DECL_DISCRIMINANT_NUMBER
7145 (TREE_OPERAND (gnu_size, 1))),
7150 CASE_CONVERT: case NON_LVALUE_EXPR:
7151 return annotate_value (TREE_OPERAND (gnu_size, 0));
7153 /* Now just list the operations we handle. */
7154 case COND_EXPR: tcode = Cond_Expr; break;
7155 case PLUS_EXPR: tcode = Plus_Expr; break;
7156 case MINUS_EXPR: tcode = Minus_Expr; break;
7157 case MULT_EXPR: tcode = Mult_Expr; break;
7158 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
7159 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
7160 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
7161 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
7162 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
7163 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
7164 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
7165 case NEGATE_EXPR: tcode = Negate_Expr; break;
7166 case MIN_EXPR: tcode = Min_Expr; break;
7167 case MAX_EXPR: tcode = Max_Expr; break;
7168 case ABS_EXPR: tcode = Abs_Expr; break;
7169 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
7170 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
7171 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
7172 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
7173 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
7174 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
7175 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
7176 case LT_EXPR: tcode = Lt_Expr; break;
7177 case LE_EXPR: tcode = Le_Expr; break;
7178 case GT_EXPR: tcode = Gt_Expr; break;
7179 case GE_EXPR: tcode = Ge_Expr; break;
7180 case EQ_EXPR: tcode = Eq_Expr; break;
7181 case NE_EXPR: tcode = Ne_Expr; break;
7185 tree t = maybe_inline_call_in_expr (gnu_size);
7187 return annotate_value (t);
7190 /* Fall through... */
7196 /* Now get each of the operands that's relevant for this code. If any
7197 cannot be expressed as a repinfo node, say we can't. */
7198 for (i = 0; i < 3; i++)
7201 for (i = 0; i < len; i++)
7203 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
7204 if (ops[i] == No_Uint)
7208 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
7210 /* Save the result in the cache. */
7213 *h = GGC_NEW (struct tree_int_map);
7214 (*h)->base.from = gnu_size;
7221 /* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
7222 and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
7223 size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
7224 BY_REF is true if the object is used by reference. */
7227 annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
7231 if (TYPE_IS_FAT_POINTER_P (gnu_type))
7232 gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
7234 gnu_type = TREE_TYPE (gnu_type);
7237 if (Unknown_Esize (gnat_entity))
7239 if (TREE_CODE (gnu_type) == RECORD_TYPE
7240 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7241 size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
7243 size = TYPE_SIZE (gnu_type);
7246 Set_Esize (gnat_entity, annotate_value (size));
7249 if (Unknown_Alignment (gnat_entity))
7250 Set_Alignment (gnat_entity,
7251 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
7254 /* Return first element of field list whose TREE_PURPOSE is ELEM or whose
7255 DECL_ORIGINAL_FIELD of TREE_PURPOSE is ELEM. Return NULL_TREE if there
7256 is no such element in the list. */
7259 purpose_member_field (const_tree elem, tree list)
7263 tree field = TREE_PURPOSE (list);
7264 if (elem == field || elem == DECL_ORIGINAL_FIELD (field))
7266 list = TREE_CHAIN (list);
7271 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
7272 set Component_Bit_Offset and Esize of the components to the position and
7273 size used by Gigi. */
7276 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7278 Entity_Id gnat_field;
7281 /* We operate by first making a list of all fields and their position (we
7282 can get the size easily) and then update all the sizes in the tree. */
7284 = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
7285 BIGGEST_ALIGNMENT, NULL_TREE);
7287 for (gnat_field = First_Entity (gnat_entity);
7288 Present (gnat_field);
7289 gnat_field = Next_Entity (gnat_field))
7290 if (Ekind (gnat_field) == E_Component
7291 || (Ekind (gnat_field) == E_Discriminant
7292 && !Is_Unchecked_Union (Scope (gnat_field))))
7294 tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
7300 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7302 /* In this mode the tag and parent components are not
7303 generated, so we add the appropriate offset to each
7304 component. For a component appearing in the current
7305 extension, the offset is the size of the parent. */
7306 if (Is_Derived_Type (gnat_entity)
7307 && Original_Record_Component (gnat_field) == gnat_field)
7309 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7312 parent_offset = bitsize_int (POINTER_SIZE);
7315 parent_offset = bitsize_zero_node;
7317 Set_Component_Bit_Offset
7320 (size_binop (PLUS_EXPR,
7321 bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
7322 TREE_VEC_ELT (TREE_VALUE (t), 2)),
7325 Set_Esize (gnat_field,
7326 annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
7328 else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
7330 /* If there is no entry, this is an inherited component whose
7331 position is the same as in the parent type. */
7332 Set_Component_Bit_Offset
7334 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7336 Set_Esize (gnat_field,
7337 Esize (Original_Record_Component (gnat_field)));
7342 /* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
7343 the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
7344 value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
7345 of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
7346 is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
7347 bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
7348 pre-existing list to be chained to the newly created entries. */
7351 build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
7352 tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
7356 for (gnu_field = TYPE_FIELDS (gnu_type);
7358 gnu_field = TREE_CHAIN (gnu_field))
7360 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7361 DECL_FIELD_BIT_OFFSET (gnu_field));
7362 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7363 DECL_FIELD_OFFSET (gnu_field));
7364 unsigned int our_offset_align
7365 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7366 tree v = make_tree_vec (3);
7368 TREE_VEC_ELT (v, 0) = gnu_our_offset;
7369 TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
7370 TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
7371 gnu_list = tree_cons (gnu_field, v, gnu_list);
7373 /* Recurse on internal fields, flattening the nested fields except for
7374 those in the variant part, if requested. */
7375 if (DECL_INTERNAL_P (gnu_field))
7377 tree gnu_field_type = TREE_TYPE (gnu_field);
7378 if (do_not_flatten_variant
7379 && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
7381 = build_position_list (gnu_field_type, do_not_flatten_variant,
7382 size_zero_node, bitsize_zero_node,
7383 BIGGEST_ALIGNMENT, gnu_list);
7386 = build_position_list (gnu_field_type, do_not_flatten_variant,
7387 gnu_our_offset, gnu_our_bitpos,
7388 our_offset_align, gnu_list);
7395 /* Return a TREE_LIST describing the substitutions needed to reflect the
7396 discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
7397 be in any order. TREE_PURPOSE gives the tree for the discriminant and
7398 TREE_VALUE is the replacement value. They are in the form of operands
7399 to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
7403 build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
7405 tree gnu_list = NULL_TREE;
7406 Entity_Id gnat_discrim;
7409 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
7410 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
7411 Present (gnat_discrim);
7412 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
7413 gnat_value = Next_Elmt (gnat_value))
7414 /* Ignore access discriminants. */
7415 if (!Is_Access_Type (Etype (Node (gnat_value))))
7417 tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
7418 gnu_list = tree_cons (gnu_field,
7419 convert (TREE_TYPE (gnu_field),
7420 elaborate_expression
7421 (Node (gnat_value), gnat_subtype,
7422 get_entity_name (gnat_discrim),
7423 definition, true, false)),
7430 /* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
7431 variants of QUAL_UNION_TYPE that are still relevant after applying the
7432 substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
7433 variant and TREE_VALUE is a TREE_VEC containing the field, the new value
7434 of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
7435 list to be chained to the newly created entries. */
7438 build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
7442 for (gnu_field = TYPE_FIELDS (qual_union_type);
7444 gnu_field = TREE_CHAIN (gnu_field))
7446 tree t, qual = DECL_QUALIFIER (gnu_field);
7448 for (t = subst_list; t; t = TREE_CHAIN (t))
7449 qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
7451 /* If the new qualifier is not unconditionally false, its variant may
7452 still be accessed. */
7453 if (!integer_zerop (qual))
7455 tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
7456 tree v = make_tree_vec (3);
7457 TREE_VEC_ELT (v, 0) = gnu_field;
7458 TREE_VEC_ELT (v, 1) = qual;
7459 TREE_VEC_ELT (v, 2) = NULL_TREE;
7460 gnu_list = tree_cons (variant_type, v, gnu_list);
7462 /* Recurse on the variant subpart of the variant, if any. */
7463 variant_subpart = get_variant_part (variant_type);
7464 if (variant_subpart)
7465 gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
7466 subst_list, gnu_list);
7468 /* If the new qualifier is unconditionally true, the subsequent
7469 variants cannot be accessed. */
7470 if (integer_onep (qual))
7478 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7479 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
7480 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
7481 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7482 for the size of a field. COMPONENT_P is true if we are being called
7483 to process the Component_Size of GNAT_OBJECT. This is used for error
7484 message handling and to indicate to use the object size of GNU_TYPE.
7485 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7486 it means that a size of zero should be treated as an unspecified size. */
7489 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7490 enum tree_code kind, bool component_p, bool zero_ok)
7492 Node_Id gnat_error_node;
7493 tree type_size, size;
7495 if (kind == VAR_DECL
7496 /* If a type needs strict alignment, a component of this type in
7497 a packed record cannot be packed and thus uses the type size. */
7498 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7499 type_size = TYPE_SIZE (gnu_type);
7501 type_size = rm_size (gnu_type);
7503 /* Find the node to use for errors. */
7504 if ((Ekind (gnat_object) == E_Component
7505 || Ekind (gnat_object) == E_Discriminant)
7506 && Present (Component_Clause (gnat_object)))
7507 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7508 else if (Present (Size_Clause (gnat_object)))
7509 gnat_error_node = Expression (Size_Clause (gnat_object));
7511 gnat_error_node = gnat_object;
7513 /* Return 0 if no size was specified, either because Esize was not Present
7514 or the specified size was zero. */
7515 if (No (uint_size) || uint_size == No_Uint)
7518 /* Get the size as a tree. Issue an error if a size was specified but
7519 cannot be represented in sizetype. */
7520 size = UI_To_gnu (uint_size, bitsizetype);
7521 if (TREE_OVERFLOW (size))
7523 post_error_ne (component_p ? "component size of & is too large"
7524 : "size of & is too large",
7525 gnat_error_node, gnat_object);
7529 /* Ignore a negative size since that corresponds to our back-annotation.
7530 Also ignore a zero size if it is not permitted. */
7531 if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
7534 /* The size of objects is always a multiple of a byte. */
7535 if (kind == VAR_DECL
7536 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7539 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7540 gnat_error_node, gnat_object);
7542 post_error_ne ("size for& is not a multiple of Storage_Unit",
7543 gnat_error_node, gnat_object);
7547 /* If this is an integral type or a packed array type, the front-end has
7548 verified the size, so we need not do it here (which would entail
7549 checking against the bounds). However, if this is an aliased object,
7550 it may not be smaller than the type of the object. */
7551 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7552 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7555 /* If the object is a record that contains a template, add the size of
7556 the template to the specified size. */
7557 if (TREE_CODE (gnu_type) == RECORD_TYPE
7558 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7559 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7561 /* Modify the size of the type to be that of the maximum size if it has a
7563 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7564 type_size = max_size (type_size, true);
7566 /* If this is an access type or a fat pointer, the minimum size is that given
7567 by the smallest integral mode that's valid for pointers. */
7568 if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
7570 enum machine_mode p_mode;
7572 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7573 !targetm.valid_pointer_mode (p_mode);
7574 p_mode = GET_MODE_WIDER_MODE (p_mode))
7577 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7580 /* If the size of the object is a constant, the new size must not be
7582 if (TREE_CODE (type_size) != INTEGER_CST
7583 || TREE_OVERFLOW (type_size)
7584 || tree_int_cst_lt (size, type_size))
7588 ("component size for& too small{, minimum allowed is ^}",
7589 gnat_error_node, gnat_object, type_size);
7591 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7592 gnat_error_node, gnat_object, type_size);
7594 if (kind == VAR_DECL && !component_p
7595 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7596 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7597 post_error_ne_tree_2
7598 ("\\size of ^ is not a multiple of alignment (^ bits)",
7599 gnat_error_node, gnat_object, rm_size (gnu_type),
7600 TYPE_ALIGN (gnu_type));
7602 else if (INTEGRAL_TYPE_P (gnu_type))
7603 post_error_ne ("\\size would be legal if & were not aliased!",
7604 gnat_error_node, gnat_object);
7612 /* Similarly, but both validate and process a value of RM size. This
7613 routine is only called for types. */
7616 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7618 /* Only issue an error if a Value_Size clause was explicitly given.
7619 Otherwise, we'd be duplicating an error on the Size clause. */
7620 Node_Id gnat_attr_node
7621 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7622 tree old_size = rm_size (gnu_type), size;
7624 /* Do nothing if no size was specified, either because RM size was not
7625 Present or if the specified size was zero. */
7626 if (No (uint_size) || uint_size == No_Uint)
7629 /* Get the size as a tree. Issue an error if a size was specified but
7630 cannot be represented in sizetype. */
7631 size = UI_To_gnu (uint_size, bitsizetype);
7632 if (TREE_OVERFLOW (size))
7634 if (Present (gnat_attr_node))
7635 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7640 /* Ignore a negative size since that corresponds to our back-annotation.
7641 Also ignore a zero size unless a Value_Size clause exists, or a size
7642 clause exists, or this is an integer type, in which case the front-end
7643 will have always set it. */
7644 if (tree_int_cst_sgn (size) < 0
7645 || (integer_zerop (size)
7646 && No (gnat_attr_node)
7647 && !Has_Size_Clause (gnat_entity)
7648 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7651 /* If the old size is self-referential, get the maximum size. */
7652 if (CONTAINS_PLACEHOLDER_P (old_size))
7653 old_size = max_size (old_size, true);
7655 /* If the size of the object is a constant, the new size must not be smaller
7656 (the front-end has verified this for scalar and packed array types). */
7657 if (TREE_CODE (old_size) != INTEGER_CST
7658 || TREE_OVERFLOW (old_size)
7659 || (AGGREGATE_TYPE_P (gnu_type)
7660 && !(TREE_CODE (gnu_type) == ARRAY_TYPE
7661 && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
7662 && !(TYPE_IS_PADDING_P (gnu_type)
7663 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
7664 && TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
7665 && tree_int_cst_lt (size, old_size)))
7667 if (Present (gnat_attr_node))
7669 ("Value_Size for& too small{, minimum allowed is ^}",
7670 gnat_attr_node, gnat_entity, old_size);
7674 /* Otherwise, set the RM size proper for integral types... */
7675 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
7676 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7677 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7678 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
7679 SET_TYPE_RM_SIZE (gnu_type, size);
7681 /* ...or the Ada size for record and union types. */
7682 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7683 || TREE_CODE (gnu_type) == UNION_TYPE
7684 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7685 && !TYPE_FAT_POINTER_P (gnu_type))
7686 SET_TYPE_ADA_SIZE (gnu_type, size);
7689 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7690 If TYPE is the best type, return it. Otherwise, make a new type. We
7691 only support new integral and pointer types. FOR_BIASED is true if
7692 we are making a biased type. */
7695 make_type_from_size (tree type, tree size_tree, bool for_biased)
7697 unsigned HOST_WIDE_INT size;
7701 /* If size indicates an error, just return TYPE to avoid propagating
7702 the error. Likewise if it's too large to represent. */
7703 if (!size_tree || !host_integerp (size_tree, 1))
7706 size = tree_low_cst (size_tree, 1);
7708 switch (TREE_CODE (type))
7713 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7714 && TYPE_BIASED_REPRESENTATION_P (type));
7716 /* Integer types with precision 0 are forbidden. */
7720 /* Only do something if the type is not a packed array type and
7721 doesn't already have the proper size. */
7722 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7723 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7726 biased_p |= for_biased;
7727 if (size > LONG_LONG_TYPE_SIZE)
7728 size = LONG_LONG_TYPE_SIZE;
7730 if (TYPE_UNSIGNED (type) || biased_p)
7731 new_type = make_unsigned_type (size);
7733 new_type = make_signed_type (size);
7734 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7735 SET_TYPE_RM_MIN_VALUE (new_type,
7736 convert (TREE_TYPE (new_type),
7737 TYPE_MIN_VALUE (type)));
7738 SET_TYPE_RM_MAX_VALUE (new_type,
7739 convert (TREE_TYPE (new_type),
7740 TYPE_MAX_VALUE (type)));
7741 /* Propagate the name to avoid creating a fake subrange type. */
7742 if (TYPE_NAME (type))
7744 if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL)
7745 TYPE_NAME (new_type) = DECL_NAME (TYPE_NAME (type));
7747 TYPE_NAME (new_type) = TYPE_NAME (type);
7749 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7750 SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
7754 /* Do something if this is a fat pointer, in which case we
7755 may need to return the thin pointer. */
7756 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7758 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7759 if (!targetm.valid_pointer_mode (p_mode))
7762 build_pointer_type_for_mode
7763 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7769 /* Only do something if this is a thin pointer, in which case we
7770 may need to return the fat pointer. */
7771 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7773 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7783 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7784 a type or object whose present alignment is ALIGN. If this alignment is
7785 valid, return it. Otherwise, give an error and return ALIGN. */
7788 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7790 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7791 unsigned int new_align;
7792 Node_Id gnat_error_node;
7794 /* Don't worry about checking alignment if alignment was not specified
7795 by the source program and we already posted an error for this entity. */
7796 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7799 /* Post the error on the alignment clause if any. Note, for the implicit
7800 base type of an array type, the alignment clause is on the first
7802 if (Present (Alignment_Clause (gnat_entity)))
7803 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7805 else if (Is_Itype (gnat_entity)
7806 && Is_Array_Type (gnat_entity)
7807 && Etype (gnat_entity) == gnat_entity
7808 && Present (Alignment_Clause (First_Subtype (gnat_entity))))
7810 Expression (Alignment_Clause (First_Subtype (gnat_entity)));
7813 gnat_error_node = gnat_entity;
7815 /* Within GCC, an alignment is an integer, so we must make sure a value is
7816 specified that fits in that range. Also, there is an upper bound to
7817 alignments we can support/allow. */
7818 if (!UI_Is_In_Int_Range (alignment)
7819 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7820 post_error_ne_num ("largest supported alignment for& is ^",
7821 gnat_error_node, gnat_entity, max_allowed_alignment);
7822 else if (!(Present (Alignment_Clause (gnat_entity))
7823 && From_At_Mod (Alignment_Clause (gnat_entity)))
7824 && new_align * BITS_PER_UNIT < align)
7826 unsigned int double_align;
7827 bool is_capped_double, align_clause;
7829 /* If the default alignment of "double" or larger scalar types is
7830 specifically capped and the new alignment is above the cap, do
7831 not post an error and change the alignment only if there is an
7832 alignment clause; this makes it possible to have the associated
7833 GCC type overaligned by default for performance reasons. */
7834 if ((double_align = double_float_alignment) > 0)
7837 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7839 = is_double_float_or_array (gnat_type, &align_clause);
7841 else if ((double_align = double_scalar_alignment) > 0)
7844 = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
7846 = is_double_scalar_or_array (gnat_type, &align_clause);
7849 is_capped_double = align_clause = false;
7851 if (is_capped_double && new_align >= double_align)
7854 align = new_align * BITS_PER_UNIT;
7858 if (is_capped_double)
7859 align = double_align * BITS_PER_UNIT;
7861 post_error_ne_num ("alignment for& must be at least ^",
7862 gnat_error_node, gnat_entity,
7863 align / BITS_PER_UNIT);
7868 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7869 if (new_align > align)
7876 /* Return the smallest alignment not less than SIZE. */
7879 ceil_alignment (unsigned HOST_WIDE_INT size)
7881 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7884 /* Verify that OBJECT, a type or decl, is something we can implement
7885 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7886 if we require atomic components. */
7889 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7891 Node_Id gnat_error_point = gnat_entity;
7893 enum machine_mode mode;
7897 /* There are three case of what OBJECT can be. It can be a type, in which
7898 case we take the size, alignment and mode from the type. It can be a
7899 declaration that was indirect, in which case the relevant values are
7900 that of the type being pointed to, or it can be a normal declaration,
7901 in which case the values are of the decl. The code below assumes that
7902 OBJECT is either a type or a decl. */
7903 if (TYPE_P (object))
7905 /* If this is an anonymous base type, nothing to check. Error will be
7906 reported on the source type. */
7907 if (!Comes_From_Source (gnat_entity))
7910 mode = TYPE_MODE (object);
7911 align = TYPE_ALIGN (object);
7912 size = TYPE_SIZE (object);
7914 else if (DECL_BY_REF_P (object))
7916 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7917 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7918 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7922 mode = DECL_MODE (object);
7923 align = DECL_ALIGN (object);
7924 size = DECL_SIZE (object);
7927 /* Consider all floating-point types atomic and any types that that are
7928 represented by integers no wider than a machine word. */
7929 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7930 || ((GET_MODE_CLASS (mode) == MODE_INT
7931 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7932 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7935 /* For the moment, also allow anything that has an alignment equal
7936 to its size and which is smaller than a word. */
7937 if (size && TREE_CODE (size) == INTEGER_CST
7938 && compare_tree_int (size, align) == 0
7939 && align <= BITS_PER_WORD)
7942 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7943 gnat_node = Next_Rep_Item (gnat_node))
7945 if (!comp_p && Nkind (gnat_node) == N_Pragma
7946 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7948 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7949 else if (comp_p && Nkind (gnat_node) == N_Pragma
7950 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7951 == Pragma_Atomic_Components))
7952 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7956 post_error_ne ("atomic access to component of & cannot be guaranteed",
7957 gnat_error_point, gnat_entity);
7959 post_error_ne ("atomic access to & cannot be guaranteed",
7960 gnat_error_point, gnat_entity);
7963 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7964 have compatible signatures so that a call using one type may be safely
7965 issued if the actual target function type is the other. Return 1 if it is
7966 the case, 0 otherwise, and post errors on the incompatibilities.
7968 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7969 that calls to the subprogram will have arguments suitable for the later
7970 underlying builtin expansion. */
7973 compatible_signatures_p (tree ftype1, tree ftype2)
7975 /* As of now, we only perform very trivial tests and consider it's the
7976 programmer's responsibility to ensure the type correctness in the Ada
7977 declaration, as in the regular Import cases.
7979 Mismatches typically result in either error messages from the builtin
7980 expander, internal compiler errors, or in a real call sequence. This
7981 should be refined to issue diagnostics helping error detection and
7984 /* Almost fake test, ensuring a use of each argument. */
7985 if (ftype1 == ftype2)
7991 /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
7992 and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
7993 specified size for this field. POS_LIST is a position list describing
7994 the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
7998 create_field_decl_from (tree old_field, tree field_type, tree record_type,
7999 tree size, tree pos_list, tree subst_list)
8001 tree t = TREE_VALUE (purpose_member (old_field, pos_list));
8002 tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
8003 unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
8004 tree new_pos, new_field;
8006 if (CONTAINS_PLACEHOLDER_P (pos))
8007 for (t = subst_list; t; t = TREE_CHAIN (t))
8008 pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
8010 /* If the position is now a constant, we can set it as the position of the
8011 field when we make it. Otherwise, we need to deal with it specially. */
8012 if (TREE_CONSTANT (pos))
8013 new_pos = bit_from_pos (pos, bitpos);
8015 new_pos = NULL_TREE;
8018 = create_field_decl (DECL_NAME (old_field), field_type, record_type,
8019 DECL_PACKED (old_field), size, new_pos,
8020 !DECL_NONADDRESSABLE_P (old_field));
8024 normalize_offset (&pos, &bitpos, offset_align);
8025 DECL_FIELD_OFFSET (new_field) = pos;
8026 DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
8027 SET_DECL_OFFSET_ALIGN (new_field, offset_align);
8028 DECL_SIZE (new_field) = size;
8029 DECL_SIZE_UNIT (new_field)
8030 = convert (sizetype,
8031 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
8032 layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
8035 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
8036 t = DECL_ORIGINAL_FIELD (old_field);
8037 SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
8038 DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
8039 TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
8044 /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
8047 get_rep_part (tree record_type)
8049 tree field = TYPE_FIELDS (record_type);
8051 /* The REP part is the first field, internal, another record, and its name
8052 doesn't start with an underscore (i.e. is not generated by the FE). */
8053 if (DECL_INTERNAL_P (field)
8054 && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
8055 && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
8061 /* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
8064 get_variant_part (tree record_type)
8068 /* The variant part is the only internal field that is a qualified union. */
8069 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
8070 if (DECL_INTERNAL_P (field)
8071 && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
8077 /* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
8078 the list of variants to be used and RECORD_TYPE is the type of the parent.
8079 POS_LIST is a position list describing the layout of fields present in
8080 OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
8084 create_variant_part_from (tree old_variant_part, tree variant_list,
8085 tree record_type, tree pos_list, tree subst_list)
8087 tree offset = DECL_FIELD_OFFSET (old_variant_part);
8088 tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
8089 tree old_union_type = TREE_TYPE (old_variant_part);
8090 tree new_union_type, new_variant_part, t;
8091 tree union_field_list = NULL_TREE;
8093 /* First create the type of the variant part from that of the old one. */
8094 new_union_type = make_node (QUAL_UNION_TYPE);
8095 TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
8097 /* If the position of the variant part is constant, subtract it from the
8098 size of the type of the parent to get the new size. This manual CSE
8099 reduces the code size when not optimizing. */
8100 if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
8102 tree first_bit = bit_from_pos (offset, bitpos);
8103 TYPE_SIZE (new_union_type)
8104 = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
8105 TYPE_SIZE_UNIT (new_union_type)
8106 = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
8107 byte_from_pos (offset, bitpos));
8108 SET_TYPE_ADA_SIZE (new_union_type,
8109 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
8111 TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
8112 relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
8115 copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
8117 /* Now finish up the new variants and populate the union type. */
8118 for (t = variant_list; t; t = TREE_CHAIN (t))
8120 tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
8121 tree old_variant, old_variant_subpart, new_variant, field_list;
8123 /* Skip variants that don't belong to this nesting level. */
8124 if (DECL_CONTEXT (old_field) != old_union_type)
8127 /* Retrieve the list of fields already added to the new variant. */
8128 new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
8129 field_list = TYPE_FIELDS (new_variant);
8131 /* If the old variant had a variant subpart, we need to create a new
8132 variant subpart and add it to the field list. */
8133 old_variant = TREE_PURPOSE (t);
8134 old_variant_subpart = get_variant_part (old_variant);
8135 if (old_variant_subpart)
8137 tree new_variant_subpart
8138 = create_variant_part_from (old_variant_subpart, variant_list,
8139 new_variant, pos_list, subst_list);
8140 TREE_CHAIN (new_variant_subpart) = field_list;
8141 field_list = new_variant_subpart;
8144 /* Finish up the new variant and create the field. */
8145 finish_record_type (new_variant, nreverse (field_list), 2, true);
8146 compute_record_mode (new_variant);
8147 rest_of_record_type_compilation (new_variant);
8149 /* No need for debug info thanks to the XVS type. */
8150 create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
8151 true, false, Empty);
8154 = create_field_decl_from (old_field, new_variant, new_union_type,
8155 TYPE_SIZE (new_variant),
8156 pos_list, subst_list);
8157 DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
8158 DECL_INTERNAL_P (new_field) = 1;
8159 TREE_CHAIN (new_field) = union_field_list;
8160 union_field_list = new_field;
8163 /* Finish up the union type and create the variant part. */
8164 finish_record_type (new_union_type, union_field_list, 2, true);
8165 compute_record_mode (new_union_type);
8166 rest_of_record_type_compilation (new_union_type);
8168 /* No need for debug info thanks to the XVS type. */
8169 create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
8170 true, false, Empty);
8173 = create_field_decl_from (old_variant_part, new_union_type, record_type,
8174 TYPE_SIZE (new_union_type),
8175 pos_list, subst_list);
8176 DECL_INTERNAL_P (new_variant_part) = 1;
8178 /* With multiple discriminants it is possible for an inner variant to be
8179 statically selected while outer ones are not; in this case, the list
8180 of fields of the inner variant is not flattened and we end up with a
8181 qualified union with a single member. Drop the useless container. */
8182 if (!TREE_CHAIN (union_field_list))
8184 DECL_CONTEXT (union_field_list) = record_type;
8185 DECL_FIELD_OFFSET (union_field_list)
8186 = DECL_FIELD_OFFSET (new_variant_part);
8187 DECL_FIELD_BIT_OFFSET (union_field_list)
8188 = DECL_FIELD_BIT_OFFSET (new_variant_part);
8189 SET_DECL_OFFSET_ALIGN (union_field_list,
8190 DECL_OFFSET_ALIGN (new_variant_part));
8191 new_variant_part = union_field_list;
8194 return new_variant_part;
8197 /* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
8198 which are both RECORD_TYPE, after applying the substitutions described
8202 copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
8206 TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
8207 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
8208 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
8209 TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
8210 relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
8212 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
8213 for (t = subst_list; t; t = TREE_CHAIN (t))
8214 TYPE_SIZE (new_type)
8215 = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
8219 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
8220 for (t = subst_list; t; t = TREE_CHAIN (t))
8221 TYPE_SIZE_UNIT (new_type)
8222 = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
8226 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
8227 for (t = subst_list; t; t = TREE_CHAIN (t))
8229 (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
8233 /* Finalize the size. */
8234 TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
8235 TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
8238 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
8239 type with all size expressions that contain F in a PLACEHOLDER_EXPR
8240 updated by replacing F with R.
8242 The function doesn't update the layout of the type, i.e. it assumes
8243 that the substitution is purely formal. That's why the replacement
8244 value R must itself contain a PLACEHOLDER_EXPR. */
8247 substitute_in_type (tree t, tree f, tree r)
8251 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
8253 switch (TREE_CODE (t))
8260 /* First the domain types of arrays. */
8261 if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
8262 || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
8264 tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
8265 tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
8267 if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
8271 TYPE_GCC_MIN_VALUE (nt) = low;
8272 TYPE_GCC_MAX_VALUE (nt) = high;
8274 if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
8276 (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
8281 /* Then the subtypes. */
8282 if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
8283 || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
8285 tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
8286 tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
8288 if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
8292 SET_TYPE_RM_MIN_VALUE (nt, low);
8293 SET_TYPE_RM_MAX_VALUE (nt, high);
8301 nt = substitute_in_type (TREE_TYPE (t), f, r);
8302 if (nt == TREE_TYPE (t))
8305 return build_complex_type (nt);
8311 /* These should never show up here. */
8316 tree component = substitute_in_type (TREE_TYPE (t), f, r);
8317 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
8319 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
8322 nt = build_array_type (component, domain);
8323 TYPE_ALIGN (nt) = TYPE_ALIGN (t);
8324 TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
8325 SET_TYPE_MODE (nt, TYPE_MODE (t));
8326 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8327 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8328 TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
8329 TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
8330 TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
8336 case QUAL_UNION_TYPE:
8338 bool changed_field = false;
8341 /* Start out with no fields, make new fields, and chain them
8342 in. If we haven't actually changed the type of any field,
8343 discard everything we've done and return the old type. */
8345 TYPE_FIELDS (nt) = NULL_TREE;
8347 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
8349 tree new_field = copy_node (field), new_n;
8351 new_n = substitute_in_type (TREE_TYPE (field), f, r);
8352 if (new_n != TREE_TYPE (field))
8354 TREE_TYPE (new_field) = new_n;
8355 changed_field = true;
8358 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
8359 if (new_n != DECL_FIELD_OFFSET (field))
8361 DECL_FIELD_OFFSET (new_field) = new_n;
8362 changed_field = true;
8365 /* Do the substitution inside the qualifier, if any. */
8366 if (TREE_CODE (t) == QUAL_UNION_TYPE)
8368 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
8369 if (new_n != DECL_QUALIFIER (field))
8371 DECL_QUALIFIER (new_field) = new_n;
8372 changed_field = true;
8376 DECL_CONTEXT (new_field) = nt;
8377 SET_DECL_ORIGINAL_FIELD (new_field,
8378 (DECL_ORIGINAL_FIELD (field)
8379 ? DECL_ORIGINAL_FIELD (field) : field));
8381 TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
8382 TYPE_FIELDS (nt) = new_field;
8388 TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
8389 TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
8390 TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
8391 SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
8400 /* Return the RM size of GNU_TYPE. This is the actual number of bits
8401 needed to represent the object. */
8404 rm_size (tree gnu_type)
8406 /* For integral types, we store the RM size explicitly. */
8407 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
8408 return TYPE_RM_SIZE (gnu_type);
8410 /* Return the RM size of the actual data plus the size of the template. */
8411 if (TREE_CODE (gnu_type) == RECORD_TYPE
8412 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
8414 size_binop (PLUS_EXPR,
8415 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
8416 DECL_SIZE (TYPE_FIELDS (gnu_type)));
8418 /* For record types, we store the size explicitly. */
8419 if ((TREE_CODE (gnu_type) == RECORD_TYPE
8420 || TREE_CODE (gnu_type) == UNION_TYPE
8421 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
8422 && !TYPE_FAT_POINTER_P (gnu_type)
8423 && TYPE_ADA_SIZE (gnu_type))
8424 return TYPE_ADA_SIZE (gnu_type);
8426 /* For other types, this is just the size. */
8427 return TYPE_SIZE (gnu_type);
8430 /* Return the name to be used for GNAT_ENTITY. If a type, create a
8431 fully-qualified name, possibly with type information encoding.
8432 Otherwise, return the name. */
8435 get_entity_name (Entity_Id gnat_entity)
8437 Get_Encoded_Name (gnat_entity);
8438 return get_identifier_with_length (Name_Buffer, Name_Len);
8441 /* Return an identifier representing the external name to be used for
8442 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
8443 and the specified suffix. */
8446 create_concat_name (Entity_Id gnat_entity, const char *suffix)
8448 Entity_Kind kind = Ekind (gnat_entity);
8452 String_Template temp = {1, strlen (suffix)};
8453 Fat_Pointer fp = {suffix, &temp};
8454 Get_External_Name_With_Suffix (gnat_entity, fp);
8457 Get_External_Name (gnat_entity, 0);
8459 /* A variable using the Stdcall convention lives in a DLL. We adjust
8460 its name to use the jump table, the _imp__NAME contains the address
8461 for the NAME variable. */
8462 if ((kind == E_Variable || kind == E_Constant)
8463 && Has_Stdcall_Convention (gnat_entity))
8465 const int len = 6 + Name_Len;
8466 char *new_name = (char *) alloca (len + 1);
8467 strcpy (new_name, "_imp__");
8468 strcat (new_name, Name_Buffer);
8469 return get_identifier_with_length (new_name, len);
8472 return get_identifier_with_length (Name_Buffer, Name_Len);
8475 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
8476 string, return a new IDENTIFIER_NODE that is the concatenation of
8477 the name followed by "___" and the specified suffix. */
8480 concat_name (tree gnu_name, const char *suffix)
8482 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
8483 char *new_name = (char *) alloca (len + 1);
8484 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
8485 strcat (new_name, "___");
8486 strcat (new_name, suffix);
8487 return get_identifier_with_length (new_name, len);
8490 #include "gt-ada-decl.h"
OSDN Git Service
