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"
56 #ifndef MAX_FIXED_MODE_SIZE
57 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
60 /* Convention_Stdcall should be processed in a specific way on Windows targets
61 only. The macro below is a helper to avoid having to check for a Windows
62 specific attribute throughout this unit. */
64 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
65 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
67 #define Has_Stdcall_Convention(E) (0)
70 /* Stack realignment for functions with foreign conventions is provided on a
71 per back-end basis now, as it is handled by the prologue expanders and not
72 as part of the function's body any more. It might be requested by way of a
73 dedicated function type attribute on the targets that support it.
75 We need a way to avoid setting the attribute on the targets that don't
76 support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
78 It is defined on targets where the circuitry is available, and indicates
79 whether the realignment is needed for 'main'. We use this to decide for
80 foreign subprograms as well.
82 It is not defined on targets where the circuitry is not implemented, and
83 we just never set the attribute in these cases.
85 Whether it is defined on all targets that would need it in theory is
86 not entirely clear. We currently trust the base GCC settings for this
89 #ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
90 #define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
95 struct incomplete *next;
100 /* These variables are used to defer recursively expanding incomplete types
101 while we are processing an array, a record or a subprogram type. */
102 static int defer_incomplete_level = 0;
103 static struct incomplete *defer_incomplete_list;
105 /* This variable is used to delay expanding From_With_Type types until the
107 static struct incomplete *defer_limited_with;
109 /* These variables are used to defer finalizing types. The element of the
110 list is the TYPE_DECL associated with the type. */
111 static int defer_finalize_level = 0;
112 static VEC (tree,heap) *defer_finalize_list;
114 /* A hash table used to cache the result of annotate_value. */
115 static GTY ((if_marked ("tree_int_map_marked_p"),
116 param_is (struct tree_int_map))) htab_t annotate_value_cache;
125 static void relate_alias_sets (tree, tree, enum alias_set_op);
127 static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
128 static bool allocatable_size_p (tree, bool);
129 static void prepend_one_attribute_to (struct attrib **,
130 enum attr_type, tree, tree, Node_Id);
131 static void prepend_attributes (Entity_Id, struct attrib **);
132 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
133 static bool is_variable_size (tree);
134 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
136 static tree make_packable_type (tree, bool);
137 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
138 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
140 static bool same_discriminant_p (Entity_Id, Entity_Id);
141 static bool array_type_has_nonaliased_component (Entity_Id, tree);
142 static bool compile_time_known_address_p (Node_Id);
143 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
144 bool, bool, bool, bool);
145 static Uint annotate_value (tree);
146 static void annotate_rep (Entity_Id, tree);
147 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
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 ftype1, tree ftype2);
155 static void rest_of_type_decl_compilation_no_defer (tree);
157 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
158 entity, return the equivalent GCC tree for that entity (a ..._DECL node)
159 and associate the ..._DECL node with the input GNAT defining identifier.
161 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
162 initial value (in GCC tree form). This is optional for a variable. For
163 a renamed entity, GNU_EXPR gives the object being renamed.
165 DEFINITION is nonzero if this call is intended for a definition. This is
166 used for separate compilation where it is necessary to know whether an
167 external declaration or a definition must be created if the GCC equivalent
168 was not created previously. The value of 1 is normally used for a nonzero
169 DEFINITION, but a value of 2 is used in special circumstances, defined in
173 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
175 Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
177 Entity_Kind kind = Ekind (gnat_entity);
178 /* Contains the GCC DECL node which is equivalent to the input GNAT node.
179 This node will be associated with the GNAT node by calling at the end
180 of the `switch' statement. */
181 tree gnu_decl = NULL_TREE;
182 /* Contains the GCC type to be used for the GCC node. */
183 tree gnu_type = NULL_TREE;
184 /* Contains the GCC size tree to be used for the GCC node. */
185 tree gnu_size = NULL_TREE;
186 /* Contains the GCC name to be used for the GCC node. */
187 tree gnu_entity_name;
188 /* True if we have already saved gnu_decl as a GNAT association. */
190 /* True if we incremented defer_incomplete_level. */
191 bool this_deferred = false;
192 /* True if we incremented force_global. */
193 bool this_global = false;
194 /* True if we should check to see if elaborated during processing. */
195 bool maybe_present = false;
196 /* True if we made GNU_DECL and its type here. */
197 bool this_made_decl = false;
198 /* True if debug info is requested for this entity. */
199 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
200 || debug_info_level == DINFO_LEVEL_VERBOSE);
201 /* True if this entity is to be considered as imported. */
202 bool imported_p = (Is_Imported (gnat_entity)
203 && No (Address_Clause (gnat_entity)));
204 unsigned int esize, align = 0;
205 struct attrib *attr_list = NULL;
207 /* First compute a default value for the size of the entity. */
208 if (Known_Esize (gnat_entity) && UI_Is_In_Int_Range (Esize (gnat_entity)))
210 unsigned int max_esize;
211 esize = UI_To_Int (Esize (gnat_entity));
213 if (IN (kind, Float_Kind))
214 max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
215 else if (IN (kind, Access_Kind))
216 max_esize = POINTER_SIZE * 2;
218 max_esize = LONG_LONG_TYPE_SIZE;
220 esize = MIN (esize, max_esize);
223 esize = LONG_LONG_TYPE_SIZE;
225 /* Since a use of an Itype is a definition, process it as such if it
226 is not in a with'ed unit. */
228 && Is_Itype (gnat_entity)
229 && !present_gnu_tree (gnat_entity)
230 && In_Extended_Main_Code_Unit (gnat_entity))
232 /* Ensure that we are in a subprogram mentioned in the Scope chain of
233 this entity, our current scope is global, or we encountered a task
234 or entry (where we can't currently accurately check scoping). */
235 if (!current_function_decl
236 || DECL_ELABORATION_PROC_P (current_function_decl))
238 process_type (gnat_entity);
239 return get_gnu_tree (gnat_entity);
242 for (gnat_temp = Scope (gnat_entity);
244 gnat_temp = Scope (gnat_temp))
246 if (Is_Type (gnat_temp))
247 gnat_temp = Underlying_Type (gnat_temp);
249 if (Ekind (gnat_temp) == E_Subprogram_Body)
251 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
253 if (IN (Ekind (gnat_temp), Subprogram_Kind)
254 && Present (Protected_Body_Subprogram (gnat_temp)))
255 gnat_temp = Protected_Body_Subprogram (gnat_temp);
257 if (Ekind (gnat_temp) == E_Entry
258 || Ekind (gnat_temp) == E_Entry_Family
259 || Ekind (gnat_temp) == E_Task_Type
260 || (IN (Ekind (gnat_temp), Subprogram_Kind)
261 && present_gnu_tree (gnat_temp)
262 && (current_function_decl
263 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
265 process_type (gnat_entity);
266 return get_gnu_tree (gnat_entity);
270 /* This abort means the entity has an incorrect scope, i.e. that its
271 scope does not correspond to the subprogram it is declared in. */
275 /* If the entiy is not present, something went badly wrong. */
276 gcc_assert (Present (gnat_entity));
278 /* If we've already processed this entity, return what we got last time.
279 If we are defining the node, we should not have already processed it.
280 In that case, we will abort below when we try to save a new GCC tree
281 for this object. We also need to handle the case of getting a dummy
282 type when a Full_View exists. */
283 if (present_gnu_tree (gnat_entity)
284 && (!definition || (Is_Type (gnat_entity) && imported_p)))
286 gnu_decl = get_gnu_tree (gnat_entity);
288 if (TREE_CODE (gnu_decl) == TYPE_DECL
289 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
290 && IN (kind, Incomplete_Or_Private_Kind)
291 && Present (Full_View (gnat_entity)))
294 = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
295 save_gnu_tree (gnat_entity, NULL_TREE, false);
296 save_gnu_tree (gnat_entity, gnu_decl, false);
302 /* If this is a numeric or enumeral type, or an access type, a nonzero
303 Esize must be specified unless it was specified by the programmer. */
304 gcc_assert (!Unknown_Esize (gnat_entity)
305 || Has_Size_Clause (gnat_entity)
306 || (!IN (kind, Numeric_Kind)
307 && !IN (kind, Enumeration_Kind)
308 && (!IN (kind, Access_Kind)
309 || kind == E_Access_Protected_Subprogram_Type
310 || kind == E_Anonymous_Access_Protected_Subprogram_Type
311 || kind == E_Access_Subtype)));
313 /* The RM size must be specified for all discrete and fixed-point types. */
314 gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
315 || !Unknown_RM_Size (gnat_entity));
317 /* Get the name of the entity and set up the line number and filename of
318 the original definition for use in any decl we make. */
319 gnu_entity_name = get_entity_name (gnat_entity);
320 Sloc_to_locus (Sloc (gnat_entity), &input_location);
322 /* If we get here, it means we have not yet done anything with this
323 entity. If we are not defining it here, it must be external,
324 otherwise we should have defined it already. */
325 gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
326 || kind == E_Discriminant || kind == E_Component
328 || (kind == E_Constant && Present (Full_View (gnat_entity)))
329 || IN (kind, Type_Kind));
331 /* For cases when we are not defining (i.e., we are referencing from
332 another compilation unit) public entities, show we are at global level
333 for the purpose of computing scopes. Don't do this for components or
334 discriminants since the relevant test is whether or not the record is
337 && Is_Public (gnat_entity)
338 && !Is_Statically_Allocated (gnat_entity)
339 && kind != E_Component
340 && kind != E_Discriminant)
341 force_global++, this_global = true;
343 /* Handle any attributes directly attached to the entity. */
344 if (Has_Gigi_Rep_Item (gnat_entity))
345 prepend_attributes (gnat_entity, &attr_list);
347 /* Machine_Attributes on types are expected to be propagated to subtypes.
348 The corresponding Gigi_Rep_Items are only attached to the first subtype
349 though, so we handle the propagation here. */
350 if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
351 && !Is_First_Subtype (gnat_entity)
352 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
353 prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
358 /* If this is a use of a deferred constant without address clause,
359 get its full definition. */
361 && No (Address_Clause (gnat_entity))
362 && Present (Full_View (gnat_entity)))
365 = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
370 /* If we have an external constant that we are not defining, get the
371 expression that is was defined to represent. We may throw that
372 expression away later if it is not a constant. Do not retrieve the
373 expression if it is an aggregate or allocator, because in complex
374 instantiation contexts it may not be expanded */
376 && Present (Expression (Declaration_Node (gnat_entity)))
377 && !No_Initialization (Declaration_Node (gnat_entity))
378 && (Nkind (Expression (Declaration_Node (gnat_entity)))
380 && (Nkind (Expression (Declaration_Node (gnat_entity)))
382 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
384 /* Ignore deferred constant definitions without address clause since
385 they are processed fully in the front-end. If No_Initialization
386 is set, this is not a deferred constant but a constant whose value
387 is built manually. And constants that are renamings are handled
391 && No (Address_Clause (gnat_entity))
392 && !No_Initialization (Declaration_Node (gnat_entity))
393 && No (Renamed_Object (gnat_entity)))
395 gnu_decl = error_mark_node;
400 /* Ignore constant definitions already marked with the error node. See
401 the N_Object_Declaration case of gnat_to_gnu for the rationale. */
404 && present_gnu_tree (gnat_entity)
405 && get_gnu_tree (gnat_entity) == error_mark_node)
407 maybe_present = true;
414 /* We used to special case VMS exceptions here to directly map them to
415 their associated condition code. Since this code had to be masked
416 dynamically to strip off the severity bits, this caused trouble in
417 the GCC/ZCX case because the "type" pointers we store in the tables
418 have to be static. We now don't special case here anymore, and let
419 the regular processing take place, which leaves us with a regular
420 exception data object for VMS exceptions too. The condition code
421 mapping is taken care of by the front end and the bitmasking by the
428 /* The GNAT record where the component was defined. */
429 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
431 /* If the variable is an inherited record component (in the case of
432 extended record types), just return the inherited entity, which
433 must be a FIELD_DECL. Likewise for discriminants.
434 For discriminants of untagged records which have explicit
435 stored discriminants, return the entity for the corresponding
436 stored discriminant. Also use Original_Record_Component
437 if the record has a private extension. */
438 if (Present (Original_Record_Component (gnat_entity))
439 && Original_Record_Component (gnat_entity) != gnat_entity)
442 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
443 gnu_expr, definition);
448 /* If the enclosing record has explicit stored discriminants,
449 then it is an untagged record. If the Corresponding_Discriminant
450 is not empty then this must be a renamed discriminant and its
451 Original_Record_Component must point to the corresponding explicit
452 stored discriminant (i.e. we should have taken the previous
454 else if (Present (Corresponding_Discriminant (gnat_entity))
455 && Is_Tagged_Type (gnat_record))
457 /* A tagged record has no explicit stored discriminants. */
458 gcc_assert (First_Discriminant (gnat_record)
459 == First_Stored_Discriminant (gnat_record));
461 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
462 gnu_expr, definition);
467 else if (Present (CR_Discriminant (gnat_entity))
468 && type_annotate_only)
470 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
471 gnu_expr, definition);
476 /* If the enclosing record has explicit stored discriminants, then
477 it is an untagged record. If the Corresponding_Discriminant
478 is not empty then this must be a renamed discriminant and its
479 Original_Record_Component must point to the corresponding explicit
480 stored discriminant (i.e. we should have taken the first
482 else if (Present (Corresponding_Discriminant (gnat_entity))
483 && (First_Discriminant (gnat_record)
484 != First_Stored_Discriminant (gnat_record)))
487 /* Otherwise, if we are not defining this and we have no GCC type
488 for the containing record, make one for it. Then we should
489 have made our own equivalent. */
490 else if (!definition && !present_gnu_tree (gnat_record))
492 /* ??? If this is in a record whose scope is a protected
493 type and we have an Original_Record_Component, use it.
494 This is a workaround for major problems in protected type
496 Entity_Id Scop = Scope (Scope (gnat_entity));
497 if ((Is_Protected_Type (Scop)
498 || (Is_Private_Type (Scop)
499 && Present (Full_View (Scop))
500 && Is_Protected_Type (Full_View (Scop))))
501 && Present (Original_Record_Component (gnat_entity)))
504 = gnat_to_gnu_entity (Original_Record_Component
511 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
512 gnu_decl = get_gnu_tree (gnat_entity);
518 /* Here we have no GCC type and this is a reference rather than a
519 definition. This should never happen. Most likely the cause is
520 reference before declaration in the gnat tree for gnat_entity. */
524 case E_Loop_Parameter:
525 case E_Out_Parameter:
528 /* Simple variables, loop variables, Out parameters, and exceptions. */
531 bool used_by_ref = false;
533 = ((kind == E_Constant || kind == E_Variable)
534 && Is_True_Constant (gnat_entity)
535 && !Treat_As_Volatile (gnat_entity)
536 && (((Nkind (Declaration_Node (gnat_entity))
537 == N_Object_Declaration)
538 && Present (Expression (Declaration_Node (gnat_entity))))
539 || Present (Renamed_Object (gnat_entity))));
540 bool inner_const_flag = const_flag;
541 bool static_p = Is_Statically_Allocated (gnat_entity);
542 bool mutable_p = false;
543 tree gnu_ext_name = NULL_TREE;
544 tree renamed_obj = NULL_TREE;
545 tree gnu_object_size;
547 if (Present (Renamed_Object (gnat_entity)) && !definition)
549 if (kind == E_Exception)
550 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
553 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
556 /* Get the type after elaborating the renamed object. */
557 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
559 /* For a debug renaming declaration, build a pure debug entity. */
560 if (Present (Debug_Renaming_Link (gnat_entity)))
563 gnu_decl = build_decl (VAR_DECL, gnu_entity_name, gnu_type);
564 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
565 if (global_bindings_p ())
566 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
568 addr = stack_pointer_rtx;
569 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
570 gnat_pushdecl (gnu_decl, gnat_entity);
574 /* If this is a loop variable, its type should be the base type.
575 This is because the code for processing a loop determines whether
576 a normal loop end test can be done by comparing the bounds of the
577 loop against those of the base type, which is presumed to be the
578 size used for computation. But this is not correct when the size
579 of the subtype is smaller than the type. */
580 if (kind == E_Loop_Parameter)
581 gnu_type = get_base_type (gnu_type);
583 /* Reject non-renamed objects whose types are unconstrained arrays or
584 any object whose type is a dummy type or VOID_TYPE. */
586 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
587 && No (Renamed_Object (gnat_entity)))
588 || TYPE_IS_DUMMY_P (gnu_type)
589 || TREE_CODE (gnu_type) == VOID_TYPE)
591 gcc_assert (type_annotate_only);
594 return error_mark_node;
597 /* If an alignment is specified, use it if valid. Note that
598 exceptions are objects but don't have alignments. We must do this
599 before we validate the size, since the alignment can affect the
601 if (kind != E_Exception && Known_Alignment (gnat_entity))
603 gcc_assert (Present (Alignment (gnat_entity)));
604 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
605 TYPE_ALIGN (gnu_type));
606 gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
607 "PAD", false, definition, true);
610 /* If we are defining the object, see if it has a Size value and
611 validate it if so. If we are not defining the object and a Size
612 clause applies, simply retrieve the value. We don't want to ignore
613 the clause and it is expected to have been validated already. Then
614 get the new type, if any. */
616 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
617 gnat_entity, VAR_DECL, false,
618 Has_Size_Clause (gnat_entity));
619 else if (Has_Size_Clause (gnat_entity))
620 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
625 = make_type_from_size (gnu_type, gnu_size,
626 Has_Biased_Representation (gnat_entity));
628 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
629 gnu_size = NULL_TREE;
632 /* If this object has self-referential size, it must be a record with
633 a default value. We are supposed to allocate an object of the
634 maximum size in this case unless it is a constant with an
635 initializing expression, in which case we can get the size from
636 that. Note that the resulting size may still be a variable, so
637 this may end up with an indirect allocation. */
638 if (No (Renamed_Object (gnat_entity))
639 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
641 if (gnu_expr && kind == E_Constant)
643 tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
644 if (CONTAINS_PLACEHOLDER_P (size))
646 /* If the initializing expression is itself a constant,
647 despite having a nominal type with self-referential
648 size, we can get the size directly from it. */
649 if (TREE_CODE (gnu_expr) == COMPONENT_REF
650 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
653 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
654 && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
655 && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
656 || DECL_READONLY_ONCE_ELAB
657 (TREE_OPERAND (gnu_expr, 0))))
658 gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
661 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
666 /* We may have no GNU_EXPR because No_Initialization is
667 set even though there's an Expression. */
668 else if (kind == E_Constant
669 && (Nkind (Declaration_Node (gnat_entity))
670 == N_Object_Declaration)
671 && Present (Expression (Declaration_Node (gnat_entity))))
673 = TYPE_SIZE (gnat_to_gnu_type
675 (Expression (Declaration_Node (gnat_entity)))));
678 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
683 /* If the size is zero bytes, make it one byte since some linkers have
684 trouble with zero-sized objects. If the object will have a
685 template, that will make it nonzero so don't bother. Also avoid
686 doing that for an object renaming or an object with an address
687 clause, as we would lose useful information on the view size
688 (e.g. for null array slices) and we are not allocating the object
691 && integer_zerop (gnu_size)
692 && !TREE_OVERFLOW (gnu_size))
693 || (TYPE_SIZE (gnu_type)
694 && integer_zerop (TYPE_SIZE (gnu_type))
695 && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
696 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
697 || !Is_Array_Type (Etype (gnat_entity)))
698 && !Present (Renamed_Object (gnat_entity))
699 && !Present (Address_Clause (gnat_entity)))
700 gnu_size = bitsize_unit_node;
702 /* If this is an object with no specified size and alignment, and
703 if either it is atomic or we are not optimizing alignment for
704 space and it is composite and not an exception, an Out parameter
705 or a reference to another object, and the size of its type is a
706 constant, set the alignment to the smallest one which is not
707 smaller than the size, with an appropriate cap. */
708 if (!gnu_size && align == 0
709 && (Is_Atomic (gnat_entity)
710 || (!Optimize_Alignment_Space (gnat_entity)
711 && kind != E_Exception
712 && kind != E_Out_Parameter
713 && Is_Composite_Type (Etype (gnat_entity))
714 && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
716 && No (Renamed_Object (gnat_entity))
717 && No (Address_Clause (gnat_entity))))
718 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
720 /* No point in jumping through all the hoops needed in order
721 to support BIGGEST_ALIGNMENT if we don't really have to.
722 So we cap to the smallest alignment that corresponds to
723 a known efficient memory access pattern of the target. */
724 unsigned int align_cap = Is_Atomic (gnat_entity)
726 : get_mode_alignment (ptr_mode);
728 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
729 || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
732 align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
734 /* But make sure not to under-align the object. */
735 if (align <= TYPE_ALIGN (gnu_type))
738 /* And honor the minimum valid atomic alignment, if any. */
739 #ifdef MINIMUM_ATOMIC_ALIGNMENT
740 else if (align < MINIMUM_ATOMIC_ALIGNMENT)
741 align = MINIMUM_ATOMIC_ALIGNMENT;
745 /* If the object is set to have atomic components, find the component
746 type and validate it.
748 ??? Note that we ignore Has_Volatile_Components on objects; it's
749 not at all clear what to do in that case. */
751 if (Has_Atomic_Components (gnat_entity))
753 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
754 ? TREE_TYPE (gnu_type) : gnu_type);
756 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
757 && TYPE_MULTI_ARRAY_P (gnu_inner))
758 gnu_inner = TREE_TYPE (gnu_inner);
760 check_ok_for_atomic (gnu_inner, gnat_entity, true);
763 /* Now check if the type of the object allows atomic access. Note
764 that we must test the type, even if this object has size and
765 alignment to allow such access, because we will be going
766 inside the padded record to assign to the object. We could fix
767 this by always copying via an intermediate value, but it's not
768 clear it's worth the effort. */
769 if (Is_Atomic (gnat_entity))
770 check_ok_for_atomic (gnu_type, gnat_entity, false);
772 /* If this is an aliased object with an unconstrained nominal subtype,
773 make a type that includes the template. */
774 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
775 && Is_Array_Type (Etype (gnat_entity))
776 && !type_annotate_only)
779 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
782 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
783 concat_name (gnu_entity_name,
787 #ifdef MINIMUM_ATOMIC_ALIGNMENT
788 /* If the size is a constant and no alignment is specified, force
789 the alignment to be the minimum valid atomic alignment. The
790 restriction on constant size avoids problems with variable-size
791 temporaries; if the size is variable, there's no issue with
792 atomic access. Also don't do this for a constant, since it isn't
793 necessary and can interfere with constant replacement. Finally,
794 do not do it for Out parameters since that creates an
795 size inconsistency with In parameters. */
796 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
797 && !FLOAT_TYPE_P (gnu_type)
798 && !const_flag && No (Renamed_Object (gnat_entity))
799 && !imported_p && No (Address_Clause (gnat_entity))
800 && kind != E_Out_Parameter
801 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
802 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
803 align = MINIMUM_ATOMIC_ALIGNMENT;
806 /* Make a new type with the desired size and alignment, if needed.
807 But do not take into account alignment promotions to compute the
808 size of the object. */
809 gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
810 if (gnu_size || align > 0)
811 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
812 "PAD", false, definition,
813 gnu_size ? true : false);
815 /* If this is a renaming, avoid as much as possible to create a new
816 object. However, in several cases, creating it is required.
817 This processing needs to be applied to the raw expression so
818 as to make it more likely to rename the underlying object. */
819 if (Present (Renamed_Object (gnat_entity)))
821 bool create_normal_object = false;
823 /* If the renamed object had padding, strip off the reference
824 to the inner object and reset our type. */
825 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
826 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
828 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
829 /* Strip useless conversions around the object. */
830 || (TREE_CODE (gnu_expr) == NOP_EXPR
831 && gnat_types_compatible_p
832 (TREE_TYPE (gnu_expr),
833 TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
835 gnu_expr = TREE_OPERAND (gnu_expr, 0);
836 gnu_type = TREE_TYPE (gnu_expr);
839 /* Case 1: If this is a constant renaming stemming from a function
840 call, treat it as a normal object whose initial value is what
841 is being renamed. RM 3.3 says that the result of evaluating a
842 function call is a constant object. As a consequence, it can
843 be the inner object of a constant renaming. In this case, the
844 renaming must be fully instantiated, i.e. it cannot be a mere
845 reference to (part of) an existing object. */
848 tree inner_object = gnu_expr;
849 while (handled_component_p (inner_object))
850 inner_object = TREE_OPERAND (inner_object, 0);
851 if (TREE_CODE (inner_object) == CALL_EXPR)
852 create_normal_object = true;
855 /* Otherwise, see if we can proceed with a stabilized version of
856 the renamed entity or if we need to make a new object. */
857 if (!create_normal_object)
859 tree maybe_stable_expr = NULL_TREE;
862 /* Case 2: If the renaming entity need not be materialized and
863 the renamed expression is something we can stabilize, use
864 that for the renaming. At the global level, we can only do
865 this if we know no SAVE_EXPRs need be made, because the
866 expression we return might be used in arbitrary conditional
867 branches so we must force the SAVE_EXPRs evaluation
868 immediately and this requires a function context. */
869 if (!Materialize_Entity (gnat_entity)
870 && (!global_bindings_p ()
871 || (staticp (gnu_expr)
872 && !TREE_SIDE_EFFECTS (gnu_expr))))
875 = maybe_stabilize_reference (gnu_expr, true, &stable);
879 gnu_decl = maybe_stable_expr;
880 /* ??? No DECL_EXPR is created so we need to mark
881 the expression manually lest it is shared. */
882 if (global_bindings_p ())
883 mark_visited (&gnu_decl);
884 save_gnu_tree (gnat_entity, gnu_decl, true);
889 /* The stabilization failed. Keep maybe_stable_expr
890 untouched here to let the pointer case below know
891 about that failure. */
894 /* Case 3: If this is a constant renaming and creating a
895 new object is allowed and cheap, treat it as a normal
896 object whose initial value is what is being renamed. */
898 && !Is_Composite_Type
899 (Underlying_Type (Etype (gnat_entity))))
902 /* Case 4: Make this into a constant pointer to the object we
903 are to rename and attach the object to the pointer if it is
904 something we can stabilize.
906 From the proper scope, attached objects will be referenced
907 directly instead of indirectly via the pointer to avoid
908 subtle aliasing problems with non-addressable entities.
909 They have to be stable because we must not evaluate the
910 variables in the expression every time the renaming is used.
911 The pointer is called a "renaming" pointer in this case.
913 In the rare cases where we cannot stabilize the renamed
914 object, we just make a "bare" pointer, and the renamed
915 entity is always accessed indirectly through it. */
918 gnu_type = build_reference_type (gnu_type);
919 inner_const_flag = TREE_READONLY (gnu_expr);
922 /* If the previous attempt at stabilizing failed, there
923 is no point in trying again and we reuse the result
924 without attaching it to the pointer. In this case it
925 will only be used as the initializing expression of
926 the pointer and thus needs no special treatment with
927 regard to multiple evaluations. */
928 if (maybe_stable_expr)
931 /* Otherwise, try to stabilize and attach the expression
932 to the pointer if the stabilization succeeds.
934 Note that this might introduce SAVE_EXPRs and we don't
935 check whether we're at the global level or not. This
936 is fine since we are building a pointer initializer and
937 neither the pointer nor the initializing expression can
938 be accessed before the pointer elaboration has taken
939 place in a correct program.
941 These SAVE_EXPRs will be evaluated at the right place
942 by either the evaluation of the initializer for the
943 non-global case or the elaboration code for the global
944 case, and will be attached to the elaboration procedure
945 in the latter case. */
949 = maybe_stabilize_reference (gnu_expr, true, &stable);
952 renamed_obj = maybe_stable_expr;
954 /* Attaching is actually performed downstream, as soon
955 as we have a VAR_DECL for the pointer we make. */
959 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
961 gnu_size = NULL_TREE;
967 /* Make a volatile version of this object's type if we are to make
968 the object volatile. We also interpret 13.3(19) conservatively
969 and disallow any optimizations for such a non-constant object. */
970 if ((Treat_As_Volatile (gnat_entity)
972 && (Is_Exported (gnat_entity)
973 || Is_Imported (gnat_entity)
974 || Present (Address_Clause (gnat_entity)))))
975 && !TYPE_VOLATILE (gnu_type))
976 gnu_type = build_qualified_type (gnu_type,
977 (TYPE_QUALS (gnu_type)
978 | TYPE_QUAL_VOLATILE));
980 /* If we are defining an aliased object whose nominal subtype is
981 unconstrained, the object is a record that contains both the
982 template and the object. If there is an initializer, it will
983 have already been converted to the right type, but we need to
984 create the template if there is no initializer. */
987 && TREE_CODE (gnu_type) == RECORD_TYPE
988 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
989 /* Beware that padding might have been introduced
990 via maybe_pad_type above. */
991 || (TYPE_IS_PADDING_P (gnu_type)
992 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
994 && TYPE_CONTAINS_TEMPLATE_P
995 (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
998 = TYPE_IS_PADDING_P (gnu_type)
999 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
1000 : TYPE_FIELDS (gnu_type);
1003 = gnat_build_constructor
1007 build_template (TREE_TYPE (template_field),
1008 TREE_TYPE (TREE_CHAIN (template_field)),
1013 /* Convert the expression to the type of the object except in the
1014 case where the object's type is unconstrained or the object's type
1015 is a padded record whose field is of self-referential size. In
1016 the former case, converting will generate unnecessary evaluations
1017 of the CONSTRUCTOR to compute the size and in the latter case, we
1018 want to only copy the actual data. */
1020 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1021 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1022 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1023 && TYPE_IS_PADDING_P (gnu_type)
1024 && (CONTAINS_PLACEHOLDER_P
1025 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1026 gnu_expr = convert (gnu_type, gnu_expr);
1028 /* If this is a pointer and it does not have an initializing
1029 expression, initialize it to NULL, unless the object is
1032 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
1033 && !Is_Imported (gnat_entity) && !gnu_expr)
1034 gnu_expr = integer_zero_node;
1036 /* If we are defining the object and it has an Address clause, we must
1037 either get the address expression from the saved GCC tree for the
1038 object if it has a Freeze node, or elaborate the address expression
1039 here since the front-end has guaranteed that the elaboration has no
1040 effects in this case. */
1041 if (definition && Present (Address_Clause (gnat_entity)))
1044 = present_gnu_tree (gnat_entity)
1045 ? get_gnu_tree (gnat_entity)
1046 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)));
1048 save_gnu_tree (gnat_entity, NULL_TREE, false);
1050 /* Ignore the size. It's either meaningless or was handled
1052 gnu_size = NULL_TREE;
1053 /* Convert the type of the object to a reference type that can
1054 alias everything as per 13.3(19). */
1056 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1057 gnu_address = convert (gnu_type, gnu_address);
1059 const_flag = !Is_Public (gnat_entity)
1060 || compile_time_known_address_p (Expression (Address_Clause
1063 /* If this is a deferred constant, the initializer is attached to
1065 if (kind == E_Constant && Present (Full_View (gnat_entity)))
1068 (Expression (Declaration_Node (Full_View (gnat_entity))));
1070 /* If we don't have an initializing expression for the underlying
1071 variable, the initializing expression for the pointer is the
1072 specified address. Otherwise, we have to make a COMPOUND_EXPR
1073 to assign both the address and the initial value. */
1075 gnu_expr = gnu_address;
1078 = build2 (COMPOUND_EXPR, gnu_type,
1080 (MODIFY_EXPR, NULL_TREE,
1081 build_unary_op (INDIRECT_REF, NULL_TREE,
1087 /* If it has an address clause and we are not defining it, mark it
1088 as an indirect object. Likewise for Stdcall objects that are
1090 if ((!definition && Present (Address_Clause (gnat_entity)))
1091 || (Is_Imported (gnat_entity)
1092 && Has_Stdcall_Convention (gnat_entity)))
1094 /* Convert the type of the object to a reference type that can
1095 alias everything as per 13.3(19). */
1097 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
1098 gnu_size = NULL_TREE;
1100 /* No point in taking the address of an initializing expression
1101 that isn't going to be used. */
1102 gnu_expr = NULL_TREE;
1104 /* If it has an address clause whose value is known at compile
1105 time, make the object a CONST_DECL. This will avoid a
1106 useless dereference. */
1107 if (Present (Address_Clause (gnat_entity)))
1109 Node_Id gnat_address
1110 = Expression (Address_Clause (gnat_entity));
1112 if (compile_time_known_address_p (gnat_address))
1114 gnu_expr = gnat_to_gnu (gnat_address);
1122 /* If we are at top level and this object is of variable size,
1123 make the actual type a hidden pointer to the real type and
1124 make the initializer be a memory allocation and initialization.
1125 Likewise for objects we aren't defining (presumed to be
1126 external references from other packages), but there we do
1127 not set up an initialization.
1129 If the object's size overflows, make an allocator too, so that
1130 Storage_Error gets raised. Note that we will never free
1131 such memory, so we presume it never will get allocated. */
1133 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1134 global_bindings_p () || !definition
1137 && ! allocatable_size_p (gnu_size,
1138 global_bindings_p () || !definition
1141 gnu_type = build_reference_type (gnu_type);
1142 gnu_size = NULL_TREE;
1146 /* In case this was a aliased object whose nominal subtype is
1147 unconstrained, the pointer above will be a thin pointer and
1148 build_allocator will automatically make the template.
1150 If we have a template initializer only (that we made above),
1151 pretend there is none and rely on what build_allocator creates
1152 again anyway. Otherwise (if we have a full initializer), get
1153 the data part and feed that to build_allocator.
1155 If we are elaborating a mutable object, tell build_allocator to
1156 ignore a possibly simpler size from the initializer, if any, as
1157 we must allocate the maximum possible size in this case. */
1161 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1163 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1164 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1167 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1169 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1170 && 1 == VEC_length (constructor_elt,
1171 CONSTRUCTOR_ELTS (gnu_expr)))
1175 = build_component_ref
1176 (gnu_expr, NULL_TREE,
1177 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1181 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1182 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1183 && !Is_Imported (gnat_entity))
1184 post_error ("?Storage_Error will be raised at run-time!",
1187 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1188 0, 0, gnat_entity, mutable_p);
1192 gnu_expr = NULL_TREE;
1197 /* If this object would go into the stack and has an alignment larger
1198 than the largest stack alignment the back-end can honor, resort to
1199 a variable of "aligning type". */
1200 if (!global_bindings_p () && !static_p && definition
1201 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1203 /* Create the new variable. No need for extra room before the
1204 aligned field as this is in automatic storage. */
1206 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1207 TYPE_SIZE_UNIT (gnu_type),
1208 BIGGEST_ALIGNMENT, 0);
1210 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1211 NULL_TREE, gnu_new_type, NULL_TREE, false,
1212 false, false, false, NULL, gnat_entity);
1214 /* Initialize the aligned field if we have an initializer. */
1217 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1219 (gnu_new_var, NULL_TREE,
1220 TYPE_FIELDS (gnu_new_type), false),
1224 /* And setup this entity as a reference to the aligned field. */
1225 gnu_type = build_reference_type (gnu_type);
1228 (ADDR_EXPR, gnu_type,
1229 build_component_ref (gnu_new_var, NULL_TREE,
1230 TYPE_FIELDS (gnu_new_type), false));
1232 gnu_size = NULL_TREE;
1238 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1239 | TYPE_QUAL_CONST));
1241 /* Convert the expression to the type of the object except in the
1242 case where the object's type is unconstrained or the object's type
1243 is a padded record whose field is of self-referential size. In
1244 the former case, converting will generate unnecessary evaluations
1245 of the CONSTRUCTOR to compute the size and in the latter case, we
1246 want to only copy the actual data. */
1248 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1249 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1250 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1251 && TYPE_IS_PADDING_P (gnu_type)
1252 && (CONTAINS_PLACEHOLDER_P
1253 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1254 gnu_expr = convert (gnu_type, gnu_expr);
1256 /* If this name is external or there was a name specified, use it,
1257 unless this is a VMS exception object since this would conflict
1258 with the symbol we need to export in addition. Don't use the
1259 Interface_Name if there is an address clause (see CD30005). */
1260 if (!Is_VMS_Exception (gnat_entity)
1261 && ((Present (Interface_Name (gnat_entity))
1262 && No (Address_Clause (gnat_entity)))
1263 || (Is_Public (gnat_entity)
1264 && (!Is_Imported (gnat_entity)
1265 || Is_Exported (gnat_entity)))))
1266 gnu_ext_name = create_concat_name (gnat_entity, NULL);
1268 /* If this is constant initialized to a static constant and the
1269 object has an aggregate type, force it to be statically
1270 allocated. This will avoid an initialization copy. */
1271 if (!static_p && const_flag
1272 && gnu_expr && TREE_CONSTANT (gnu_expr)
1273 && AGGREGATE_TYPE_P (gnu_type)
1274 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1275 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1276 && TYPE_IS_PADDING_P (gnu_type)
1277 && !host_integerp (TYPE_SIZE_UNIT
1278 (TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
1281 gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1282 gnu_expr, const_flag,
1283 Is_Public (gnat_entity),
1284 imported_p || !definition,
1285 static_p, attr_list, gnat_entity);
1286 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1287 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1288 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1290 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1291 if (global_bindings_p ())
1293 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1294 record_global_renaming_pointer (gnu_decl);
1298 if (definition && DECL_SIZE_UNIT (gnu_decl)
1299 && get_block_jmpbuf_decl ()
1300 && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST
1301 || (flag_stack_check == GENERIC_STACK_CHECK
1302 && compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1303 STACK_CHECK_MAX_VAR_SIZE) > 0)))
1304 add_stmt_with_node (build_call_1_expr
1305 (update_setjmp_buf_decl,
1306 build_unary_op (ADDR_EXPR, NULL_TREE,
1307 get_block_jmpbuf_decl ())),
1310 /* If we are defining an Out parameter and we're not optimizing,
1311 create a fake PARM_DECL for debugging purposes and make it
1312 point to the VAR_DECL. Suppress debug info for the latter
1313 but make sure it will still live on the stack so it can be
1314 accessed from within the debugger through the PARM_DECL. */
1315 if (kind == E_Out_Parameter && definition && !optimize)
1317 tree param = create_param_decl (gnu_entity_name, gnu_type, false);
1318 gnat_pushdecl (param, gnat_entity);
1319 SET_DECL_VALUE_EXPR (param, gnu_decl);
1320 DECL_HAS_VALUE_EXPR_P (param) = 1;
1322 debug_info_p = false;
1324 DECL_IGNORED_P (param) = 1;
1325 TREE_ADDRESSABLE (gnu_decl) = 1;
1328 /* If this is a public constant or we're not optimizing and we're not
1329 making a VAR_DECL for it, make one just for export or debugger use.
1330 Likewise if the address is taken or if either the object or type is
1331 aliased. Make an external declaration for a reference, unless this
1332 is a Standard entity since there no real symbol at the object level
1334 if (TREE_CODE (gnu_decl) == CONST_DECL
1335 && (definition || Sloc (gnat_entity) > Standard_Location)
1336 && ((Is_Public (gnat_entity)
1337 && !Present (Address_Clause (gnat_entity)))
1339 || Address_Taken (gnat_entity)
1340 || Is_Aliased (gnat_entity)
1341 || Is_Aliased (Etype (gnat_entity))))
1344 = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
1345 gnu_expr, true, Is_Public (gnat_entity),
1346 !definition, static_p, NULL,
1349 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1351 /* As debugging information will be generated for the variable,
1352 do not generate information for the constant. */
1353 DECL_IGNORED_P (gnu_decl) = 1;
1356 /* If this is declared in a block that contains a block with an
1357 exception handler, we must force this variable in memory to
1358 suppress an invalid optimization. */
1359 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1360 && Exception_Mechanism != Back_End_Exceptions)
1361 TREE_ADDRESSABLE (gnu_decl) = 1;
1363 gnu_type = TREE_TYPE (gnu_decl);
1365 /* Back-annotate Alignment and Esize of the object if not already
1366 known, except for when the object is actually a pointer to the
1367 real object, since alignment and size of a pointer don't have
1368 anything to do with those of the designated object. Note that
1369 we pick the values of the type, not those of the object, to
1370 shield ourselves from low-level platform-dependent adjustments
1371 like alignment promotion. This is both consistent with all the
1372 treatment above, where alignment and size are set on the type of
1373 the object and not on the object directly, and makes it possible
1374 to support confirming representation clauses in all cases. */
1376 if (!used_by_ref && Unknown_Alignment (gnat_entity))
1377 Set_Alignment (gnat_entity,
1378 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
1380 if (!used_by_ref && Unknown_Esize (gnat_entity))
1382 if (TREE_CODE (gnu_type) == RECORD_TYPE
1383 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1385 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
1387 Set_Esize (gnat_entity, annotate_value (gnu_object_size));
1393 /* Return a TYPE_DECL for "void" that we previously made. */
1394 gnu_decl = TYPE_NAME (void_type_node);
1397 case E_Enumeration_Type:
1398 /* A special case, for the types Character and Wide_Character in
1399 Standard, we do not list all the literals. So if the literals
1400 are not specified, make this an unsigned type. */
1401 if (No (First_Literal (gnat_entity)))
1403 gnu_type = make_unsigned_type (esize);
1404 TYPE_NAME (gnu_type) = gnu_entity_name;
1406 /* Set TYPE_STRING_FLAG for Ada Character and Wide_Character types.
1407 This is needed by the DWARF-2 back-end to distinguish between
1408 unsigned integer types and character types. */
1409 TYPE_STRING_FLAG (gnu_type) = 1;
1413 /* Normal case of non-character type, or non-Standard character type */
1415 /* Here we have a list of enumeral constants in First_Literal.
1416 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1417 the list to be places into TYPE_FIELDS. Each node in the list
1418 is a TREE_LIST node whose TREE_VALUE is the literal name
1419 and whose TREE_PURPOSE is the value of the literal.
1421 Esize contains the number of bits needed to represent the enumeral
1422 type, Type_Low_Bound also points to the first literal and
1423 Type_High_Bound points to the last literal. */
1425 Entity_Id gnat_literal;
1426 tree gnu_literal_list = NULL_TREE;
1428 if (Is_Unsigned_Type (gnat_entity))
1429 gnu_type = make_unsigned_type (esize);
1431 gnu_type = make_signed_type (esize);
1433 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1435 for (gnat_literal = First_Literal (gnat_entity);
1436 Present (gnat_literal);
1437 gnat_literal = Next_Literal (gnat_literal))
1439 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1442 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1443 gnu_type, gnu_value, true, false, false,
1444 false, NULL, gnat_literal);
1446 save_gnu_tree (gnat_literal, gnu_literal, false);
1447 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1448 gnu_value, gnu_literal_list);
1451 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1453 /* Note that the bounds are updated at the end of this function
1454 because to avoid an infinite recursion when we get the bounds of
1455 this type, since those bounds are objects of this type. */
1459 case E_Signed_Integer_Type:
1460 case E_Ordinary_Fixed_Point_Type:
1461 case E_Decimal_Fixed_Point_Type:
1462 /* For integer types, just make a signed type the appropriate number
1464 gnu_type = make_signed_type (esize);
1467 case E_Modular_Integer_Type:
1469 /* For modular types, make the unsigned type of the proper number
1470 of bits and then set up the modulus, if required. */
1471 tree gnu_modulus, gnu_high = NULL_TREE;
1472 enum machine_mode mode;
1474 /* Packed array types are supposed to be subtypes only. */
1475 gcc_assert (!Is_Packed_Array_Type (gnat_entity));
1477 /* Find the smallest mode at least ESIZE bits wide and make a class
1479 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1480 GET_MODE_BITSIZE (mode) < esize;
1481 mode = GET_MODE_WIDER_MODE (mode))
1484 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1486 /* Get the modulus in this type. If it overflows, assume it is because
1487 it is equal to 2**Esize. Note that there is no overflow checking
1488 done on unsigned type, so we detect the overflow by looking for
1489 a modulus of zero, which is otherwise invalid. */
1490 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1492 if (!integer_zerop (gnu_modulus))
1494 TYPE_MODULAR_P (gnu_type) = 1;
1495 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1496 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1497 convert (gnu_type, integer_one_node));
1500 /* If we have to set TYPE_PRECISION different from its natural value,
1501 make a subtype to do do. Likewise if there is a modulus and
1502 it is not one greater than TYPE_MAX_VALUE. */
1503 if (TYPE_PRECISION (gnu_type) != esize
1504 || (TYPE_MODULAR_P (gnu_type)
1505 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1507 tree gnu_subtype = make_node (INTEGER_TYPE);
1508 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1509 TREE_TYPE (gnu_subtype) = gnu_type;
1510 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1511 TYPE_MAX_VALUE (gnu_subtype)
1512 = TYPE_MODULAR_P (gnu_type)
1513 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1514 TYPE_PRECISION (gnu_subtype) = esize;
1515 TYPE_UNSIGNED (gnu_subtype) = 1;
1516 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1517 layout_type (gnu_subtype);
1518 gnu_type = gnu_subtype;
1523 case E_Signed_Integer_Subtype:
1524 case E_Enumeration_Subtype:
1525 case E_Modular_Integer_Subtype:
1526 case E_Ordinary_Fixed_Point_Subtype:
1527 case E_Decimal_Fixed_Point_Subtype:
1529 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1530 that we do not want to call build_range_type since we would
1531 like each subtype node to be distinct. This will be important
1532 when memory aliasing is implemented.
1534 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1535 parent type; this fact is used by the arithmetic conversion
1538 We elaborate the Ancestor_Subtype if it is not in the current
1539 unit and one of our bounds is non-static. We do this to ensure
1540 consistent naming in the case where several subtypes share the same
1541 bounds by always elaborating the first such subtype first, thus
1545 && Present (Ancestor_Subtype (gnat_entity))
1546 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1547 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1548 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1549 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
1551 gnu_type = make_node (INTEGER_TYPE);
1552 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1554 /* Set the precision to the Esize except for bit-packed arrays and
1555 subtypes of Standard.Boolean. */
1556 if (Is_Packed_Array_Type (gnat_entity)
1557 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1558 esize = UI_To_Int (RM_Size (gnat_entity));
1559 else if (TREE_CODE (TREE_TYPE (gnu_type)) == BOOLEAN_TYPE)
1562 TYPE_PRECISION (gnu_type) = esize;
1564 TYPE_MIN_VALUE (gnu_type)
1565 = convert (TREE_TYPE (gnu_type),
1566 elaborate_expression (Type_Low_Bound (gnat_entity),
1568 get_identifier ("L"), definition, 1,
1569 Needs_Debug_Info (gnat_entity)));
1571 TYPE_MAX_VALUE (gnu_type)
1572 = convert (TREE_TYPE (gnu_type),
1573 elaborate_expression (Type_High_Bound (gnat_entity),
1575 get_identifier ("U"), definition, 1,
1576 Needs_Debug_Info (gnat_entity)));
1578 /* One of the above calls might have caused us to be elaborated,
1579 so don't blow up if so. */
1580 if (present_gnu_tree (gnat_entity))
1582 maybe_present = true;
1586 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1587 = Has_Biased_Representation (gnat_entity);
1589 /* This should be an unsigned type if the lower bound is constant
1590 and non-negative or if the base type is unsigned; a signed type
1592 TYPE_UNSIGNED (gnu_type)
1593 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1594 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1595 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1596 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1597 || Is_Unsigned_Type (gnat_entity));
1599 layout_type (gnu_type);
1601 /* Inherit our alias set from what we're a subtype of. Subtypes
1602 are not different types and a pointer can designate any instance
1603 within a subtype hierarchy. */
1604 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1606 /* If the type we are dealing with represents a bit-packed array,
1607 we need to have the bits left justified on big-endian targets
1608 and right justified on little-endian targets. We also need to
1609 ensure that when the value is read (e.g. for comparison of two
1610 such values), we only get the good bits, since the unused bits
1611 are uninitialized. Both goals are accomplished by wrapping up
1612 the modular type in an enclosing record type. */
1613 if (Is_Packed_Array_Type (gnat_entity)
1614 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
1616 tree gnu_field_type, gnu_field;
1618 /* Set the RM size before wrapping up the type. */
1619 TYPE_RM_SIZE (gnu_type)
1620 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1621 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1622 gnu_field_type = gnu_type;
1624 gnu_type = make_node (RECORD_TYPE);
1625 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1627 /* Propagate the alignment of the modular type to the record.
1628 This means that bit-packed arrays have "ceil" alignment for
1629 their size, which may seem counter-intuitive but makes it
1630 possible to easily overlay them on modular types. */
1631 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1632 TYPE_PACKED (gnu_type) = 1;
1634 /* Create a stripped-down declaration of the original type, mainly
1636 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1637 debug_info_p, gnat_entity);
1639 /* Don't notify the field as "addressable", since we won't be taking
1640 it's address and it would prevent create_field_decl from making a
1642 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1643 gnu_field_type, gnu_type, 1, 0, 0, 0);
1645 finish_record_type (gnu_type, gnu_field, 0, false);
1646 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1648 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1651 /* If the type we are dealing with has got a smaller alignment than the
1652 natural one, we need to wrap it up in a record type and under-align
1653 the latter. We reuse the padding machinery for this purpose. */
1654 else if (Known_Alignment (gnat_entity)
1655 && UI_Is_In_Int_Range (Alignment (gnat_entity))
1656 && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
1657 && align < TYPE_ALIGN (gnu_type))
1659 tree gnu_field_type, gnu_field;
1661 /* Set the RM size before wrapping up the type. */
1662 TYPE_RM_SIZE (gnu_type)
1663 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1664 gnu_field_type = gnu_type;
1666 gnu_type = make_node (RECORD_TYPE);
1667 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
1669 TYPE_ALIGN (gnu_type) = align;
1670 TYPE_PACKED (gnu_type) = 1;
1672 /* Create a stripped-down declaration of the original type, mainly
1674 create_type_decl (gnu_entity_name, gnu_field_type, NULL, true,
1675 debug_info_p, gnat_entity);
1677 /* Don't notify the field as "addressable", since we won't be taking
1678 it's address and it would prevent create_field_decl from making a
1680 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1681 gnu_field_type, gnu_type, 1, 0, 0, 0);
1683 finish_record_type (gnu_type, gnu_field, 0, false);
1684 TYPE_IS_PADDING_P (gnu_type) = 1;
1686 relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
1689 /* Otherwise reset the alignment lest we computed it above. */
1695 case E_Floating_Point_Type:
1696 /* If this is a VAX floating-point type, use an integer of the proper
1697 size. All the operations will be handled with ASM statements. */
1698 if (Vax_Float (gnat_entity))
1700 gnu_type = make_signed_type (esize);
1701 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1702 SET_TYPE_DIGITS_VALUE (gnu_type,
1703 UI_To_gnu (Digits_Value (gnat_entity),
1708 /* The type of the Low and High bounds can be our type if this is
1709 a type from Standard, so set them at the end of the function. */
1710 gnu_type = make_node (REAL_TYPE);
1711 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1712 layout_type (gnu_type);
1715 case E_Floating_Point_Subtype:
1716 if (Vax_Float (gnat_entity))
1718 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1724 && Present (Ancestor_Subtype (gnat_entity))
1725 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1726 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1727 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1728 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1731 gnu_type = make_node (REAL_TYPE);
1732 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1733 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1735 TYPE_MIN_VALUE (gnu_type)
1736 = convert (TREE_TYPE (gnu_type),
1737 elaborate_expression (Type_Low_Bound (gnat_entity),
1738 gnat_entity, get_identifier ("L"),
1740 Needs_Debug_Info (gnat_entity)));
1742 TYPE_MAX_VALUE (gnu_type)
1743 = convert (TREE_TYPE (gnu_type),
1744 elaborate_expression (Type_High_Bound (gnat_entity),
1745 gnat_entity, get_identifier ("U"),
1747 Needs_Debug_Info (gnat_entity)));
1749 /* One of the above calls might have caused us to be elaborated,
1750 so don't blow up if so. */
1751 if (present_gnu_tree (gnat_entity))
1753 maybe_present = true;
1757 layout_type (gnu_type);
1759 /* Inherit our alias set from what we're a subtype of, as for
1760 integer subtypes. */
1761 relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
1765 /* Array and String Types and Subtypes
1767 Unconstrained array types are represented by E_Array_Type and
1768 constrained array types are represented by E_Array_Subtype. There
1769 are no actual objects of an unconstrained array type; all we have
1770 are pointers to that type.
1772 The following fields are defined on array types and subtypes:
1774 Component_Type Component type of the array.
1775 Number_Dimensions Number of dimensions (an int).
1776 First_Index Type of first index. */
1781 tree gnu_template_fields = NULL_TREE;
1782 tree gnu_template_type = make_node (RECORD_TYPE);
1783 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1784 tree gnu_fat_type = make_node (RECORD_TYPE);
1785 int ndim = Number_Dimensions (gnat_entity);
1787 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1789 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1791 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1792 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1793 tree gnu_comp_size = 0;
1794 tree gnu_max_size = size_one_node;
1795 tree gnu_max_size_unit;
1796 Entity_Id gnat_ind_subtype;
1797 Entity_Id gnat_ind_base_subtype;
1798 tree gnu_template_reference;
1801 TYPE_NAME (gnu_template_type)
1802 = create_concat_name (gnat_entity, "XUB");
1804 /* Make a node for the array. If we are not defining the array
1805 suppress expanding incomplete types. */
1806 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1809 defer_incomplete_level++, 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"),
1817 gnu_fat_type, 0, 0, 0, 0)),
1818 create_field_decl (get_identifier ("P_BOUNDS"),
1820 gnu_fat_type, 0, 0, 0, 0));
1822 /* Make sure we can put this into a register. */
1823 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1825 /* Do not finalize this record type since the types of its fields
1826 are still incomplete at this point. */
1827 finish_record_type (gnu_fat_type, tem, 0, true);
1828 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1830 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1831 is the fat pointer. This will be used to access the individual
1832 fields once we build them. */
1833 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1834 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1835 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1836 gnu_template_reference
1837 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1838 TREE_READONLY (gnu_template_reference) = 1;
1840 /* Now create the GCC type for each index and add the fields for
1841 that index to the template. */
1842 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1843 gnat_ind_base_subtype
1844 = First_Index (Implementation_Base_Type (gnat_entity));
1845 index < ndim && index >= 0;
1847 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1848 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1850 char field_name[10];
1851 tree gnu_ind_subtype
1852 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1853 tree gnu_base_subtype
1854 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1856 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1858 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1859 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1861 /* Make the FIELD_DECLs for the minimum and maximum of this
1862 type and then make extractions of that field from the
1864 sprintf (field_name, "LB%d", index);
1865 gnu_min_field = create_field_decl (get_identifier (field_name),
1867 gnu_template_type, 0, 0, 0, 0);
1868 field_name[0] = 'U';
1869 gnu_max_field = create_field_decl (get_identifier (field_name),
1871 gnu_template_type, 0, 0, 0, 0);
1873 Sloc_to_locus (Sloc (gnat_entity),
1874 &DECL_SOURCE_LOCATION (gnu_min_field));
1875 Sloc_to_locus (Sloc (gnat_entity),
1876 &DECL_SOURCE_LOCATION (gnu_max_field));
1877 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1879 /* We can't use build_component_ref here since the template
1880 type isn't complete yet. */
1881 gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
1882 gnu_template_reference, gnu_min_field,
1884 gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
1885 gnu_template_reference, gnu_max_field,
1887 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1889 /* Make a range type with the new ranges, but using
1890 the Ada subtype. Then we convert to sizetype. */
1891 gnu_index_types[index]
1892 = create_index_type (convert (sizetype, gnu_min),
1893 convert (sizetype, gnu_max),
1894 build_range_type (gnu_ind_subtype,
1897 /* Update the maximum size of the array, in elements. */
1899 = size_binop (MULT_EXPR, gnu_max_size,
1900 size_binop (PLUS_EXPR, size_one_node,
1901 size_binop (MINUS_EXPR, gnu_base_max,
1904 TYPE_NAME (gnu_index_types[index])
1905 = create_concat_name (gnat_entity, field_name);
1908 for (index = 0; index < ndim; index++)
1910 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1912 /* Install all the fields into the template. */
1913 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1914 TYPE_READONLY (gnu_template_type) = 1;
1916 /* Now make the array of arrays and update the pointer to the array
1917 in the fat pointer. Note that it is the first field. */
1918 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1920 /* Try to get a smaller form of the component if needed. */
1921 if ((Is_Packed (gnat_entity)
1922 || Has_Component_Size_Clause (gnat_entity))
1923 && !Is_Bit_Packed_Array (gnat_entity)
1924 && !Has_Aliased_Components (gnat_entity)
1925 && !Strict_Alignment (Component_Type (gnat_entity))
1926 && TREE_CODE (tem) == RECORD_TYPE
1927 && !TYPE_IS_FAT_POINTER_P (tem)
1928 && host_integerp (TYPE_SIZE (tem), 1))
1929 tem = make_packable_type (tem, false);
1931 if (Has_Atomic_Components (gnat_entity))
1932 check_ok_for_atomic (tem, gnat_entity, true);
1934 /* Get and validate any specified Component_Size, but if Packed,
1935 ignore it since the front end will have taken care of it. */
1937 = validate_size (Component_Size (gnat_entity), tem,
1939 (Is_Bit_Packed_Array (gnat_entity)
1940 ? TYPE_DECL : VAR_DECL),
1941 true, Has_Component_Size_Clause (gnat_entity));
1943 /* If the component type is a RECORD_TYPE that has a self-referential
1944 size, use the maximum size. */
1945 if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
1946 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1947 gnu_comp_size = max_size (TYPE_SIZE (tem), true);
1949 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
1952 tem = make_type_from_size (tem, gnu_comp_size, false);
1954 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1955 "C_PAD", false, definition, true);
1956 /* If a padding record was made, declare it now since it will
1957 never be declared otherwise. This is necessary to ensure
1958 that its subtrees are properly marked. */
1959 if (tem != orig_tem)
1960 create_type_decl (TYPE_NAME (tem), tem, NULL, true,
1961 debug_info_p, gnat_entity);
1964 if (Has_Volatile_Components (gnat_entity))
1965 tem = build_qualified_type (tem,
1966 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1968 /* If Component_Size is not already specified, annotate it with the
1969 size of the component. */
1970 if (Unknown_Component_Size (gnat_entity))
1971 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1973 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1974 size_binop (MULT_EXPR, gnu_max_size,
1975 TYPE_SIZE_UNIT (tem)));
1976 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1977 size_binop (MULT_EXPR,
1978 convert (bitsizetype,
1982 for (index = ndim - 1; index >= 0; index--)
1984 tem = build_array_type (tem, gnu_index_types[index]);
1985 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1986 if (array_type_has_nonaliased_component (gnat_entity, tem))
1987 TYPE_NONALIASED_COMPONENT (tem) = 1;
1990 /* If an alignment is specified, use it if valid. But ignore it for
1991 types that represent the unpacked base type for packed arrays. If
1992 the alignment was requested with an explicit user alignment clause,
1994 if (No (Packed_Array_Type (gnat_entity))
1995 && Known_Alignment (gnat_entity))
1997 gcc_assert (Present (Alignment (gnat_entity)));
1999 = validate_alignment (Alignment (gnat_entity), gnat_entity,
2001 if (Present (Alignment_Clause (gnat_entity)))
2002 TYPE_USER_ALIGN (tem) = 1;
2005 TYPE_CONVENTION_FORTRAN_P (tem)
2006 = (Convention (gnat_entity) == Convention_Fortran);
2007 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
2009 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
2010 corresponding fat pointer. */
2011 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
2012 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
2013 SET_TYPE_MODE (gnu_type, BLKmode);
2014 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
2015 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
2017 /* If the maximum size doesn't overflow, use it. */
2018 if (TREE_CODE (gnu_max_size) == INTEGER_CST
2019 && !TREE_OVERFLOW (gnu_max_size))
2021 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
2022 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2023 && !TREE_OVERFLOW (gnu_max_size_unit))
2024 TYPE_SIZE_UNIT (tem)
2025 = size_binop (MIN_EXPR, gnu_max_size_unit,
2026 TYPE_SIZE_UNIT (tem));
2028 create_type_decl (create_concat_name (gnat_entity, "XUA"),
2029 tem, NULL, !Comes_From_Source (gnat_entity),
2030 debug_info_p, gnat_entity);
2032 /* Give the fat pointer type a name. */
2033 create_type_decl (create_concat_name (gnat_entity, "XUP"),
2034 gnu_fat_type, NULL, true,
2035 debug_info_p, gnat_entity);
2037 /* Create the type to be used as what a thin pointer designates: an
2038 record type for the object and its template with the field offsets
2039 shifted to have the template at a negative offset. */
2040 tem = build_unc_object_type (gnu_template_type, tem,
2041 create_concat_name (gnat_entity, "XUT"));
2042 shift_unc_components_for_thin_pointers (tem);
2044 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
2045 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
2047 /* Give the thin pointer type a name. */
2048 create_type_decl (create_concat_name (gnat_entity, "XUX"),
2049 build_pointer_type (tem), NULL, true,
2050 debug_info_p, gnat_entity);
2054 case E_String_Subtype:
2055 case E_Array_Subtype:
2057 /* This is the actual data type for array variables. Multidimensional
2058 arrays are implemented in the gnu tree as arrays of arrays. Note
2059 that for the moment arrays which have sparse enumeration subtypes as
2060 index components create sparse arrays, which is obviously space
2061 inefficient but so much easier to code for now.
2063 Also note that the subtype never refers to the unconstrained
2064 array type, which is somewhat at variance with Ada semantics.
2066 First check to see if this is simply a renaming of the array
2067 type. If so, the result is the array type. */
2069 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
2070 if (!Is_Constrained (gnat_entity))
2075 int array_dim = Number_Dimensions (gnat_entity);
2077 = ((Convention (gnat_entity) == Convention_Fortran)
2078 ? array_dim - 1 : 0);
2080 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
2081 Entity_Id gnat_ind_subtype;
2082 Entity_Id gnat_ind_base_subtype;
2083 tree gnu_base_type = gnu_type;
2084 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
2085 tree gnu_comp_size = NULL_TREE;
2086 tree gnu_max_size = size_one_node;
2087 tree gnu_max_size_unit;
2088 bool need_index_type_struct = false;
2089 bool max_overflow = false;
2091 /* First create the gnu types for each index. Create types for
2092 debugging information to point to the index types if the
2093 are not integer types, have variable bounds, or are
2094 wider than sizetype. */
2096 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
2097 gnat_ind_base_subtype
2098 = First_Index (Implementation_Base_Type (gnat_entity));
2099 index < array_dim && index >= 0;
2101 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
2102 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
2104 tree gnu_index_subtype
2105 = get_unpadded_type (Etype (gnat_ind_subtype));
2107 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
2109 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
2110 tree gnu_base_subtype
2111 = get_unpadded_type (Etype (gnat_ind_base_subtype));
2113 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
2115 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
2116 tree gnu_base_type = get_base_type (gnu_base_subtype);
2117 tree gnu_base_base_min
2118 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
2119 tree gnu_base_base_max
2120 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
2124 /* If the minimum and maximum values both overflow in
2125 SIZETYPE, but the difference in the original type
2126 does not overflow in SIZETYPE, ignore the overflow
2128 if ((TYPE_PRECISION (gnu_index_subtype)
2129 > TYPE_PRECISION (sizetype)
2130 || TYPE_UNSIGNED (gnu_index_subtype)
2131 != TYPE_UNSIGNED (sizetype))
2132 && TREE_CODE (gnu_min) == INTEGER_CST
2133 && TREE_CODE (gnu_max) == INTEGER_CST
2134 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
2136 (fold_build2 (MINUS_EXPR, gnu_index_subtype,
2137 TYPE_MAX_VALUE (gnu_index_subtype),
2138 TYPE_MIN_VALUE (gnu_index_subtype)))))
2140 TREE_OVERFLOW (gnu_min) = 0;
2141 TREE_OVERFLOW (gnu_max) = 0;
2144 /* Similarly, if the range is null, use bounds of 1..0 for
2145 the sizetype bounds. */
2146 else if ((TYPE_PRECISION (gnu_index_subtype)
2147 > TYPE_PRECISION (sizetype)
2148 || TYPE_UNSIGNED (gnu_index_subtype)
2149 != TYPE_UNSIGNED (sizetype))
2150 && TREE_CODE (gnu_min) == INTEGER_CST
2151 && TREE_CODE (gnu_max) == INTEGER_CST
2152 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
2153 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
2154 TYPE_MIN_VALUE (gnu_index_subtype)))
2155 gnu_min = size_one_node, gnu_max = size_zero_node;
2157 /* Now compute the size of this bound. We need to provide
2158 GCC with an upper bound to use but have to deal with the
2159 "superflat" case. There are three ways to do this. If we
2160 can prove that the array can never be superflat, we can
2161 just use the high bound of the index subtype. If we can
2162 prove that the low bound minus one can't overflow, we
2163 can do this as MAX (hb, lb - 1). Otherwise, we have to use
2164 the expression hb >= lb ? hb : lb - 1. */
2165 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
2167 /* See if the base array type is already flat. If it is, we
2168 are probably compiling an ACVC test, but it will cause the
2169 code below to malfunction if we don't handle it specially. */
2170 if (TREE_CODE (gnu_base_min) == INTEGER_CST
2171 && TREE_CODE (gnu_base_max) == INTEGER_CST
2172 && !TREE_OVERFLOW (gnu_base_min)
2173 && !TREE_OVERFLOW (gnu_base_max)
2174 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
2175 gnu_high = size_zero_node, gnu_min = size_one_node;
2177 /* If gnu_high is now an integer which overflowed, the array
2178 cannot be superflat. */
2179 else if (TREE_CODE (gnu_high) == INTEGER_CST
2180 && TREE_OVERFLOW (gnu_high))
2182 else if (TYPE_UNSIGNED (gnu_base_subtype)
2183 || TREE_CODE (gnu_high) == INTEGER_CST)
2184 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
2188 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
2192 gnu_index_type[index]
2193 = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
2196 /* Also compute the maximum size of the array. 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
2199 the 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. */
2203 if ((TREE_CODE (gnu_min) == INTEGER_CST
2204 && !TREE_OVERFLOW (gnu_min)
2205 && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
2206 || !CONTAINS_PLACEHOLDER_P (gnu_min)
2207 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2208 && !TREE_OVERFLOW (gnu_base_min)))
2209 gnu_base_min = gnu_min;
2211 if ((TREE_CODE (gnu_max) == INTEGER_CST
2212 && !TREE_OVERFLOW (gnu_max)
2213 && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
2214 || !CONTAINS_PLACEHOLDER_P (gnu_max)
2215 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2216 && !TREE_OVERFLOW (gnu_base_max)))
2217 gnu_base_max = gnu_max;
2219 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2220 && TREE_OVERFLOW (gnu_base_min))
2221 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2222 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2223 && TREE_OVERFLOW (gnu_base_max))
2224 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2225 max_overflow = true;
2227 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
2228 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
2231 = size_binop (MAX_EXPR,
2232 size_binop (PLUS_EXPR, size_one_node,
2233 size_binop (MINUS_EXPR, gnu_base_max,
2237 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2238 && TREE_OVERFLOW (gnu_this_max))
2239 max_overflow = true;
2242 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2244 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
2245 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
2247 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
2248 || (TREE_TYPE (gnu_index_subtype)
2249 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
2251 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
2252 || (TYPE_PRECISION (gnu_index_subtype)
2253 > TYPE_PRECISION (sizetype)))
2254 need_index_type_struct = true;
2257 /* Then flatten: create the array of arrays. For an array type
2258 used to implement a packed array, get the component type from
2259 the original array type since the representation clauses that
2260 can affect it are on the latter. */
2261 if (Is_Packed_Array_Type (gnat_entity)
2262 && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
2264 gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
2265 for (index = array_dim - 1; index >= 0; index--)
2266 gnu_type = TREE_TYPE (gnu_type);
2268 /* One of the above calls might have caused us to be elaborated,
2269 so don't blow up if so. */
2270 if (present_gnu_tree (gnat_entity))
2272 maybe_present = true;
2278 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
2280 /* One of the above calls might have caused us to be elaborated,
2281 so don't blow up if so. */
2282 if (present_gnu_tree (gnat_entity))
2284 maybe_present = true;
2288 /* Try to get a smaller form of the component if needed. */
2289 if ((Is_Packed (gnat_entity)
2290 || Has_Component_Size_Clause (gnat_entity))
2291 && !Is_Bit_Packed_Array (gnat_entity)
2292 && !Has_Aliased_Components (gnat_entity)
2293 && !Strict_Alignment (Component_Type (gnat_entity))
2294 && TREE_CODE (gnu_type) == RECORD_TYPE
2295 && !TYPE_IS_FAT_POINTER_P (gnu_type)
2296 && host_integerp (TYPE_SIZE (gnu_type), 1))
2297 gnu_type = make_packable_type (gnu_type, false);
2299 /* Get and validate any specified Component_Size, but if Packed,
2300 ignore it since the front end will have taken care of it. */
2302 = validate_size (Component_Size (gnat_entity), gnu_type,
2304 (Is_Bit_Packed_Array (gnat_entity)
2305 ? TYPE_DECL : VAR_DECL), true,
2306 Has_Component_Size_Clause (gnat_entity));
2308 /* If the component type is a RECORD_TYPE that has a
2309 self-referential size, use the maximum size. */
2311 && TREE_CODE (gnu_type) == RECORD_TYPE
2312 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2313 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
2315 if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
2319 = make_type_from_size (gnu_type, gnu_comp_size, false);
2320 orig_gnu_type = gnu_type;
2321 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
2322 gnat_entity, "C_PAD", false,
2324 /* If a padding record was made, declare it now since it
2325 will never be declared otherwise. This is necessary
2326 to ensure that its subtrees are properly marked. */
2327 if (gnu_type != orig_gnu_type)
2328 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL,
2329 true, debug_info_p, gnat_entity);
2332 if (Has_Volatile_Components (Base_Type (gnat_entity)))
2333 gnu_type = build_qualified_type (gnu_type,
2334 (TYPE_QUALS (gnu_type)
2335 | TYPE_QUAL_VOLATILE));
2338 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2339 TYPE_SIZE_UNIT (gnu_type));
2340 gnu_max_size = size_binop (MULT_EXPR,
2341 convert (bitsizetype, gnu_max_size),
2342 TYPE_SIZE (gnu_type));
2344 for (index = array_dim - 1; index >= 0; index --)
2346 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
2347 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2348 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2349 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2352 /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
2353 if (need_index_type_struct)
2354 TYPE_STUB_DECL (gnu_type)
2355 = create_type_stub_decl (gnu_entity_name, gnu_type);
2357 /* If we are at file level and this is a multi-dimensional array, we
2358 need to make a variable corresponding to the stride of the
2359 inner dimensions. */
2360 if (global_bindings_p () && array_dim > 1)
2362 tree gnu_str_name = get_identifier ("ST");
2365 for (gnu_arr_type = TREE_TYPE (gnu_type);
2366 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2367 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2368 gnu_str_name = concat_name (gnu_str_name, "ST"))
2370 tree eltype = TREE_TYPE (gnu_arr_type);
2372 TYPE_SIZE (gnu_arr_type)
2373 = elaborate_expression_1 (gnat_entity, gnat_entity,
2374 TYPE_SIZE (gnu_arr_type),
2375 gnu_str_name, definition, 0);
2377 /* ??? For now, store the size as a multiple of the
2378 alignment of the element type in bytes so that we
2379 can see the alignment from the tree. */
2380 TYPE_SIZE_UNIT (gnu_arr_type)
2382 (MULT_EXPR, sizetype,
2383 elaborate_expression_1
2384 (gnat_entity, gnat_entity,
2385 build_binary_op (EXACT_DIV_EXPR, sizetype,
2386 TYPE_SIZE_UNIT (gnu_arr_type),
2387 size_int (TYPE_ALIGN (eltype)
2389 concat_name (gnu_str_name, "A_U"), definition, 0),
2390 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2392 /* ??? create_type_decl is not invoked on the inner types so
2393 the MULT_EXPR node built above will never be marked. */
2394 mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type));
2398 /* If we need to write out a record type giving the names of
2399 the bounds, do it now. Make sure to reference the index
2400 types themselves, not just their names, as the debugger
2401 may fall back on them in some cases. */
2402 if (need_index_type_struct && debug_info_p)
2404 tree gnu_bound_rec = make_node (RECORD_TYPE);
2405 tree gnu_field_list = NULL_TREE;
2408 TYPE_NAME (gnu_bound_rec)
2409 = create_concat_name (gnat_entity, "XA");
2411 for (index = array_dim - 1; index >= 0; index--)
2413 tree gnu_index = TYPE_INDEX_TYPE (gnu_index_type[index]);
2414 tree gnu_index_name = TYPE_NAME (gnu_index);
2416 if (TREE_CODE (gnu_index_name) == TYPE_DECL)
2417 gnu_index_name = DECL_NAME (gnu_index_name);
2419 gnu_field = create_field_decl (gnu_index_name, gnu_index,
2421 0, NULL_TREE, NULL_TREE, 0);
2422 TREE_CHAIN (gnu_field) = gnu_field_list;
2423 gnu_field_list = gnu_field;
2426 finish_record_type (gnu_bound_rec, gnu_field_list, 0, false);
2427 add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
2430 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2431 = (Convention (gnat_entity) == Convention_Fortran);
2432 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2433 = (Is_Packed_Array_Type (gnat_entity)
2434 && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
2436 /* If our size depends on a placeholder and the maximum size doesn't
2437 overflow, use it. */
2438 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2439 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2440 && TREE_OVERFLOW (gnu_max_size))
2441 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2442 && TREE_OVERFLOW (gnu_max_size_unit))
2445 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2446 TYPE_SIZE (gnu_type));
2447 TYPE_SIZE_UNIT (gnu_type)
2448 = size_binop (MIN_EXPR, gnu_max_size_unit,
2449 TYPE_SIZE_UNIT (gnu_type));
2452 /* Set our alias set to that of our base type. This gives all
2453 array subtypes the same alias set. */
2454 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
2457 /* If this is a packed type, make this type the same as the packed
2458 array type, but do some adjusting in the type first. */
2459 if (Present (Packed_Array_Type (gnat_entity)))
2461 Entity_Id gnat_index;
2462 tree gnu_inner_type;
2464 /* First finish the type we had been making so that we output
2465 debugging information for it. */
2467 = build_qualified_type (gnu_type,
2468 (TYPE_QUALS (gnu_type)
2469 | (TYPE_QUAL_VOLATILE
2470 * Treat_As_Volatile (gnat_entity))));
2472 /* Make it artificial only if the base type was artificial as well.
2473 That's sort of "morally" true and will make it possible for the
2474 debugger to look it up by name in DWARF more easily. */
2476 = create_type_decl (gnu_entity_name, gnu_type, attr_list,
2477 !Comes_From_Source (gnat_entity)
2478 && !Comes_From_Source (Etype (gnat_entity)),
2479 debug_info_p, gnat_entity);
2481 /* Save it as our equivalent in case the call below elaborates
2483 save_gnu_tree (gnat_entity, gnu_decl, false);
2485 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2487 this_made_decl = true;
2488 gnu_type = TREE_TYPE (gnu_decl);
2489 save_gnu_tree (gnat_entity, NULL_TREE, false);
2491 gnu_inner_type = gnu_type;
2492 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2493 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
2494 || TYPE_IS_PADDING_P (gnu_inner_type)))
2495 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2497 /* We need to point the type we just made to our index type so
2498 the actual bounds can be put into a template. */
2500 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2501 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
2502 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2503 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2505 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2507 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2508 If it is, we need to make another type. */
2509 if (TYPE_MODULAR_P (gnu_inner_type))
2513 gnu_subtype = make_node (INTEGER_TYPE);
2515 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2516 TYPE_MIN_VALUE (gnu_subtype)
2517 = TYPE_MIN_VALUE (gnu_inner_type);
2518 TYPE_MAX_VALUE (gnu_subtype)
2519 = TYPE_MAX_VALUE (gnu_inner_type);
2520 TYPE_PRECISION (gnu_subtype)
2521 = TYPE_PRECISION (gnu_inner_type);
2522 TYPE_UNSIGNED (gnu_subtype)
2523 = TYPE_UNSIGNED (gnu_inner_type);
2524 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2525 layout_type (gnu_subtype);
2527 gnu_inner_type = gnu_subtype;
2530 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2533 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2535 for (gnat_index = First_Index (gnat_entity);
2536 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2537 SET_TYPE_ACTUAL_BOUNDS
2539 tree_cons (NULL_TREE,
2540 get_unpadded_type (Etype (gnat_index)),
2541 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2543 if (Convention (gnat_entity) != Convention_Fortran)
2544 SET_TYPE_ACTUAL_BOUNDS
2546 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2548 if (TREE_CODE (gnu_type) == RECORD_TYPE
2549 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2550 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2554 /* Abort if packed array with no packed array type field set. */
2556 gcc_assert (!Is_Packed (gnat_entity));
2560 case E_String_Literal_Subtype:
2561 /* Create the type for a string literal. */
2563 Entity_Id gnat_full_type
2564 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2565 && Present (Full_View (Etype (gnat_entity)))
2566 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2567 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2568 tree gnu_string_array_type
2569 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2570 tree gnu_string_index_type
2571 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2572 (TYPE_DOMAIN (gnu_string_array_type))));
2573 tree gnu_lower_bound
2574 = convert (gnu_string_index_type,
2575 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2576 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2577 tree gnu_length = ssize_int (length - 1);
2578 tree gnu_upper_bound
2579 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2581 convert (gnu_string_index_type, gnu_length));
2583 = build_range_type (gnu_string_index_type,
2584 gnu_lower_bound, gnu_upper_bound);
2586 = create_index_type (convert (sizetype,
2587 TYPE_MIN_VALUE (gnu_range_type)),
2589 TYPE_MAX_VALUE (gnu_range_type)),
2590 gnu_range_type, gnat_entity);
2593 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2595 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2596 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2597 relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
2601 /* Record Types and Subtypes
2603 The following fields are defined on record types:
2605 Has_Discriminants True if the record has discriminants
2606 First_Discriminant Points to head of list of discriminants
2607 First_Entity Points to head of list of fields
2608 Is_Tagged_Type True if the record is tagged
2610 Implementation of Ada records and discriminated records:
2612 A record type definition is transformed into the equivalent of a C
2613 struct definition. The fields that are the discriminants which are
2614 found in the Full_Type_Declaration node and the elements of the
2615 Component_List found in the Record_Type_Definition node. The
2616 Component_List can be a recursive structure since each Variant of
2617 the Variant_Part of the Component_List has a Component_List.
2619 Processing of a record type definition comprises starting the list of
2620 field declarations here from the discriminants and the calling the
2621 function components_to_record to add the rest of the fields from the
2622 component list and return the gnu type node. The function
2623 components_to_record will call itself recursively as it traverses
2627 if (Has_Complex_Representation (gnat_entity))
2630 = build_complex_type
2632 (Etype (Defining_Entity
2633 (First (Component_Items
2636 (Declaration_Node (gnat_entity)))))))));
2642 Node_Id full_definition = Declaration_Node (gnat_entity);
2643 Node_Id record_definition = Type_Definition (full_definition);
2644 Entity_Id gnat_field;
2646 tree gnu_field_list = NULL_TREE;
2647 tree gnu_get_parent;
2648 /* Set PACKED in keeping with gnat_to_gnu_field. */
2650 = Is_Packed (gnat_entity)
2652 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2654 : (Known_Alignment (gnat_entity)
2655 || (Strict_Alignment (gnat_entity)
2656 && Known_Static_Esize (gnat_entity)))
2659 bool has_rep = Has_Specified_Layout (gnat_entity);
2660 bool all_rep = has_rep;
2662 = (Is_Tagged_Type (gnat_entity)
2663 && Nkind (record_definition) == N_Derived_Type_Definition);
2665 /* See if all fields have a rep clause. Stop when we find one
2667 for (gnat_field = First_Entity (gnat_entity);
2668 Present (gnat_field) && all_rep;
2669 gnat_field = Next_Entity (gnat_field))
2670 if ((Ekind (gnat_field) == E_Component
2671 || Ekind (gnat_field) == E_Discriminant)
2672 && No (Component_Clause (gnat_field)))
2675 /* If this is a record extension, go a level further to find the
2676 record definition. Also, verify we have a Parent_Subtype. */
2679 if (!type_annotate_only
2680 || Present (Record_Extension_Part (record_definition)))
2681 record_definition = Record_Extension_Part (record_definition);
2683 gcc_assert (type_annotate_only
2684 || Present (Parent_Subtype (gnat_entity)));
2687 /* Make a node for the record. If we are not defining the record,
2688 suppress expanding incomplete types. */
2689 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2690 TYPE_NAME (gnu_type) = gnu_entity_name;
2691 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2694 defer_incomplete_level++, this_deferred = true;
2696 /* If both a size and rep clause was specified, put the size in
2697 the record type now so that it can get the proper mode. */
2698 if (has_rep && Known_Esize (gnat_entity))
2699 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2701 /* Always set the alignment here so that it can be used to
2702 set the mode, if it is making the alignment stricter. If
2703 it is invalid, it will be checked again below. If this is to
2704 be Atomic, choose a default alignment of a word unless we know
2705 the size and it's smaller. */
2706 if (Known_Alignment (gnat_entity))
2707 TYPE_ALIGN (gnu_type)
2708 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2709 else if (Is_Atomic (gnat_entity))
2710 TYPE_ALIGN (gnu_type)
2711 = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
2712 /* If a type needs strict alignment, the minimum size will be the
2713 type size instead of the RM size (see validate_size). Cap the
2714 alignment, lest it causes this type size to become too large. */
2715 else if (Strict_Alignment (gnat_entity)
2716 && Known_Static_Esize (gnat_entity))
2718 unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
2719 unsigned int raw_align = raw_size & -raw_size;
2720 if (raw_align < BIGGEST_ALIGNMENT)
2721 TYPE_ALIGN (gnu_type) = raw_align;
2724 TYPE_ALIGN (gnu_type) = 0;
2726 /* If we have a Parent_Subtype, make a field for the parent. If
2727 this record has rep clauses, force the position to zero. */
2728 if (Present (Parent_Subtype (gnat_entity)))
2730 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2733 /* A major complexity here is that the parent subtype will
2734 reference our discriminants in its Discriminant_Constraint
2735 list. But those must reference the parent component of this
2736 record which is of the parent subtype we have not built yet!
2737 To break the circle we first build a dummy COMPONENT_REF which
2738 represents the "get to the parent" operation and initialize
2739 each of those discriminants to a COMPONENT_REF of the above
2740 dummy parent referencing the corresponding discriminant of the
2741 base type of the parent subtype. */
2742 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2743 build0 (PLACEHOLDER_EXPR, gnu_type),
2744 build_decl (FIELD_DECL, NULL_TREE,
2748 if (Has_Discriminants (gnat_entity))
2749 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2750 Present (gnat_field);
2751 gnat_field = Next_Stored_Discriminant (gnat_field))
2752 if (Present (Corresponding_Discriminant (gnat_field)))
2755 build3 (COMPONENT_REF,
2756 get_unpadded_type (Etype (gnat_field)),
2758 gnat_to_gnu_field_decl (Corresponding_Discriminant
2763 /* Then we build the parent subtype. If it has discriminants but
2764 the type itself has unknown discriminants, this means that it
2765 doesn't contain information about how the discriminants are
2766 derived from those of the ancestor type, so it cannot be used
2767 directly. Instead it is built by cloning the parent subtype
2768 of the underlying record view of the type, for which the above
2769 derivation of discriminants has been made explicit. */
2770 if (Has_Discriminants (gnat_parent)
2771 && Has_Unknown_Discriminants (gnat_entity))
2773 Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
2775 /* If we are defining the type, the underlying record
2776 view must already have been elaborated at this point.
2777 Otherwise do it now as its parent subtype cannot be
2778 technically elaborated on its own. */
2780 gcc_assert (present_gnu_tree (gnat_uview));
2782 gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
2784 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
2786 /* Substitute the "get to the parent" of the type for that
2787 of its underlying record view in the cloned type. */
2788 for (gnat_field = First_Stored_Discriminant (gnat_uview);
2789 Present (gnat_field);
2790 gnat_field = Next_Stored_Discriminant (gnat_field))
2791 if (Present (Corresponding_Discriminant (gnat_field)))
2793 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
2795 = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2796 gnu_get_parent, gnu_field, NULL_TREE);
2798 = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
2802 gnu_parent = gnat_to_gnu_type (gnat_parent);
2804 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2805 initially built. The discriminants must reference the fields
2806 of the parent subtype and not those of its base type for the
2807 placeholder machinery to properly work. */
2808 if (Has_Discriminants (gnat_entity))
2809 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2810 Present (gnat_field);
2811 gnat_field = Next_Stored_Discriminant (gnat_field))
2812 if (Present (Corresponding_Discriminant (gnat_field)))
2814 Entity_Id field = Empty;
2815 for (field = First_Stored_Discriminant (gnat_parent);
2817 field = Next_Stored_Discriminant (field))
2818 if (same_discriminant_p (gnat_field, field))
2820 gcc_assert (Present (field));
2821 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2822 = gnat_to_gnu_field_decl (field);
2825 /* The "get to the parent" COMPONENT_REF must be given its
2827 TREE_TYPE (gnu_get_parent) = gnu_parent;
2829 /* ...and reference the _parent field of this record. */
2831 = create_field_decl (get_identifier
2832 (Get_Name_String (Name_uParent)),
2833 gnu_parent, gnu_type, 0,
2834 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2835 has_rep ? bitsize_zero_node : 0, 1);
2836 DECL_INTERNAL_P (gnu_field_list) = 1;
2837 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2840 /* Make the fields for the discriminants and put them into the record
2841 unless it's an Unchecked_Union. */
2842 if (Has_Discriminants (gnat_entity))
2843 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2844 Present (gnat_field);
2845 gnat_field = Next_Stored_Discriminant (gnat_field))
2847 /* If this is a record extension and this discriminant
2848 is the renaming of another discriminant, we've already
2849 handled the discriminant above. */
2850 if (Present (Parent_Subtype (gnat_entity))
2851 && Present (Corresponding_Discriminant (gnat_field)))
2855 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2857 /* Make an expression using a PLACEHOLDER_EXPR from the
2858 FIELD_DECL node just created and link that with the
2859 corresponding GNAT defining identifier. Then add to the
2861 save_gnu_tree (gnat_field,
2862 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2863 build0 (PLACEHOLDER_EXPR,
2864 DECL_CONTEXT (gnu_field)),
2865 gnu_field, NULL_TREE),
2868 if (!Is_Unchecked_Union (gnat_entity))
2870 TREE_CHAIN (gnu_field) = gnu_field_list;
2871 gnu_field_list = gnu_field;
2875 /* Put the discriminants into the record (backwards), so we can
2876 know the appropriate discriminant to use for the names of the
2878 TYPE_FIELDS (gnu_type) = gnu_field_list;
2880 /* Add the listed fields into the record and finish it up. */
2881 components_to_record (gnu_type, Component_List (record_definition),
2882 gnu_field_list, packed, definition, NULL,
2883 false, all_rep, false,
2884 Is_Unchecked_Union (gnat_entity));
2886 /* We used to remove the associations of the discriminants and
2887 _Parent for validity checking, but we may need them if there's
2888 Freeze_Node for a subtype used in this record. */
2889 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2890 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2892 /* If it is a tagged record force the type to BLKmode to insure
2893 that these objects will always be placed in memory. Do the
2894 same thing for limited record types. */
2895 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2896 SET_TYPE_MODE (gnu_type, BLKmode);
2898 /* Fill in locations of fields. */
2899 annotate_rep (gnat_entity, gnu_type);
2901 /* If there are any entities in the chain corresponding to
2902 components that we did not elaborate, ensure we elaborate their
2903 types if they are Itypes. */
2904 for (gnat_temp = First_Entity (gnat_entity);
2905 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2906 if ((Ekind (gnat_temp) == E_Component
2907 || Ekind (gnat_temp) == E_Discriminant)
2908 && Is_Itype (Etype (gnat_temp))
2909 && !present_gnu_tree (gnat_temp))
2910 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2914 case E_Class_Wide_Subtype:
2915 /* If an equivalent type is present, that is what we should use.
2916 Otherwise, fall through to handle this like a record subtype
2917 since it may have constraints. */
2918 if (gnat_equiv_type != gnat_entity)
2920 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2921 maybe_present = true;
2925 /* ... fall through ... */
2927 case E_Record_Subtype:
2929 /* If Cloned_Subtype is Present it means this record subtype has
2930 identical layout to that type or subtype and we should use
2931 that GCC type for this one. The front end guarantees that
2932 the component list is shared. */
2933 if (Present (Cloned_Subtype (gnat_entity)))
2935 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2937 maybe_present = true;
2940 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2941 changing the type, make a new type with each field having the
2942 type of the field in the new subtype but having the position
2943 computed by transforming every discriminant reference according
2944 to the constraints. We don't see any difference between
2945 private and nonprivate type here since derivations from types should
2946 have been deferred until the completion of the private type. */
2949 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2954 defer_incomplete_level++, this_deferred = true;
2956 /* Get the base type initially for its alignment and sizes. But
2957 if it is a padded type, we do all the other work with the
2959 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2961 if (TREE_CODE (gnu_base_type) == RECORD_TYPE
2962 && TYPE_IS_PADDING_P (gnu_base_type))
2963 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2965 gnu_type = gnu_orig_type = gnu_base_type;
2967 if (present_gnu_tree (gnat_entity))
2969 maybe_present = true;
2973 /* When the type has discriminants, and these discriminants
2974 affect the shape of what it built, factor them in.
2976 If we are making a subtype of an Unchecked_Union (must be an
2977 Itype), just return the type.
2979 We can't just use Is_Constrained because private subtypes without
2980 discriminants of full types with discriminants with default
2981 expressions are Is_Constrained but aren't constrained! */
2983 if (IN (Ekind (gnat_base_type), Record_Kind)
2984 && !Is_For_Access_Subtype (gnat_entity)
2985 && !Is_Unchecked_Union (gnat_base_type)
2986 && Is_Constrained (gnat_entity)
2987 && Stored_Constraint (gnat_entity) != No_Elist
2988 && Present (Discriminant_Constraint (gnat_entity)))
2990 Entity_Id gnat_field;
2991 tree gnu_field_list = 0;
2993 = compute_field_positions (gnu_orig_type, NULL_TREE,
2994 size_zero_node, bitsize_zero_node,
2997 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
3001 gnu_type = make_node (RECORD_TYPE);
3002 TYPE_NAME (gnu_type) = gnu_entity_name;
3003 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
3005 /* Set the size, alignment and alias set of the new type to
3006 match that of the old one, doing required substitutions.
3007 We do it this early because we need the size of the new
3008 type below to discard old fields if necessary. */
3009 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
3010 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
3011 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
3012 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
3013 relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
3015 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
3016 for (gnu_temp = gnu_subst_list;
3017 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3018 TYPE_SIZE (gnu_type)
3019 = substitute_in_expr (TYPE_SIZE (gnu_type),
3020 TREE_PURPOSE (gnu_temp),
3021 TREE_VALUE (gnu_temp));
3023 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
3024 for (gnu_temp = gnu_subst_list;
3025 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3026 TYPE_SIZE_UNIT (gnu_type)
3027 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
3028 TREE_PURPOSE (gnu_temp),
3029 TREE_VALUE (gnu_temp));
3031 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
3032 for (gnu_temp = gnu_subst_list;
3033 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3035 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
3036 TREE_PURPOSE (gnu_temp),
3037 TREE_VALUE (gnu_temp)));
3039 for (gnat_field = First_Entity (gnat_entity);
3040 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3041 if ((Ekind (gnat_field) == E_Component
3042 || Ekind (gnat_field) == E_Discriminant)
3043 && (Underlying_Type (Scope (Original_Record_Component
3046 && (No (Corresponding_Discriminant (gnat_field))
3047 || !Is_Tagged_Type (gnat_base_type)))
3050 = gnat_to_gnu_field_decl (Original_Record_Component
3053 = TREE_VALUE (purpose_member (gnu_old_field,
3055 tree gnu_pos = TREE_PURPOSE (gnu_offset);
3056 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
3058 = gnat_to_gnu_type (Etype (gnat_field));
3059 tree gnu_size = TYPE_SIZE (gnu_field_type);
3060 tree gnu_new_pos = NULL_TREE;
3061 unsigned int offset_align
3062 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
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
3072 (Original_Record_Component (gnat_field)))
3073 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
3074 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
3075 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
3076 == TREE_TYPE (gnu_old_field)))
3078 gnu_size = DECL_SIZE (gnu_old_field);
3079 gnu_field_type = TREE_TYPE (gnu_old_field);
3082 /* If the old field was packed and of constant size, we
3083 have to get the old size here, as it might differ from
3084 what the Etype conveys and the latter might overlap
3085 onto the following field. Try to arrange the type for
3086 possible better packing along the way. */
3087 else if (DECL_PACKED (gnu_old_field)
3088 && TREE_CODE (DECL_SIZE (gnu_old_field))
3091 gnu_size = DECL_SIZE (gnu_old_field);
3092 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
3093 && !TYPE_IS_FAT_POINTER_P (gnu_field_type)
3094 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
3096 = make_packable_type (gnu_field_type, true);
3099 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
3100 for (gnu_temp = gnu_subst_list;
3101 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
3102 gnu_pos = substitute_in_expr (gnu_pos,
3103 TREE_PURPOSE (gnu_temp),
3104 TREE_VALUE (gnu_temp));
3106 /* If the position is now a constant, we can set it as the
3107 position of the field when we make it. Otherwise, we need
3108 to deal with it specially below. */
3109 if (TREE_CONSTANT (gnu_pos))
3111 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
3113 /* Discard old fields that are outside the new type.
3114 This avoids confusing code scanning it to decide
3115 how to pass it to functions on some platforms. */
3116 if (TREE_CODE (gnu_new_pos) == INTEGER_CST
3117 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
3118 && !integer_zerop (gnu_size)
3119 && !tree_int_cst_lt (gnu_new_pos,
3120 TYPE_SIZE (gnu_type)))
3126 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
3127 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
3128 !DECL_NONADDRESSABLE_P (gnu_old_field));
3130 if (!TREE_CONSTANT (gnu_pos))
3132 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
3133 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
3134 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
3135 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
3136 DECL_SIZE (gnu_field) = gnu_size;
3137 DECL_SIZE_UNIT (gnu_field)
3138 = convert (sizetype,
3139 size_binop (CEIL_DIV_EXPR, gnu_size,
3140 bitsize_unit_node));
3141 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
3144 DECL_INTERNAL_P (gnu_field)
3145 = DECL_INTERNAL_P (gnu_old_field);
3146 SET_DECL_ORIGINAL_FIELD
3147 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
3148 ? DECL_ORIGINAL_FIELD (gnu_old_field)
3150 DECL_DISCRIMINANT_NUMBER (gnu_field)
3151 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
3152 TREE_THIS_VOLATILE (gnu_field)
3153 = TREE_THIS_VOLATILE (gnu_old_field);
3155 /* To match the layout crafted in components_to_record, if
3156 this is the _Tag field, put it before any discriminants
3157 instead of after them as for all other fields. */
3158 if (Chars (gnat_field) == Name_uTag)
3159 gnu_field_list = chainon (gnu_field_list, gnu_field);
3162 TREE_CHAIN (gnu_field) = gnu_field_list;
3163 gnu_field_list = gnu_field;
3166 save_gnu_tree (gnat_field, gnu_field, false);
3169 /* Now go through the entities again looking for Itypes that
3170 we have not elaborated but should (e.g., Etypes of fields
3171 that have Original_Components). */
3172 for (gnat_field = First_Entity (gnat_entity);
3173 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
3174 if ((Ekind (gnat_field) == E_Discriminant
3175 || Ekind (gnat_field) == E_Component)
3176 && !present_gnu_tree (Etype (gnat_field)))
3177 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
3179 /* Do not finalize it since we're going to modify it below. */
3180 gnu_field_list = nreverse (gnu_field_list);
3181 finish_record_type (gnu_type, gnu_field_list, 2, true);
3183 /* Finalize size and mode. */
3184 TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
3185 TYPE_SIZE_UNIT (gnu_type)
3186 = variable_size (TYPE_SIZE_UNIT (gnu_type));
3188 compute_record_mode (gnu_type);
3190 /* Fill in locations of fields. */
3191 annotate_rep (gnat_entity, gnu_type);
3193 /* We've built a new type, make an XVS type to show what this
3194 is a subtype of. Some debuggers require the XVS type to be
3195 output first, so do it in that order. */
3198 tree gnu_subtype_marker = make_node (RECORD_TYPE);
3199 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
3201 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
3202 gnu_orig_name = DECL_NAME (gnu_orig_name);
3204 TYPE_NAME (gnu_subtype_marker)
3205 = create_concat_name (gnat_entity, "XVS");
3206 finish_record_type (gnu_subtype_marker,
3207 create_field_decl (gnu_orig_name,
3214 add_parallel_type (TYPE_STUB_DECL (gnu_type),
3215 gnu_subtype_marker);
3218 /* Now we can finalize it. */
3219 rest_of_record_type_compilation (gnu_type);
3222 /* Otherwise, go down all the components in the new type and
3223 make them equivalent to those in the base type. */
3225 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3226 gnat_temp = Next_Entity (gnat_temp))
3227 if ((Ekind (gnat_temp) == E_Discriminant
3228 && !Is_Unchecked_Union (gnat_base_type))
3229 || Ekind (gnat_temp) == E_Component)
3230 save_gnu_tree (gnat_temp,
3231 gnat_to_gnu_field_decl
3232 (Original_Record_Component (gnat_temp)), false);
3236 case E_Access_Subprogram_Type:
3237 /* Use the special descriptor type for dispatch tables if needed,
3238 that is to say for the Prim_Ptr of a-tags.ads and its clones.
3239 Note that we are only required to do so for static tables in
3240 order to be compatible with the C++ ABI, but Ada 2005 allows
3241 to extend library level tagged types at the local level so
3242 we do it in the non-static case as well. */
3243 if (TARGET_VTABLE_USES_DESCRIPTORS
3244 && Is_Dispatch_Table_Entity (gnat_entity))
3246 gnu_type = fdesc_type_node;
3247 gnu_size = TYPE_SIZE (gnu_type);
3251 /* ... fall through ... */
3253 case E_Anonymous_Access_Subprogram_Type:
3254 /* If we are not defining this entity, and we have incomplete
3255 entities being processed above us, make a dummy type and
3256 fill it in later. */
3257 if (!definition && defer_incomplete_level != 0)
3259 struct incomplete *p
3260 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3263 = build_pointer_type
3264 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3265 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3266 !Comes_From_Source (gnat_entity),
3267 debug_info_p, gnat_entity);
3268 this_made_decl = true;
3269 gnu_type = TREE_TYPE (gnu_decl);
3270 save_gnu_tree (gnat_entity, gnu_decl, false);
3273 p->old_type = TREE_TYPE (gnu_type);
3274 p->full_type = Directly_Designated_Type (gnat_entity);
3275 p->next = defer_incomplete_list;
3276 defer_incomplete_list = p;
3280 /* ... fall through ... */
3282 case E_Allocator_Type:
3284 case E_Access_Attribute_Type:
3285 case E_Anonymous_Access_Type:
3286 case E_General_Access_Type:
3288 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
3289 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
3290 bool is_from_limited_with
3291 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
3292 && From_With_Type (gnat_desig_equiv));
3294 /* Get the "full view" of this entity. If this is an incomplete
3295 entity from a limited with, treat its non-limited view as the full
3296 view. Otherwise, if this is an incomplete or private type, use the
3297 full view. In the former case, we might point to a private type,
3298 in which case, we need its full view. Also, we want to look at the
3299 actual type used for the representation, so this takes a total of
3301 Entity_Id gnat_desig_full_direct_first
3302 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
3303 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
3304 ? Full_View (gnat_desig_equiv) : Empty));
3305 Entity_Id gnat_desig_full_direct
3306 = ((is_from_limited_with
3307 && Present (gnat_desig_full_direct_first)
3308 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
3309 ? Full_View (gnat_desig_full_direct_first)
3310 : gnat_desig_full_direct_first);
3311 Entity_Id gnat_desig_full
3312 = Gigi_Equivalent_Type (gnat_desig_full_direct);
3314 /* This the type actually used to represent the designated type,
3315 either gnat_desig_full or gnat_desig_equiv. */
3316 Entity_Id gnat_desig_rep;
3318 /* True if this is a pointer to an unconstrained array. */
3319 bool is_unconstrained_array;
3321 /* We want to know if we'll be seeing the freeze node for any
3322 incomplete type we may be pointing to. */
3324 = (Present (gnat_desig_full)
3325 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3326 : In_Extended_Main_Code_Unit (gnat_desig_type));
3328 /* True if we make a dummy type here. */
3329 bool got_fat_p = false;
3330 /* True if the dummy is a fat pointer. */
3331 bool made_dummy = false;
3332 tree gnu_desig_type = NULL_TREE;
3333 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3335 if (!targetm.valid_pointer_mode (p_mode))
3338 /* If either the designated type or its full view is an unconstrained
3339 array subtype, replace it with the type it's a subtype of. This
3340 avoids problems with multiple copies of unconstrained array types.
3341 Likewise, if the designated type is a subtype of an incomplete
3342 record type, use the parent type to avoid order of elaboration
3343 issues. This can lose some code efficiency, but there is no
3345 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3346 && ! Is_Constrained (gnat_desig_equiv))
3347 gnat_desig_equiv = Etype (gnat_desig_equiv);
3348 if (Present (gnat_desig_full)
3349 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3350 && ! Is_Constrained (gnat_desig_full))
3351 || (Ekind (gnat_desig_full) == E_Record_Subtype
3352 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3353 gnat_desig_full = Etype (gnat_desig_full);
3355 /* Now set the type that actually marks the representation of
3356 the designated type and also flag whether we have a unconstrained
3358 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3359 is_unconstrained_array
3360 = (Is_Array_Type (gnat_desig_rep)
3361 && ! Is_Constrained (gnat_desig_rep));
3363 /* If we are pointing to an incomplete type whose completion is an
3364 unconstrained array, make a fat pointer type. The two types in our
3365 fields will be pointers to dummy nodes and will be replaced in
3366 update_pointer_to. Similarly, if the type itself is a dummy type or
3367 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3368 in case we have any thin pointers to it. */
3369 if (is_unconstrained_array
3370 && (Present (gnat_desig_full)
3371 || (present_gnu_tree (gnat_desig_equiv)
3372 && TYPE_IS_DUMMY_P (TREE_TYPE
3373 (get_gnu_tree (gnat_desig_equiv))))
3374 || (No (gnat_desig_full) && ! in_main_unit
3375 && defer_incomplete_level != 0
3376 && ! present_gnu_tree (gnat_desig_equiv))
3377 || (in_main_unit && is_from_limited_with
3378 && Present (Freeze_Node (gnat_desig_rep)))))
3381 = (present_gnu_tree (gnat_desig_rep)
3382 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
3383 : make_dummy_type (gnat_desig_rep));
3386 /* Show the dummy we get will be a fat pointer. */
3387 got_fat_p = made_dummy = true;
3389 /* If the call above got something that has a pointer, that
3390 pointer is our type. This could have happened either
3391 because the type was elaborated or because somebody
3392 else executed the code below. */
3393 gnu_type = TYPE_POINTER_TO (gnu_old);
3396 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3397 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3398 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3399 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3401 TYPE_NAME (gnu_template_type)
3402 = create_concat_name (gnat_desig_equiv, "XUB");
3403 TYPE_DUMMY_P (gnu_template_type) = 1;
3405 TYPE_NAME (gnu_array_type)
3406 = create_concat_name (gnat_desig_equiv, "XUA");
3407 TYPE_DUMMY_P (gnu_array_type) = 1;
3409 gnu_type = make_node (RECORD_TYPE);
3410 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3411 TYPE_POINTER_TO (gnu_old) = gnu_type;
3413 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3415 = chainon (chainon (NULL_TREE,
3417 (get_identifier ("P_ARRAY"),
3419 gnu_type, 0, 0, 0, 0)),
3420 create_field_decl (get_identifier ("P_BOUNDS"),
3422 gnu_type, 0, 0, 0, 0));
3424 /* Make sure we can place this into a register. */
3425 TYPE_ALIGN (gnu_type)
3426 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3427 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
3429 /* Do not finalize this record type since the types of
3430 its fields are incomplete. */
3431 finish_record_type (gnu_type, fields, 0, true);
3433 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3434 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3435 = create_concat_name (gnat_desig_equiv, "XUT");
3436 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3440 /* If we already know what the full type is, use it. */
3441 else if (Present (gnat_desig_full)
3442 && present_gnu_tree (gnat_desig_full))
3443 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3445 /* Get the type of the thing we are to point to and build a pointer
3446 to it. If it is a reference to an incomplete or private type with a
3447 full view that is a record, make a dummy type node and get the
3448 actual type later when we have verified it is safe. */
3449 else if ((! in_main_unit
3450 && ! present_gnu_tree (gnat_desig_equiv)
3451 && Present (gnat_desig_full)
3452 && ! present_gnu_tree (gnat_desig_full)
3453 && Is_Record_Type (gnat_desig_full))
3454 /* Likewise if we are pointing to a record or array and we
3455 are to defer elaborating incomplete types. We do this
3456 since this access type may be the full view of some
3457 private type. Note that the unconstrained array case is
3459 || ((! in_main_unit || imported_p)
3460 && defer_incomplete_level != 0
3461 && ! present_gnu_tree (gnat_desig_equiv)
3462 && ((Is_Record_Type (gnat_desig_rep)
3463 || Is_Array_Type (gnat_desig_rep))))
3464 /* If this is a reference from a limited_with type back to our
3465 main unit and there's a Freeze_Node for it, either we have
3466 already processed the declaration and made the dummy type,
3467 in which case we just reuse the latter, or we have not yet,
3468 in which case we make the dummy type and it will be reused
3469 when the declaration is processed. In both cases, the
3470 pointer eventually created below will be automatically
3471 adjusted when the Freeze_Node is processed. Note that the
3472 unconstrained array case is handled above. */
3473 || (in_main_unit && is_from_limited_with
3474 && Present (Freeze_Node (gnat_desig_rep))))
3476 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3480 /* Otherwise handle the case of a pointer to itself. */
3481 else if (gnat_desig_equiv == gnat_entity)
3484 = build_pointer_type_for_mode (void_type_node, p_mode,
3485 No_Strict_Aliasing (gnat_entity));
3486 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3489 /* If expansion is disabled, the equivalent type of a concurrent
3490 type is absent, so build a dummy pointer type. */
3491 else if (type_annotate_only && No (gnat_desig_equiv))
3492 gnu_type = ptr_void_type_node;
3494 /* Finally, handle the straightforward case where we can just
3495 elaborate our designated type and point to it. */
3497 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3499 /* It is possible that a call to gnat_to_gnu_type above resolved our
3500 type. If so, just return it. */
3501 if (present_gnu_tree (gnat_entity))
3503 maybe_present = true;
3507 /* If we have a GCC type for the designated type, possibly modify it
3508 if we are pointing only to constant objects and then make a pointer
3509 to it. Don't do this for unconstrained arrays. */
3510 if (!gnu_type && gnu_desig_type)
3512 if (Is_Access_Constant (gnat_entity)
3513 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3516 = build_qualified_type
3518 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3520 /* Some extra processing is required if we are building a
3521 pointer to an incomplete type (in the GCC sense). We might
3522 have such a type if we just made a dummy, or directly out
3523 of the call to gnat_to_gnu_type above if we are processing
3524 an access type for a record component designating the
3525 record type itself. */
3526 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3528 /* We must ensure that the pointer to variant we make will
3529 be processed by update_pointer_to when the initial type
3530 is completed. Pretend we made a dummy and let further
3531 processing act as usual. */
3534 /* We must ensure that update_pointer_to will not retrieve
3535 the dummy variant when building a properly qualified
3536 version of the complete type. We take advantage of the
3537 fact that get_qualified_type is requiring TYPE_NAMEs to
3538 match to influence build_qualified_type and then also
3539 update_pointer_to here. */
3540 TYPE_NAME (gnu_desig_type)
3541 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3546 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3547 No_Strict_Aliasing (gnat_entity));
3550 /* If we are not defining this object and we made a dummy pointer,
3551 save our current definition, evaluate the actual type, and replace
3552 the tentative type we made with the actual one. If we are to defer
3553 actually looking up the actual type, make an entry in the
3554 deferred list. If this is from a limited with, we have to defer
3555 to the end of the current spec in two cases: first if the
3556 designated type is in the current unit and second if the access
3558 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3561 = TYPE_FAT_POINTER_P (gnu_type)
3562 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3564 if (esize == POINTER_SIZE
3565 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3567 = build_pointer_type
3568 (TYPE_OBJECT_RECORD_TYPE
3569 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3571 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
3572 !Comes_From_Source (gnat_entity),
3573 debug_info_p, gnat_entity);
3574 this_made_decl = true;
3575 gnu_type = TREE_TYPE (gnu_decl);
3576 save_gnu_tree (gnat_entity, gnu_decl, false);
3579 if (defer_incomplete_level == 0
3580 && ! (is_from_limited_with
3582 || In_Extended_Main_Code_Unit (gnat_entity))))
3583 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3584 gnat_to_gnu_type (gnat_desig_equiv));
3586 /* Note that the call to gnat_to_gnu_type here might have
3587 updated gnu_old_type directly, in which case it is not a
3588 dummy type any more when we get into update_pointer_to.
3590 This may happen for instance when the designated type is a
3591 record type, because their elaboration starts with an
3592 initial node from make_dummy_type, which may yield the same
3593 node as the one we got.
3595 Besides, variants of this non-dummy type might have been
3596 created along the way. update_pointer_to is expected to
3597 properly take care of those situations. */
3600 struct incomplete *p
3601 = (struct incomplete *) xmalloc (sizeof
3602 (struct incomplete));
3603 struct incomplete **head
3604 = (is_from_limited_with
3606 || In_Extended_Main_Code_Unit (gnat_entity))
3607 ? &defer_limited_with : &defer_incomplete_list);
3609 p->old_type = gnu_old_type;
3610 p->full_type = gnat_desig_equiv;
3618 case E_Access_Protected_Subprogram_Type:
3619 case E_Anonymous_Access_Protected_Subprogram_Type:
3620 if (type_annotate_only && No (gnat_equiv_type))
3621 gnu_type = ptr_void_type_node;
3624 /* The runtime representation is the equivalent type. */
3625 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3626 maybe_present = true;
3629 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3630 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3631 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3632 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3633 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3638 case E_Access_Subtype:
3640 /* We treat this as identical to its base type; any constraint is
3641 meaningful only to the front end.
3643 The designated type must be elaborated as well, if it does
3644 not have its own freeze node. Designated (sub)types created
3645 for constrained components of records with discriminants are
3646 not frozen by the front end and thus not elaborated by gigi,
3647 because their use may appear before the base type is frozen,
3648 and because it is not clear that they are needed anywhere in
3649 Gigi. With the current model, there is no correct place where
3650 they could be elaborated. */
3652 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3653 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3654 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3655 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3656 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3658 /* If we are not defining this entity, and we have incomplete
3659 entities being processed above us, make a dummy type and
3660 elaborate it later. */
3661 if (!definition && defer_incomplete_level != 0)
3663 struct incomplete *p
3664 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3666 = build_pointer_type
3667 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3669 p->old_type = TREE_TYPE (gnu_ptr_type);
3670 p->full_type = Directly_Designated_Type (gnat_entity);
3671 p->next = defer_incomplete_list;
3672 defer_incomplete_list = p;
3674 else if (!IN (Ekind (Base_Type
3675 (Directly_Designated_Type (gnat_entity))),
3676 Incomplete_Or_Private_Kind))
3677 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3681 maybe_present = true;
3684 /* Subprogram Entities
3686 The following access functions are defined for subprograms (functions
3689 First_Formal The first formal parameter.
3690 Is_Imported Indicates that the subprogram has appeared in
3691 an INTERFACE or IMPORT pragma. For now we
3692 assume that the external language is C.
3693 Is_Exported Likewise but for an EXPORT pragma.
3694 Is_Inlined True if the subprogram is to be inlined.
3696 In addition for function subprograms we have:
3698 Etype Return type of the function.
3700 Each parameter is first checked by calling must_pass_by_ref on its
3701 type to determine if it is passed by reference. For parameters which
3702 are copied in, if they are Ada In Out or Out parameters, their return
3703 value becomes part of a record which becomes the return type of the
3704 function (C function - note that this applies only to Ada procedures
3705 so there is no Ada return type). Additional code to store back the
3706 parameters will be generated on the caller side. This transformation
3707 is done here, not in the front-end.
3709 The intended result of the transformation can be seen from the
3710 equivalent source rewritings that follow:
3712 struct temp {int a,b};
3713 procedure P (A,B: In Out ...) is temp P (int A,B)
3716 end P; return {A,B};
3723 For subprogram types we need to perform mainly the same conversions to
3724 GCC form that are needed for procedures and function declarations. The
3725 only difference is that at the end, we make a type declaration instead
3726 of a function declaration. */
3728 case E_Subprogram_Type:
3732 /* The first GCC parameter declaration (a PARM_DECL node). The
3733 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3734 actually is the head of this parameter list. */
3735 tree gnu_param_list = NULL_TREE;
3736 /* Likewise for the stub associated with an exported procedure. */
3737 tree gnu_stub_param_list = NULL_TREE;
3738 /* The type returned by a function. If the subprogram is a procedure
3739 this type should be void_type_node. */
3740 tree gnu_return_type = void_type_node;
3741 /* List of fields in return type of procedure with copy-in copy-out
3743 tree gnu_field_list = NULL_TREE;
3744 /* Non-null for subprograms containing parameters passed by copy-in
3745 copy-out (Ada In Out or Out parameters not passed by reference),
3746 in which case it is the list of nodes used to specify the values of
3747 the in out/out parameters that are returned as a record upon
3748 procedure return. The TREE_PURPOSE of an element of this list is
3749 a field of the record and the TREE_VALUE is the PARM_DECL
3750 corresponding to that field. This list will be saved in the
3751 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3752 tree gnu_return_list = NULL_TREE;
3753 /* If an import pragma asks to map this subprogram to a GCC builtin,
3754 this is the builtin DECL node. */
3755 tree gnu_builtin_decl = NULL_TREE;
3756 /* For the stub associated with an exported procedure. */
3757 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3758 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3759 Entity_Id gnat_param;
3760 bool inline_flag = Is_Inlined (gnat_entity);
3761 bool public_flag = Is_Public (gnat_entity) || imported_p;
3763 = (Is_Public (gnat_entity) && !definition) || imported_p;
3765 /* The semantics of "pure" in Ada essentially matches that of "const"
3766 in the back-end. In particular, both properties are orthogonal to
3767 the "nothrow" property if the EH circuitry is explicit in the
3768 internal representation of the back-end. If we are to completely
3769 hide the EH circuitry from it, we need to declare that calls to pure
3770 Ada subprograms that can throw have side effects since they can
3771 trigger an "abnormal" transfer of control flow; thus they can be
3772 neither "const" nor "pure" in the back-end sense. */
3774 = (Exception_Mechanism == Back_End_Exceptions
3775 && Is_Pure (gnat_entity));
3777 bool volatile_flag = No_Return (gnat_entity);
3778 bool returns_by_ref = false;
3779 bool returns_unconstrained = false;
3780 bool returns_by_target_ptr = false;
3781 bool has_copy_in_out = false;
3782 bool has_stub = false;
3785 if (kind == E_Subprogram_Type && !definition)
3786 /* A parameter may refer to this type, so defer completion
3787 of any incomplete types. */
3788 defer_incomplete_level++, this_deferred = true;
3790 /* If the subprogram has an alias, it is probably inherited, so
3791 we can use the original one. If the original "subprogram"
3792 is actually an enumeration literal, it may be the first use
3793 of its type, so we must elaborate that type now. */
3794 if (Present (Alias (gnat_entity)))
3796 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3797 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3799 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3802 /* Elaborate any Itypes in the parameters of this entity. */
3803 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3804 Present (gnat_temp);
3805 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3806 if (Is_Itype (Etype (gnat_temp)))
3807 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3812 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3813 corresponding DECL node.
3815 We still want the parameter associations to take place because the
3816 proper generation of calls depends on it (a GNAT parameter without
3817 a corresponding GCC tree has a very specific meaning), so we don't
3819 if (Convention (gnat_entity) == Convention_Intrinsic)
3820 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3822 /* ??? What if we don't find the builtin node above ? warn ? err ?
3823 In the current state we neither warn nor err, and calls will just
3824 be handled as for regular subprograms. */
3826 if (kind == E_Function || kind == E_Subprogram_Type)
3827 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3829 /* If this function returns by reference, make the actual
3830 return type of this function the pointer and mark the decl. */
3831 if (Returns_By_Ref (gnat_entity))
3833 returns_by_ref = true;
3834 gnu_return_type = build_pointer_type (gnu_return_type);
3837 /* If the Mechanism is By_Reference, ensure the return type uses
3838 the machine's by-reference mechanism, which may not the same
3839 as above (e.g., it might be by passing a fake parameter). */
3840 else if (kind == E_Function
3841 && Mechanism (gnat_entity) == By_Reference)
3843 TREE_ADDRESSABLE (gnu_return_type) = 1;
3845 /* We expect this bit to be reset by gigi shortly, so can avoid a
3846 type node copy here. This actually also prevents troubles with
3847 the generation of debug information for the function, because
3848 we might have issued such info for this type already, and would
3849 be attaching a distinct type node to the function if we made a
3853 /* If we are supposed to return an unconstrained array,
3854 actually return a fat pointer and make a note of that. Return
3855 a pointer to an unconstrained record of variable size. */
3856 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3858 gnu_return_type = TREE_TYPE (gnu_return_type);
3859 returns_unconstrained = true;
3862 /* If the type requires a transient scope, the result is allocated
3863 on the secondary stack, so the result type of the function is
3865 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3867 gnu_return_type = build_pointer_type (gnu_return_type);
3868 returns_unconstrained = true;
3871 /* If the type is a padded type and the underlying type would not
3872 be passed by reference or this function has a foreign convention,
3873 return the underlying type. */
3874 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3875 && TYPE_IS_PADDING_P (gnu_return_type)
3876 && (!default_pass_by_ref (TREE_TYPE
3877 (TYPE_FIELDS (gnu_return_type)))
3878 || Has_Foreign_Convention (gnat_entity)))
3879 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3881 /* If the return type has a non-constant size, we convert the function
3882 into a procedure and its caller will pass a pointer to an object as
3883 the first parameter when we call the function. This can happen for
3884 an unconstrained type with a maximum size or a constrained type with
3885 a size not known at compile time. */
3886 if (TYPE_SIZE_UNIT (gnu_return_type)
3887 && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
3889 returns_by_target_ptr = true;
3891 = create_param_decl (get_identifier ("TARGET"),
3892 build_reference_type (gnu_return_type),
3894 gnu_return_type = void_type_node;
3897 /* If the return type has a size that overflows, we cannot have
3898 a function that returns that type. This usage doesn't make
3899 sense anyway, so give an error here. */
3900 if (TYPE_SIZE_UNIT (gnu_return_type)
3901 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3902 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3904 post_error ("cannot return type whose size overflows",
3906 gnu_return_type = copy_node (gnu_return_type);
3907 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3908 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3909 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3910 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3913 /* Look at all our parameters and get the type of
3914 each. While doing this, build a copy-out structure if
3917 /* Loop over the parameters and get their associated GCC tree.
3918 While doing this, build a copy-out structure if we need one. */
3919 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3920 Present (gnat_param);
3921 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3923 tree gnu_param_name = get_entity_name (gnat_param);
3924 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3925 tree gnu_param, gnu_field;
3926 bool copy_in_copy_out = false;
3927 Mechanism_Type mech = Mechanism (gnat_param);
3929 /* Builtins are expanded inline and there is no real call sequence
3930 involved. So the type expected by the underlying expander is
3931 always the type of each argument "as is". */
3932 if (gnu_builtin_decl)
3934 /* Handle the first parameter of a valued procedure specially. */
3935 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3936 mech = By_Copy_Return;
3937 /* Otherwise, see if a Mechanism was supplied that forced this
3938 parameter to be passed one way or another. */
3939 else if (mech == Default
3940 || mech == By_Copy || mech == By_Reference)
3942 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3943 mech = By_Descriptor;
3945 else if (By_Short_Descriptor_Last <= mech &&
3946 mech <= By_Short_Descriptor)
3947 mech = By_Short_Descriptor;
3951 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3952 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3953 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3955 mech = By_Reference;
3961 post_error ("unsupported mechanism for&", gnat_param);
3966 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
3967 Has_Foreign_Convention (gnat_entity),
3970 /* We are returned either a PARM_DECL or a type if no parameter
3971 needs to be passed; in either case, adjust the type. */
3972 if (DECL_P (gnu_param))
3973 gnu_param_type = TREE_TYPE (gnu_param);
3976 gnu_param_type = gnu_param;
3977 gnu_param = NULL_TREE;
3982 /* If it's an exported subprogram, we build a parameter list
3983 in parallel, in case we need to emit a stub for it. */
3984 if (Is_Exported (gnat_entity))
3987 = chainon (gnu_param, gnu_stub_param_list);
3988 /* Change By_Descriptor parameter to By_Reference for
3989 the internal version of an exported subprogram. */
3990 if (mech == By_Descriptor || mech == By_Short_Descriptor)
3993 = gnat_to_gnu_param (gnat_param, By_Reference,
3999 gnu_param = copy_node (gnu_param);
4002 gnu_param_list = chainon (gnu_param, gnu_param_list);
4003 Sloc_to_locus (Sloc (gnat_param),
4004 &DECL_SOURCE_LOCATION (gnu_param));
4005 save_gnu_tree (gnat_param, gnu_param, false);
4007 /* If a parameter is a pointer, this function may modify
4008 memory through it and thus shouldn't be considered
4009 a const function. Also, the memory may be modified
4010 between two calls, so they can't be CSE'ed. The latter
4011 case also handles by-ref parameters. */
4012 if (POINTER_TYPE_P (gnu_param_type)
4013 || TYPE_FAT_POINTER_P (gnu_param_type))
4017 if (copy_in_copy_out)
4019 if (!has_copy_in_out)
4021 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
4022 gnu_return_type = make_node (RECORD_TYPE);
4023 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
4024 has_copy_in_out = true;
4027 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
4028 gnu_return_type, 0, 0, 0, 0);
4029 Sloc_to_locus (Sloc (gnat_param),
4030 &DECL_SOURCE_LOCATION (gnu_field));
4031 TREE_CHAIN (gnu_field) = gnu_field_list;
4032 gnu_field_list = gnu_field;
4033 gnu_return_list = tree_cons (gnu_field, gnu_param,
4038 /* Do not compute record for out parameters if subprogram is
4039 stubbed since structures are incomplete for the back-end. */
4040 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
4041 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
4044 /* If we have a CICO list but it has only one entry, we convert
4045 this function into a function that simply returns that one
4047 if (list_length (gnu_return_list) == 1)
4048 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
4050 if (Has_Stdcall_Convention (gnat_entity))
4051 prepend_one_attribute_to
4052 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4053 get_identifier ("stdcall"), NULL_TREE,
4056 /* If we are on a target where stack realignment is needed for 'main'
4057 to honor GCC's implicit expectations (stack alignment greater than
4058 what the base ABI guarantees), ensure we do the same for foreign
4059 convention subprograms as they might be used as callbacks from code
4060 breaking such expectations. Note that this applies to task entry
4061 points in particular. */
4062 if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
4063 && Has_Foreign_Convention (gnat_entity))
4064 prepend_one_attribute_to
4065 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
4066 get_identifier ("force_align_arg_pointer"), NULL_TREE,
4069 /* The lists have been built in reverse. */
4070 gnu_param_list = nreverse (gnu_param_list);
4072 gnu_stub_param_list = nreverse (gnu_stub_param_list);
4073 gnu_return_list = nreverse (gnu_return_list);
4075 if (Ekind (gnat_entity) == E_Function)
4076 Set_Mechanism (gnat_entity,
4077 (returns_by_ref || returns_unconstrained
4078 ? By_Reference : By_Copy));
4080 = create_subprog_type (gnu_return_type, gnu_param_list,
4081 gnu_return_list, returns_unconstrained,
4082 returns_by_ref, returns_by_target_ptr);
4086 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
4087 gnu_return_list, returns_unconstrained,
4088 returns_by_ref, returns_by_target_ptr);
4090 /* A subprogram (something that doesn't return anything) shouldn't
4091 be considered const since there would be no reason for such a
4092 subprogram. Note that procedures with Out (or In Out) parameters
4093 have already been converted into a function with a return type. */
4094 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
4098 = build_qualified_type (gnu_type,
4099 TYPE_QUALS (gnu_type)
4100 | (TYPE_QUAL_CONST * const_flag)
4101 | (TYPE_QUAL_VOLATILE * volatile_flag));
4103 Sloc_to_locus (Sloc (gnat_entity), &input_location);
4107 = build_qualified_type (gnu_stub_type,
4108 TYPE_QUALS (gnu_stub_type)
4109 | (TYPE_QUAL_CONST * const_flag)
4110 | (TYPE_QUAL_VOLATILE * volatile_flag));
4112 /* If we have a builtin decl for that function, check the signatures
4113 compatibilities. If the signatures are compatible, use the builtin
4114 decl. If they are not, we expect the checker predicate to have
4115 posted the appropriate errors, and just continue with what we have
4117 if (gnu_builtin_decl)
4119 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
4121 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
4123 gnu_decl = gnu_builtin_decl;
4124 gnu_type = gnu_builtin_type;
4129 /* If there was no specified Interface_Name and the external and
4130 internal names of the subprogram are the same, only use the
4131 internal name to allow disambiguation of nested subprograms. */
4132 if (No (Interface_Name (gnat_entity))
4133 && gnu_ext_name == gnu_entity_name)
4134 gnu_ext_name = NULL_TREE;
4136 /* If we are defining the subprogram and it has an Address clause
4137 we must get the address expression from the saved GCC tree for the
4138 subprogram if it has a Freeze_Node. Otherwise, we elaborate
4139 the address expression here since the front-end has guaranteed
4140 in that case that the elaboration has no effects. If there is
4141 an Address clause and we are not defining the object, just
4142 make it a constant. */
4143 if (Present (Address_Clause (gnat_entity)))
4145 tree gnu_address = NULL_TREE;
4149 = (present_gnu_tree (gnat_entity)
4150 ? get_gnu_tree (gnat_entity)
4151 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
4153 save_gnu_tree (gnat_entity, NULL_TREE, false);
4155 /* Convert the type of the object to a reference type that can
4156 alias everything as per 13.3(19). */
4158 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
4160 gnu_address = convert (gnu_type, gnu_address);
4163 = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
4164 gnu_address, false, Is_Public (gnat_entity),
4165 extern_flag, false, NULL, gnat_entity);
4166 DECL_BY_REF_P (gnu_decl) = 1;
4169 else if (kind == E_Subprogram_Type)
4170 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4171 !Comes_From_Source (gnat_entity),
4172 debug_info_p, gnat_entity);
4177 gnu_stub_name = gnu_ext_name;
4178 gnu_ext_name = create_concat_name (gnat_entity, "internal");
4179 public_flag = false;
4182 gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
4183 gnu_type, gnu_param_list,
4184 inline_flag, public_flag,
4185 extern_flag, attr_list,
4190 = create_subprog_decl (gnu_entity_name, gnu_stub_name,
4191 gnu_stub_type, gnu_stub_param_list,
4193 extern_flag, attr_list,
4195 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
4198 /* This is unrelated to the stub built right above. */
4199 DECL_STUBBED_P (gnu_decl)
4200 = Convention (gnat_entity) == Convention_Stubbed;
4205 case E_Incomplete_Type:
4206 case E_Incomplete_Subtype:
4207 case E_Private_Type:
4208 case E_Private_Subtype:
4209 case E_Limited_Private_Type:
4210 case E_Limited_Private_Subtype:
4211 case E_Record_Type_With_Private:
4212 case E_Record_Subtype_With_Private:
4214 /* Get the "full view" of this entity. If this is an incomplete
4215 entity from a limited with, treat its non-limited view as the
4216 full view. Otherwise, use either the full view or the underlying
4217 full view, whichever is present. This is used in all the tests
4220 = (IN (Ekind (gnat_entity), Incomplete_Kind)
4221 && From_With_Type (gnat_entity))
4222 ? Non_Limited_View (gnat_entity)
4223 : Present (Full_View (gnat_entity))
4224 ? Full_View (gnat_entity)
4225 : Underlying_Full_View (gnat_entity);
4227 /* If this is an incomplete type with no full view, it must be a Taft
4228 Amendment type, in which case we return a dummy type. Otherwise,
4229 just get the type from its Etype. */
4232 if (kind == E_Incomplete_Type)
4234 gnu_type = make_dummy_type (gnat_entity);
4235 gnu_decl = TYPE_STUB_DECL (gnu_type);
4239 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
4241 maybe_present = true;
4246 /* If we already made a type for the full view, reuse it. */
4247 else if (present_gnu_tree (full_view))
4249 gnu_decl = get_gnu_tree (full_view);
4253 /* Otherwise, if we are not defining the type now, get the type
4254 from the full view. But always get the type from the full view
4255 for define on use types, since otherwise we won't see them! */
4256 else if (!definition
4257 || (Is_Itype (full_view)
4258 && No (Freeze_Node (gnat_entity)))
4259 || (Is_Itype (gnat_entity)
4260 && No (Freeze_Node (full_view))))
4262 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
4263 maybe_present = true;
4267 /* For incomplete types, make a dummy type entry which will be
4268 replaced later. Save it as the full declaration's type so
4269 we can do any needed updates when we see it. */
4270 gnu_type = make_dummy_type (gnat_entity);
4271 gnu_decl = TYPE_STUB_DECL (gnu_type);
4272 save_gnu_tree (full_view, gnu_decl, 0);
4276 /* Simple class_wide types are always viewed as their root_type
4277 by Gigi unless an Equivalent_Type is specified. */
4278 case E_Class_Wide_Type:
4279 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
4280 maybe_present = true;
4284 case E_Task_Subtype:
4285 case E_Protected_Type:
4286 case E_Protected_Subtype:
4287 if (type_annotate_only && No (gnat_equiv_type))
4288 gnu_type = void_type_node;
4290 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
4292 maybe_present = true;
4296 gnu_decl = create_label_decl (gnu_entity_name);
4301 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4302 we've already saved it, so we don't try to. */
4303 gnu_decl = error_mark_node;
4311 /* If we had a case where we evaluated another type and it might have
4312 defined this one, handle it here. */
4313 if (maybe_present && present_gnu_tree (gnat_entity))
4315 gnu_decl = get_gnu_tree (gnat_entity);
4319 /* If we are processing a type and there is either no decl for it or
4320 we just made one, do some common processing for the type, such as
4321 handling alignment and possible padding. */
4323 if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
4325 if (Is_Tagged_Type (gnat_entity)
4326 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4327 TYPE_ALIGN_OK (gnu_type) = 1;
4329 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4330 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4332 /* ??? Don't set the size for a String_Literal since it is either
4333 confirming or we don't handle it properly (if the low bound is
4335 if (!gnu_size && kind != E_String_Literal_Subtype)
4336 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4338 Has_Size_Clause (gnat_entity));
4340 /* If a size was specified, see if we can make a new type of that size
4341 by rearranging the type, for example from a fat to a thin pointer. */
4345 = make_type_from_size (gnu_type, gnu_size,
4346 Has_Biased_Representation (gnat_entity));
4348 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4349 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4353 /* If the alignment hasn't already been processed and this is
4354 not an unconstrained array, see if an alignment is specified.
4355 If not, we pick a default alignment for atomic objects. */
4356 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4358 else if (Known_Alignment (gnat_entity))
4360 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4361 TYPE_ALIGN (gnu_type));
4363 /* Warn on suspiciously large alignments. This should catch
4364 errors about the (alignment,byte)/(size,bit) discrepancy. */
4365 if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
4369 /* If a size was specified, take it into account. Otherwise
4370 use the RM size for records as the type size has already
4371 been adjusted to the alignment. */
4374 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
4375 || TREE_CODE (gnu_type) == UNION_TYPE
4376 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
4377 && !TYPE_IS_FAT_POINTER_P (gnu_type))
4378 size = rm_size (gnu_type);
4380 size = TYPE_SIZE (gnu_type);
4382 /* Consider an alignment as suspicious if the alignment/size
4383 ratio is greater or equal to the byte/bit ratio. */
4384 if (host_integerp (size, 1)
4385 && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
4386 post_error_ne ("?suspiciously large alignment specified for&",
4387 Expression (Alignment_Clause (gnat_entity)),
4391 else if (Is_Atomic (gnat_entity) && !gnu_size
4392 && host_integerp (TYPE_SIZE (gnu_type), 1)
4393 && integer_pow2p (TYPE_SIZE (gnu_type)))
4394 align = MIN (BIGGEST_ALIGNMENT,
4395 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4396 else if (Is_Atomic (gnat_entity) && gnu_size
4397 && host_integerp (gnu_size, 1)
4398 && integer_pow2p (gnu_size))
4399 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4401 /* See if we need to pad the type. If we did, and made a record,
4402 the name of the new type may be changed. So get it back for
4403 us when we make the new TYPE_DECL below. */
4404 if (gnu_size || align > 0)
4405 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
4406 "PAD", true, definition, false);
4408 if (TREE_CODE (gnu_type) == RECORD_TYPE
4409 && TYPE_IS_PADDING_P (gnu_type))
4411 gnu_entity_name = TYPE_NAME (gnu_type);
4412 if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
4413 gnu_entity_name = DECL_NAME (gnu_entity_name);
4416 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4418 /* If we are at global level, GCC will have applied variable_size to
4419 the type, but that won't have done anything. So, if it's not
4420 a constant or self-referential, call elaborate_expression_1 to
4421 make a variable for the size rather than calculating it each time.
4422 Handle both the RM size and the actual size. */
4423 if (global_bindings_p ()
4424 && TYPE_SIZE (gnu_type)
4425 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4426 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4428 if (TREE_CODE (gnu_type) == RECORD_TYPE
4429 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4430 TYPE_SIZE (gnu_type), 0))
4432 TYPE_SIZE (gnu_type)
4433 = elaborate_expression_1 (gnat_entity, gnat_entity,
4434 TYPE_SIZE (gnu_type),
4435 get_identifier ("SIZE"),
4437 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4441 TYPE_SIZE (gnu_type)
4442 = elaborate_expression_1 (gnat_entity, gnat_entity,
4443 TYPE_SIZE (gnu_type),
4444 get_identifier ("SIZE"),
4447 /* ??? For now, store the size as a multiple of the alignment
4448 in bytes so that we can see the alignment from the tree. */
4449 TYPE_SIZE_UNIT (gnu_type)
4451 (MULT_EXPR, sizetype,
4452 elaborate_expression_1
4453 (gnat_entity, gnat_entity,
4454 build_binary_op (EXACT_DIV_EXPR, sizetype,
4455 TYPE_SIZE_UNIT (gnu_type),
4456 size_int (TYPE_ALIGN (gnu_type)
4458 get_identifier ("SIZE_A_UNIT"),
4460 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4462 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4465 elaborate_expression_1 (gnat_entity,
4467 TYPE_ADA_SIZE (gnu_type),
4468 get_identifier ("RM_SIZE"),
4473 /* If this is a record type or subtype, call elaborate_expression_1 on
4474 any field position. Do this for both global and local types.
4475 Skip any fields that we haven't made trees for to avoid problems with
4476 class wide types. */
4477 if (IN (kind, Record_Kind))
4478 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4479 gnat_temp = Next_Entity (gnat_temp))
4480 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4482 tree gnu_field = get_gnu_tree (gnat_temp);
4484 /* ??? Unfortunately, GCC needs to be able to prove the
4485 alignment of this offset and if it's a variable, it can't.
4486 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4487 right now, we have to put in an explicit multiply and
4488 divide by that value. */
4489 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4491 DECL_FIELD_OFFSET (gnu_field)
4493 (MULT_EXPR, sizetype,
4494 elaborate_expression_1
4495 (gnat_temp, gnat_temp,
4496 build_binary_op (EXACT_DIV_EXPR, sizetype,
4497 DECL_FIELD_OFFSET (gnu_field),
4498 size_int (DECL_OFFSET_ALIGN (gnu_field)
4500 get_identifier ("OFFSET"),
4502 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4504 /* ??? The context of gnu_field is not necessarily gnu_type so
4505 the MULT_EXPR node built above may not be marked by the call
4506 to create_type_decl below. */
4507 if (global_bindings_p ())
4508 mark_visited (&DECL_FIELD_OFFSET (gnu_field));
4512 gnu_type = build_qualified_type (gnu_type,
4513 (TYPE_QUALS (gnu_type)
4514 | (TYPE_QUAL_VOLATILE
4515 * Treat_As_Volatile (gnat_entity))));
4517 if (Is_Atomic (gnat_entity))
4518 check_ok_for_atomic (gnu_type, gnat_entity, false);
4520 if (Present (Alignment_Clause (gnat_entity)))
4521 TYPE_USER_ALIGN (gnu_type) = 1;
4523 if (Universal_Aliasing (gnat_entity))
4524 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4527 gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
4528 !Comes_From_Source (gnat_entity),
4529 debug_info_p, gnat_entity);
4531 TREE_TYPE (gnu_decl) = gnu_type;
4534 if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4536 gnu_type = TREE_TYPE (gnu_decl);
4538 /* If this is a derived type, relate its alias set to that of its parent
4539 to avoid troubles when a call to an inherited primitive is inlined in
4540 a context where a derived object is accessed. The inlined code works
4541 on the parent view so the resulting code may access the same object
4542 using both the parent and the derived alias sets, which thus have to
4543 conflict. As the same issue arises with component references, the
4544 parent alias set also has to conflict with composite types enclosing
4545 derived components. For instance, if we have:
4552 we want T to conflict with both D and R, in addition to R being a
4553 superset of D by record/component construction.
4555 One way to achieve this is to perform an alias set copy from the
4556 parent to the derived type. This is not quite appropriate, though,
4557 as we don't want separate derived types to conflict with each other:
4559 type I1 is new Integer;
4560 type I2 is new Integer;
4562 We want I1 and I2 to both conflict with Integer but we do not want
4563 I1 to conflict with I2, and an alias set copy on derivation would
4566 The option chosen is to make the alias set of the derived type a
4567 superset of that of its parent type. It trivially fulfills the
4568 simple requirement for the Integer derivation example above, and
4569 the component case as well by superset transitivity:
4572 R ----------> D ----------> T
4574 The language rules ensure the parent type is already frozen here. */
4575 if (Is_Derived_Type (gnat_entity))
4577 tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
4578 relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET);
4581 /* Back-annotate the Alignment of the type if not already in the
4582 tree. Likewise for sizes. */
4583 if (Unknown_Alignment (gnat_entity))
4584 Set_Alignment (gnat_entity,
4585 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4587 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4589 /* If the size is self-referential, we annotate the maximum
4590 value of that size. */
4591 tree gnu_size = TYPE_SIZE (gnu_type);
4593 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4594 gnu_size = max_size (gnu_size, true);
4596 Set_Esize (gnat_entity, annotate_value (gnu_size));
4598 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4600 /* In this mode the tag and the parent components are not
4601 generated by the front-end, so the sizes must be adjusted
4603 int size_offset, new_size;
4605 if (Is_Derived_Type (gnat_entity))
4608 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4609 Set_Alignment (gnat_entity,
4610 Alignment (Etype (Base_Type (gnat_entity))));
4613 size_offset = POINTER_SIZE;
4615 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4616 Set_Esize (gnat_entity,
4617 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4618 / POINTER_SIZE) * POINTER_SIZE));
4619 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4623 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4624 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4627 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4628 DECL_ARTIFICIAL (gnu_decl) = 1;
4630 if (!debug_info_p && DECL_P (gnu_decl)
4631 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4632 && No (Renamed_Object (gnat_entity)))
4633 DECL_IGNORED_P (gnu_decl) = 1;
4635 /* If we haven't already, associate the ..._DECL node that we just made with
4636 the input GNAT entity node. */
4638 save_gnu_tree (gnat_entity, gnu_decl, false);
4640 /* If this is an enumeral or floating-point type, we were not able to set
4641 the bounds since they refer to the type. These bounds are always static.
4643 For enumeration types, also write debugging information and declare the
4644 enumeration literal table, if needed. */
4646 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4647 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4649 tree gnu_scalar_type = gnu_type;
4651 /* If this is a padded type, we need to use the underlying type. */
4652 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
4653 && TYPE_IS_PADDING_P (gnu_scalar_type))
4654 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4656 /* If this is a floating point type and we haven't set a floating
4657 point type yet, use this in the evaluation of the bounds. */
4658 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4659 longest_float_type_node = gnu_type;
4661 TYPE_MIN_VALUE (gnu_scalar_type)
4662 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4663 TYPE_MAX_VALUE (gnu_scalar_type)
4664 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4666 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4668 /* Since this has both a typedef and a tag, avoid outputting
4670 DECL_ARTIFICIAL (gnu_decl) = 1;
4671 rest_of_type_decl_compilation (gnu_decl);
4675 /* If we deferred processing of incomplete types, re-enable it. If there
4676 were no other disables and we have some to process, do so. */
4677 if (this_deferred && --defer_incomplete_level == 0)
4679 if (defer_incomplete_list)
4681 struct incomplete *incp, *next;
4683 /* We are back to level 0 for the deferring of incomplete types.
4684 But processing these incomplete types below may itself require
4685 deferring, so preserve what we have and restart from scratch. */
4686 incp = defer_incomplete_list;
4687 defer_incomplete_list = NULL;
4689 /* For finalization, however, all types must be complete so we
4690 cannot do the same because deferred incomplete types may end up
4691 referencing each other. Process them all recursively first. */
4692 defer_finalize_level++;
4694 for (; incp; incp = next)
4699 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4700 gnat_to_gnu_type (incp->full_type));
4704 defer_finalize_level--;
4707 /* All the deferred incomplete types have been processed so we can
4708 now proceed with the finalization of the deferred types. */
4709 if (defer_finalize_level == 0 && defer_finalize_list)
4714 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4715 rest_of_type_decl_compilation_no_defer (t);
4717 VEC_free (tree, heap, defer_finalize_list);
4721 /* If we are not defining this type, see if it's in the incomplete list.
4722 If so, handle that list entry now. */
4723 else if (!definition)
4725 struct incomplete *incp;
4727 for (incp = defer_incomplete_list; incp; incp = incp->next)
4728 if (incp->old_type && incp->full_type == gnat_entity)
4730 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4731 TREE_TYPE (gnu_decl));
4732 incp->old_type = NULL_TREE;
4739 /* If this is a packed array type whose original array type is itself
4740 an Itype without freeze node, make sure the latter is processed. */
4741 if (Is_Packed_Array_Type (gnat_entity)
4742 && Is_Itype (Original_Array_Type (gnat_entity))
4743 && No (Freeze_Node (Original_Array_Type (gnat_entity)))
4744 && !present_gnu_tree (Original_Array_Type (gnat_entity)))
4745 gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
4750 /* Similar, but if the returned value is a COMPONENT_REF, return the
4754 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4756 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4758 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4759 gnu_field = TREE_OPERAND (gnu_field, 1);
4764 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4765 the GCC type corresponding to that entity. */
4768 gnat_to_gnu_type (Entity_Id gnat_entity)
4772 /* The back end never attempts to annotate generic types. */
4773 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
4774 return void_type_node;
4776 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4777 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
4779 return TREE_TYPE (gnu_decl);
4782 /* Similar, but GNAT_ENTITY is assumed to refer to a GNAT type. Return
4783 the unpadded version of the GCC type corresponding to that entity. */
4786 get_unpadded_type (Entity_Id gnat_entity)
4788 tree type = gnat_to_gnu_type (gnat_entity);
4790 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4791 type = TREE_TYPE (TYPE_FIELDS (type));
4796 /* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
4797 Every TYPE_DECL generated for a type definition must be passed
4798 to this function once everything else has been done for it. */
4801 rest_of_type_decl_compilation (tree decl)
4803 /* We need to defer finalizing the type if incomplete types
4804 are being deferred or if they are being processed. */
4805 if (defer_incomplete_level || defer_finalize_level)
4806 VEC_safe_push (tree, heap, defer_finalize_list, decl);
4808 rest_of_type_decl_compilation_no_defer (decl);
4811 /* Same as above but without deferring the compilation. This
4812 function should not be invoked directly on a TYPE_DECL. */
4815 rest_of_type_decl_compilation_no_defer (tree decl)
4817 const int toplev = global_bindings_p ();
4818 tree t = TREE_TYPE (decl);
4820 rest_of_decl_compilation (decl, toplev, 0);
4822 /* Now process all the variants. This is needed for STABS. */
4823 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
4825 if (t == TREE_TYPE (decl))
4828 if (!TYPE_STUB_DECL (t))
4829 TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
4831 rest_of_type_compilation (t, toplev);
4835 /* Finalize any From_With_Type incomplete types. We do this after processing
4836 our compilation unit and after processing its spec, if this is a body. */
4839 finalize_from_with_types (void)
4841 struct incomplete *incp = defer_limited_with;
4842 struct incomplete *next;
4844 defer_limited_with = 0;
4845 for (; incp; incp = next)
4849 if (incp->old_type != 0)
4850 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4851 gnat_to_gnu_type (incp->full_type));
4856 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4857 kind of type (such E_Task_Type) that has a different type which Gigi
4858 uses for its representation. If the type does not have a special type
4859 for its representation, return GNAT_ENTITY. If a type is supposed to
4860 exist, but does not, abort unless annotating types, in which case
4861 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4864 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4866 Entity_Id gnat_equiv = gnat_entity;
4868 if (No (gnat_entity))
4871 switch (Ekind (gnat_entity))
4873 case E_Class_Wide_Subtype:
4874 if (Present (Equivalent_Type (gnat_entity)))
4875 gnat_equiv = Equivalent_Type (gnat_entity);
4878 case E_Access_Protected_Subprogram_Type:
4879 case E_Anonymous_Access_Protected_Subprogram_Type:
4880 gnat_equiv = Equivalent_Type (gnat_entity);
4883 case E_Class_Wide_Type:
4884 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4885 ? Equivalent_Type (gnat_entity)
4886 : Root_Type (gnat_entity));
4890 case E_Task_Subtype:
4891 case E_Protected_Type:
4892 case E_Protected_Subtype:
4893 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4900 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4904 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4905 using MECH as its passing mechanism, to be placed in the parameter
4906 list built for GNAT_SUBPROG. Assume a foreign convention for the
4907 latter if FOREIGN is true. Also set CICO to true if the parameter
4908 must use the copy-in copy-out implementation mechanism.
4910 The returned tree is a PARM_DECL, except for those cases where no
4911 parameter needs to be actually passed to the subprogram; the type
4912 of this "shadow" parameter is then returned instead. */
4915 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
4916 Entity_Id gnat_subprog, bool foreign, bool *cico)
4918 tree gnu_param_name = get_entity_name (gnat_param);
4919 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4920 tree gnu_param_type_alt = NULL_TREE;
4921 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4922 /* The parameter can be indirectly modified if its address is taken. */
4923 bool ro_param = in_param && !Address_Taken (gnat_param);
4924 bool by_return = false, by_component_ptr = false, by_ref = false;
4927 /* Copy-return is used only for the first parameter of a valued procedure.
4928 It's a copy mechanism for which a parameter is never allocated. */
4929 if (mech == By_Copy_Return)
4931 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4936 /* If this is either a foreign function or if the underlying type won't
4937 be passed by reference, strip off possible padding type. */
4938 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4939 && TYPE_IS_PADDING_P (gnu_param_type))
4941 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4943 if (mech == By_Reference
4945 || (!must_pass_by_ref (unpadded_type)
4946 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4947 gnu_param_type = unpadded_type;
4950 /* If this is a read-only parameter, make a variant of the type that is
4951 read-only. ??? However, if this is an unconstrained array, that type
4952 can be very complex, so skip it for now. Likewise for any other
4953 self-referential type. */
4955 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4956 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4957 gnu_param_type = build_qualified_type (gnu_param_type,
4958 (TYPE_QUALS (gnu_param_type)
4959 | TYPE_QUAL_CONST));
4961 /* For foreign conventions, pass arrays as pointers to the element type.
4962 First check for unconstrained array and get the underlying array. */
4963 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4965 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4967 /* VMS descriptors are themselves passed by reference. */
4968 if (mech == By_Short_Descriptor ||
4969 (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
4971 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
4972 Mechanism (gnat_param),
4974 else if (mech == By_Descriptor)
4976 /* Build both a 32-bit and 64-bit descriptor, one of which will be
4977 chosen in fill_vms_descriptor. */
4979 = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
4980 Mechanism (gnat_param),
4983 = build_pointer_type (build_vms_descriptor (gnu_param_type,
4984 Mechanism (gnat_param),
4988 /* Arrays are passed as pointers to element type for foreign conventions. */
4991 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4993 /* Strip off any multi-dimensional entries, then strip
4994 off the last array to get the component type. */
4995 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4996 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4997 gnu_param_type = TREE_TYPE (gnu_param_type);
4999 by_component_ptr = true;
5000 gnu_param_type = TREE_TYPE (gnu_param_type);
5003 gnu_param_type = build_qualified_type (gnu_param_type,
5004 (TYPE_QUALS (gnu_param_type)
5005 | TYPE_QUAL_CONST));
5007 gnu_param_type = build_pointer_type (gnu_param_type);
5010 /* Fat pointers are passed as thin pointers for foreign conventions. */
5011 else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
5013 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
5015 /* If we must pass or were requested to pass by reference, do so.
5016 If we were requested to pass by copy, do so.
5017 Otherwise, for foreign conventions, pass In Out or Out parameters
5018 or aggregates by reference. For COBOL and Fortran, pass all
5019 integer and FP types that way too. For Convention Ada, use
5020 the standard Ada default. */
5021 else if (must_pass_by_ref (gnu_param_type)
5022 || mech == By_Reference
5025 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
5027 && (Convention (gnat_subprog) == Convention_Fortran
5028 || Convention (gnat_subprog) == Convention_COBOL)
5029 && (INTEGRAL_TYPE_P (gnu_param_type)
5030 || FLOAT_TYPE_P (gnu_param_type)))
5032 && default_pass_by_ref (gnu_param_type)))))
5034 gnu_param_type = build_reference_type (gnu_param_type);
5038 /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
5042 if (mech == By_Copy && (by_ref || by_component_ptr))
5043 post_error ("?cannot pass & by copy", gnat_param);
5045 /* If this is an Out parameter that isn't passed by reference and isn't
5046 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
5047 it will be a VAR_DECL created when we process the procedure, so just
5048 return its type. For the special parameter of a valued procedure,
5051 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
5052 Out parameters with discriminants or implicit initial values to be
5053 handled like In Out parameters. These type are normally built as
5054 aggregates, hence passed by reference, except for some packed arrays
5055 which end up encoded in special integer types.
5057 The exception we need to make is then for packed arrays of records
5058 with discriminants or implicit initial values. We have no light/easy
5059 way to check for the latter case, so we merely check for packed arrays
5060 of records. This may lead to useless copy-in operations, but in very
5061 rare cases only, as these would be exceptions in a set of already
5062 exceptional situations. */
5063 if (Ekind (gnat_param) == E_Out_Parameter
5066 || (mech != By_Descriptor
5067 && mech != By_Short_Descriptor
5068 && !POINTER_TYPE_P (gnu_param_type)
5069 && !AGGREGATE_TYPE_P (gnu_param_type)))
5070 && !(Is_Array_Type (Etype (gnat_param))
5071 && Is_Packed (Etype (gnat_param))
5072 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
5073 return gnu_param_type;
5075 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
5076 ro_param || by_ref || by_component_ptr);
5077 DECL_BY_REF_P (gnu_param) = by_ref;
5078 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
5079 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
5080 mech == By_Short_Descriptor);
5081 DECL_POINTS_TO_READONLY_P (gnu_param)
5082 = (ro_param && (by_ref || by_component_ptr));
5084 /* Save the alternate descriptor type, if any. */
5085 if (gnu_param_type_alt)
5086 SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt);
5088 /* If no Mechanism was specified, indicate what we're using, then
5089 back-annotate it. */
5090 if (mech == Default)
5091 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
5093 Set_Mechanism (gnat_param, mech);
5097 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
5100 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
5102 while (Present (Corresponding_Discriminant (discr1)))
5103 discr1 = Corresponding_Discriminant (discr1);
5105 while (Present (Corresponding_Discriminant (discr2)))
5106 discr2 = Corresponding_Discriminant (discr2);
5109 Original_Record_Component (discr1) == Original_Record_Component (discr2);
5112 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
5113 a non-aliased component in the back-end sense. */
5116 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
5118 /* If the type below this is a multi-array type, then
5119 this does not have aliased components. */
5120 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
5121 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
5124 if (Has_Aliased_Components (gnat_type))
5127 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
5130 /* Return true if GNAT_ADDRESS is a value known at compile-time. */
5133 compile_time_known_address_p (Node_Id gnat_address)
5135 /* Catch System'To_Address. */
5136 if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
5137 gnat_address = Expression (gnat_address);
5139 return Compile_Time_Known_Value (gnat_address);
5142 /* Given GNAT_ENTITY, elaborate all expressions that are required to
5143 be elaborated at the point of its definition, but do nothing else. */
5146 elaborate_entity (Entity_Id gnat_entity)
5148 switch (Ekind (gnat_entity))
5150 case E_Signed_Integer_Subtype:
5151 case E_Modular_Integer_Subtype:
5152 case E_Enumeration_Subtype:
5153 case E_Ordinary_Fixed_Point_Subtype:
5154 case E_Decimal_Fixed_Point_Subtype:
5155 case E_Floating_Point_Subtype:
5157 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
5158 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
5160 /* ??? Tests for avoiding static constraint error expression
5161 is needed until the front stops generating bogus conversions
5162 on bounds of real types. */
5164 if (!Raises_Constraint_Error (gnat_lb))
5165 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
5166 1, 0, Needs_Debug_Info (gnat_entity));
5167 if (!Raises_Constraint_Error (gnat_hb))
5168 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
5169 1, 0, Needs_Debug_Info (gnat_entity));
5175 Node_Id full_definition = Declaration_Node (gnat_entity);
5176 Node_Id record_definition = Type_Definition (full_definition);
5178 /* If this is a record extension, go a level further to find the
5179 record definition. */
5180 if (Nkind (record_definition) == N_Derived_Type_Definition)
5181 record_definition = Record_Extension_Part (record_definition);
5185 case E_Record_Subtype:
5186 case E_Private_Subtype:
5187 case E_Limited_Private_Subtype:
5188 case E_Record_Subtype_With_Private:
5189 if (Is_Constrained (gnat_entity)
5190 && Has_Discriminants (Base_Type (gnat_entity))
5191 && Present (Discriminant_Constraint (gnat_entity)))
5193 Node_Id gnat_discriminant_expr;
5194 Entity_Id gnat_field;
5196 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
5197 gnat_discriminant_expr
5198 = First_Elmt (Discriminant_Constraint (gnat_entity));
5199 Present (gnat_field);
5200 gnat_field = Next_Discriminant (gnat_field),
5201 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
5202 /* ??? For now, ignore access discriminants. */
5203 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
5204 elaborate_expression (Node (gnat_discriminant_expr),
5206 get_entity_name (gnat_field), 1, 0, 0);
5213 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
5214 any entities on its entity chain similarly. */
5217 mark_out_of_scope (Entity_Id gnat_entity)
5219 Entity_Id gnat_sub_entity;
5220 unsigned int kind = Ekind (gnat_entity);
5222 /* If this has an entity list, process all in the list. */
5223 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
5224 || IN (kind, Private_Kind)
5225 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
5226 || kind == E_Function || kind == E_Generic_Function
5227 || kind == E_Generic_Package || kind == E_Generic_Procedure
5228 || kind == E_Loop || kind == E_Operator || kind == E_Package
5229 || kind == E_Package_Body || kind == E_Procedure
5230 || kind == E_Record_Type || kind == E_Record_Subtype
5231 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
5232 for (gnat_sub_entity = First_Entity (gnat_entity);
5233 Present (gnat_sub_entity);
5234 gnat_sub_entity = Next_Entity (gnat_sub_entity))
5235 if (Scope (gnat_sub_entity) == gnat_entity
5236 && gnat_sub_entity != gnat_entity)
5237 mark_out_of_scope (gnat_sub_entity);
5239 /* Now clear this if it has been defined, but only do so if it isn't
5240 a subprogram or parameter. We could refine this, but it isn't
5241 worth it. If this is statically allocated, it is supposed to
5242 hang around out of cope. */
5243 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
5244 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
5246 save_gnu_tree (gnat_entity, NULL_TREE, true);
5247 save_gnu_tree (gnat_entity, error_mark_node, true);
5251 /* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP.
5252 If this is a multi-dimensional array type, do this recursively.
5255 - ALIAS_SET_COPY: the new set is made a copy of the old one.
5256 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one.
5257 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */
5260 relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op)
5262 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
5263 of a one-dimensional array, since the padding has the same alias set
5264 as the field type, but if it's a multi-dimensional array, we need to
5265 see the inner types. */
5266 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
5267 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
5268 || TYPE_IS_PADDING_P (gnu_old_type)))
5269 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
5271 /* Unconstrained array types are deemed incomplete and would thus be given
5272 alias set 0. Retrieve the underlying array type. */
5273 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
5275 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
5276 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE)
5278 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type))));
5280 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
5281 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
5282 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
5283 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op);
5287 case ALIAS_SET_COPY:
5288 /* The alias set shouldn't be copied between array types with different
5289 aliasing settings because this can break the aliasing relationship
5290 between the array type and its element type. */
5291 #ifndef ENABLE_CHECKING
5292 if (flag_strict_aliasing)
5294 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE
5295 && TREE_CODE (gnu_old_type) == ARRAY_TYPE
5296 && TYPE_NONALIASED_COMPONENT (gnu_new_type)
5297 != TYPE_NONALIASED_COMPONENT (gnu_old_type)));
5299 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
5302 case ALIAS_SET_SUBSET:
5303 case ALIAS_SET_SUPERSET:
5305 alias_set_type old_set = get_alias_set (gnu_old_type);
5306 alias_set_type new_set = get_alias_set (gnu_new_type);
5308 /* Do nothing if the alias sets conflict. This ensures that we
5309 never call record_alias_subset several times for the same pair
5310 or at all for alias set 0. */
5311 if (!alias_sets_conflict_p (old_set, new_set))
5313 if (op == ALIAS_SET_SUBSET)
5314 record_alias_subset (old_set, new_set);
5316 record_alias_subset (new_set, old_set);
5325 record_component_aliases (gnu_new_type);
5328 /* Return a TREE_LIST describing the substitutions needed to reflect
5329 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
5330 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
5331 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
5332 gives the tree for the discriminant and TREE_VALUES is the replacement
5333 value. They are in the form of operands to substitute_in_expr.
5334 DEFINITION is as in gnat_to_gnu_entity. */
5337 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
5338 tree gnu_list, bool definition)
5340 Entity_Id gnat_discrim;
5344 gnat_type = Implementation_Base_Type (gnat_subtype);
5346 if (Has_Discriminants (gnat_type))
5347 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
5348 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
5349 Present (gnat_discrim);
5350 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
5351 gnat_value = Next_Elmt (gnat_value))
5352 /* Ignore access discriminants. */
5353 if (!Is_Access_Type (Etype (Node (gnat_value))))
5354 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
5355 elaborate_expression
5356 (Node (gnat_value), gnat_subtype,
5357 get_entity_name (gnat_discrim), definition,
5364 /* Return true if the size represented by GNU_SIZE can be handled by an
5365 allocation. If STATIC_P is true, consider only what can be done with a
5366 static allocation. */
5369 allocatable_size_p (tree gnu_size, bool static_p)
5371 HOST_WIDE_INT our_size;
5373 /* If this is not a static allocation, the only case we want to forbid
5374 is an overflowing size. That will be converted into a raise a
5377 return !(TREE_CODE (gnu_size) == INTEGER_CST
5378 && TREE_OVERFLOW (gnu_size));
5380 /* Otherwise, we need to deal with both variable sizes and constant
5381 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
5382 since assemblers may not like very large sizes. */
5383 if (!host_integerp (gnu_size, 1))
5386 our_size = tree_low_cst (gnu_size, 1);
5387 return (int) our_size == our_size;
5390 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
5391 NAME, ARGS and ERROR_POINT. */
5394 prepend_one_attribute_to (struct attrib ** attr_list,
5395 enum attr_type attr_type,
5398 Node_Id attr_error_point)
5400 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
5402 attr->type = attr_type;
5403 attr->name = attr_name;
5404 attr->args = attr_args;
5405 attr->error_point = attr_error_point;
5407 attr->next = *attr_list;
5411 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
5414 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
5418 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
5419 gnat_temp = Next_Rep_Item (gnat_temp))
5420 if (Nkind (gnat_temp) == N_Pragma)
5422 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
5423 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
5424 enum attr_type etype;
5426 if (Present (gnat_assoc) && Present (First (gnat_assoc))
5427 && Present (Next (First (gnat_assoc)))
5428 && (Nkind (Expression (Next (First (gnat_assoc))))
5429 == N_String_Literal))
5431 gnu_arg0 = get_identifier (TREE_STRING_POINTER
5434 (First (gnat_assoc))))));
5435 if (Present (Next (Next (First (gnat_assoc))))
5436 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
5437 == N_String_Literal))
5438 gnu_arg1 = get_identifier (TREE_STRING_POINTER
5442 (First (gnat_assoc)))))));
5445 switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
5447 case Pragma_Machine_Attribute:
5448 etype = ATTR_MACHINE_ATTRIBUTE;
5451 case Pragma_Linker_Alias:
5452 etype = ATTR_LINK_ALIAS;
5455 case Pragma_Linker_Section:
5456 etype = ATTR_LINK_SECTION;
5459 case Pragma_Linker_Constructor:
5460 etype = ATTR_LINK_CONSTRUCTOR;
5463 case Pragma_Linker_Destructor:
5464 etype = ATTR_LINK_DESTRUCTOR;
5467 case Pragma_Weak_External:
5468 etype = ATTR_WEAK_EXTERNAL;
5471 case Pragma_Thread_Local_Storage:
5472 etype = ATTR_THREAD_LOCAL_STORAGE;
5480 /* Prepend to the list now. Make a list of the argument we might
5481 have, as GCC expects it. */
5482 prepend_one_attribute_to
5485 (gnu_arg1 != NULL_TREE)
5486 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
5487 Present (Next (First (gnat_assoc)))
5488 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
5492 /* Called when we need to protect a variable object using a save_expr. */
5495 maybe_variable (tree gnu_operand)
5497 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
5498 || TREE_CODE (gnu_operand) == SAVE_EXPR
5499 || TREE_CODE (gnu_operand) == NULL_EXPR)
5502 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
5504 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
5505 TREE_TYPE (gnu_operand),
5506 variable_size (TREE_OPERAND (gnu_operand, 0)));
5508 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
5509 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
5513 return variable_size (gnu_operand);
5516 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
5517 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
5518 return the GCC tree to use for that expression. GNU_NAME is the
5519 qualification to use if an external name is appropriate and DEFINITION is
5520 true if this is a definition of GNAT_ENTITY. If NEED_VALUE is true, we
5521 need a result. Otherwise, we are just elaborating this for side-effects.
5522 If NEED_DEBUG is true we need the symbol for debugging purposes even if it
5523 isn't needed for code generation. */
5526 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
5527 tree gnu_name, bool definition, bool need_value,
5532 /* If we already elaborated this expression (e.g., it was involved
5533 in the definition of a private type), use the old value. */
5534 if (present_gnu_tree (gnat_expr))
5535 return get_gnu_tree (gnat_expr);
5537 /* If we don't need a value and this is static or a discriminant, we
5538 don't need to do anything. */
5539 else if (!need_value
5540 && (Is_OK_Static_Expression (gnat_expr)
5541 || (Nkind (gnat_expr) == N_Identifier
5542 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5545 /* Otherwise, convert this tree to its GCC equivalent. */
5547 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5548 gnu_name, definition, need_debug);
5550 /* Save the expression in case we try to elaborate this entity again. Since
5551 it's not a DECL, don't check it. Don't save if it's a discriminant. */
5552 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5553 save_gnu_tree (gnat_expr, gnu_expr, true);
5555 return need_value ? gnu_expr : error_mark_node;
5558 /* Similar, but take a GNU expression. */
5561 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5562 tree gnu_expr, tree gnu_name, bool definition,
5565 tree gnu_decl = NULL_TREE;
5566 /* Skip any conversions and simple arithmetics to see if the expression
5567 is a read-only variable.
5568 ??? This really should remain read-only, but we have to think about
5569 the typing of the tree here. */
5571 = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
5572 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5575 /* In most cases, we won't see a naked FIELD_DECL here because a
5576 discriminant reference will have been replaced with a COMPONENT_REF
5577 when the type is being elaborated. However, there are some cases
5578 involving child types where we will. So convert it to a COMPONENT_REF
5579 here. We have to hope it will be at the highest level of the
5580 expression in these cases. */
5581 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5582 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5583 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5584 gnu_expr, NULL_TREE);
5586 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5587 that is read-only, make a variable that is initialized to contain the
5588 bound when the package containing the definition is elaborated. If
5589 this entity is defined at top level and a bound or discriminant value
5590 isn't a constant or a reference to a discriminant, replace the bound
5591 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5592 rely here on the fact that an expression cannot contain both the
5593 discriminant and some other variable. */
5595 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5596 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5597 && (TREE_READONLY (gnu_inner_expr)
5598 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5599 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5601 /* If this is a static expression or contains a discriminant, we don't
5602 need the variable for debugging (and can't elaborate anyway if a
5605 && (Is_OK_Static_Expression (gnat_expr)
5606 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5609 /* Now create the variable if we need it. */
5610 if (need_debug || (expr_variable && expr_global))
5612 = create_var_decl (create_concat_name (gnat_entity,
5613 IDENTIFIER_POINTER (gnu_name)),
5614 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5615 !need_debug, Is_Public (gnat_entity),
5616 !definition, false, NULL, gnat_entity);
5618 /* We only need to use this variable if we are in global context since GCC
5619 can do the right thing in the local case. */
5620 if (expr_global && expr_variable)
5622 else if (!expr_variable)
5625 return maybe_variable (gnu_expr);
5628 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5629 starting bit position so that it is aligned to ALIGN bits, and leaving at
5630 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5631 record is guaranteed to get. */
5634 make_aligning_type (tree type, unsigned int align, tree size,
5635 unsigned int base_align, int room)
5637 /* We will be crafting a record type with one field at a position set to be
5638 the next multiple of ALIGN past record'address + room bytes. We use a
5639 record placeholder to express record'address. */
5641 tree record_type = make_node (RECORD_TYPE);
5642 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5645 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5647 /* The diagram below summarizes the shape of what we manipulate:
5649 <--------- pos ---------->
5650 { +------------+-------------+-----------------+
5651 record =>{ |############| ... | field (type) |
5652 { +------------+-------------+-----------------+
5653 |<-- room -->|<- voffset ->|<---- size ----->|
5656 record_addr vblock_addr
5658 Every length is in sizetype bytes there, except "pos" which has to be
5659 set as a bit position in the GCC tree for the record. */
5661 tree room_st = size_int (room);
5662 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5663 tree voffset_st, pos, field;
5665 tree name = TYPE_NAME (type);
5667 if (TREE_CODE (name) == TYPE_DECL)
5668 name = DECL_NAME (name);
5670 TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
5672 /* Compute VOFFSET and then POS. The next byte position multiple of some
5673 alignment after some address is obtained by "and"ing the alignment minus
5674 1 with the two's complement of the address. */
5676 voffset_st = size_binop (BIT_AND_EXPR,
5677 size_diffop (size_zero_node, vblock_addr_st),
5678 ssize_int ((align / BITS_PER_UNIT) - 1));
5680 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5682 pos = size_binop (MULT_EXPR,
5683 convert (bitsizetype,
5684 size_binop (PLUS_EXPR, room_st, voffset_st)),
5687 /* Craft the GCC record representation. We exceptionally do everything
5688 manually here because 1) our generic circuitry is not quite ready to
5689 handle the complex position/size expressions we are setting up, 2) we
5690 have a strong simplifying factor at hand: we know the maximum possible
5691 value of voffset, and 3) we have to set/reset at least the sizes in
5692 accordance with this maximum value anyway, as we need them to convey
5693 what should be "alloc"ated for this type.
5695 Use -1 as the 'addressable' indication for the field to prevent the
5696 creation of a bitfield. We don't need one, it would have damaging
5697 consequences on the alignment computation, and create_field_decl would
5698 make one without this special argument, for instance because of the
5699 complex position expression. */
5701 field = create_field_decl (get_identifier ("F"), type, record_type,
5703 TYPE_FIELDS (record_type) = field;
5705 TYPE_ALIGN (record_type) = base_align;
5706 TYPE_USER_ALIGN (record_type) = 1;
5708 TYPE_SIZE (record_type)
5709 = size_binop (PLUS_EXPR,
5710 size_binop (MULT_EXPR, convert (bitsizetype, size),
5712 bitsize_int (align + room * BITS_PER_UNIT));
5713 TYPE_SIZE_UNIT (record_type)
5714 = size_binop (PLUS_EXPR, size,
5715 size_int (room + align / BITS_PER_UNIT));
5717 SET_TYPE_MODE (record_type, BLKmode);
5719 relate_alias_sets (record_type, type, ALIAS_SET_COPY);
5723 /* Return the result of rounding T up to ALIGN. */
5725 static inline unsigned HOST_WIDE_INT
5726 round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
5734 /* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
5735 as the field type of a packed record if IN_RECORD is true, or as the
5736 component type of a packed array if IN_RECORD is false. See if we can
5737 rewrite it either as a type that has a non-BLKmode, which we can pack
5738 tighter in the packed record case, or as a smaller type. If so, return
5739 the new type. If not, return the original type. */
5742 make_packable_type (tree type, bool in_record)
5744 unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
5745 unsigned HOST_WIDE_INT new_size;
5746 tree new_type, old_field, field_list = NULL_TREE;
5748 /* No point in doing anything if the size is zero. */
5752 new_type = make_node (TREE_CODE (type));
5754 /* Copy the name and flags from the old type to that of the new.
5755 Note that we rely on the pointer equality created here for
5756 TYPE_NAME to look through conversions in various places. */
5757 TYPE_NAME (new_type) = TYPE_NAME (type);
5758 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
5759 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5760 if (TREE_CODE (type) == RECORD_TYPE)
5761 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5763 /* If we are in a record and have a small size, set the alignment to
5764 try for an integral mode. Otherwise set it to try for a smaller
5765 type with BLKmode. */
5766 if (in_record && size <= MAX_FIXED_MODE_SIZE)
5768 TYPE_ALIGN (new_type) = ceil_alignment (size);
5769 new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
5773 unsigned HOST_WIDE_INT align;
5775 /* Do not try to shrink the size if the RM size is not constant. */
5776 if (TYPE_CONTAINS_TEMPLATE_P (type)
5777 || !host_integerp (TYPE_ADA_SIZE (type), 1))
5780 /* Round the RM size up to a unit boundary to get the minimal size
5781 for a BLKmode record. Give up if it's already the size. */
5782 new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
5783 new_size = round_up_to_align (new_size, BITS_PER_UNIT);
5784 if (new_size == size)
5787 align = new_size & -new_size;
5788 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
5791 TYPE_USER_ALIGN (new_type) = 1;
5793 /* Now copy the fields, keeping the position and size as we don't want
5794 to change the layout by propagating the packedness downwards. */
5795 for (old_field = TYPE_FIELDS (type); old_field;
5796 old_field = TREE_CHAIN (old_field))
5798 tree new_field_type = TREE_TYPE (old_field);
5799 tree new_field, new_size;
5801 if ((TREE_CODE (new_field_type) == RECORD_TYPE
5802 || TREE_CODE (new_field_type) == UNION_TYPE
5803 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5804 && !TYPE_IS_FAT_POINTER_P (new_field_type)
5805 && host_integerp (TYPE_SIZE (new_field_type), 1))
5806 new_field_type = make_packable_type (new_field_type, true);
5808 /* However, for the last field in a not already packed record type
5809 that is of an aggregate type, we need to use the RM size in the
5810 packable version of the record type, see finish_record_type. */
5811 if (!TREE_CHAIN (old_field)
5812 && !TYPE_PACKED (type)
5813 && (TREE_CODE (new_field_type) == RECORD_TYPE
5814 || TREE_CODE (new_field_type) == UNION_TYPE
5815 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5816 && !TYPE_IS_FAT_POINTER_P (new_field_type)
5817 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
5818 && TYPE_ADA_SIZE (new_field_type))
5819 new_size = TYPE_ADA_SIZE (new_field_type);
5821 new_size = DECL_SIZE (old_field);
5823 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5824 new_type, TYPE_PACKED (type), new_size,
5825 bit_position (old_field),
5826 !DECL_NONADDRESSABLE_P (old_field));
5828 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5829 SET_DECL_ORIGINAL_FIELD
5830 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5831 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5833 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5834 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5836 TREE_CHAIN (new_field) = field_list;
5837 field_list = new_field;
5840 finish_record_type (new_type, nreverse (field_list), 2, true);
5841 relate_alias_sets (new_type, type, ALIAS_SET_COPY);
5843 /* If this is a padding record, we never want to make the size smaller
5844 than what was specified. For QUAL_UNION_TYPE, also copy the size. */
5845 if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5846 || TREE_CODE (type) == QUAL_UNION_TYPE)
5848 TYPE_SIZE (new_type) = TYPE_SIZE (type);
5849 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5853 TYPE_SIZE (new_type) = bitsize_int (new_size);
5854 TYPE_SIZE_UNIT (new_type)
5855 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
5858 if (!TYPE_CONTAINS_TEMPLATE_P (type))
5859 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
5861 compute_record_mode (new_type);
5863 /* Try harder to get a packable type if necessary, for example
5864 in case the record itself contains a BLKmode field. */
5865 if (in_record && TYPE_MODE (new_type) == BLKmode)
5866 SET_TYPE_MODE (new_type,
5867 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
5869 /* If neither the mode nor the size has shrunk, return the old type. */
5870 if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
5876 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5877 if needed. We have already verified that SIZE and TYPE are large enough.
5879 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5882 IS_USER_TYPE is true if we must complete the original type.
5884 DEFINITION is true if this type is being defined.
5886 SAME_RM_SIZE is true if the RM size of the resulting type is to be set
5887 to SIZE too; otherwise, it's set to the RM size of the original type. */
5890 maybe_pad_type (tree type, tree size, unsigned int align,
5891 Entity_Id gnat_entity, const char *name_trailer,
5892 bool is_user_type, bool definition, bool same_rm_size)
5894 tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
5895 tree orig_size = TYPE_SIZE (type);
5896 unsigned int orig_align = align;
5899 /* If TYPE is a padded type, see if it agrees with any size and alignment
5900 we were given. If so, return the original type. Otherwise, strip
5901 off the padding, since we will either be returning the inner type
5902 or repadding it. If no size or alignment is specified, use that of
5903 the original padded type. */
5904 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5907 || operand_equal_p (round_up (size,
5908 MAX (align, TYPE_ALIGN (type))),
5909 round_up (TYPE_SIZE (type),
5910 MAX (align, TYPE_ALIGN (type))),
5912 && (align == 0 || align == TYPE_ALIGN (type)))
5916 size = TYPE_SIZE (type);
5918 align = TYPE_ALIGN (type);
5920 type = TREE_TYPE (TYPE_FIELDS (type));
5921 orig_size = TYPE_SIZE (type);
5924 /* If the size is either not being changed or is being made smaller (which
5925 is not done here (and is only valid for bitfields anyway), show the size
5926 isn't changing. Likewise, clear the alignment if it isn't being
5927 changed. Then return if we aren't doing anything. */
5929 && (operand_equal_p (size, orig_size, 0)
5930 || (TREE_CODE (orig_size) == INTEGER_CST
5931 && tree_int_cst_lt (size, orig_size))))
5934 if (align == TYPE_ALIGN (type))
5937 if (align == 0 && !size)
5940 /* If requested, complete the original type and give it a name. */
5942 create_type_decl (get_entity_name (gnat_entity), type,
5943 NULL, !Comes_From_Source (gnat_entity),
5945 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5946 && DECL_IGNORED_P (TYPE_NAME (type))),
5949 /* We used to modify the record in place in some cases, but that could
5950 generate incorrect debugging information. So make a new record
5952 record = make_node (RECORD_TYPE);
5953 TYPE_IS_PADDING_P (record) = 1;
5955 if (Present (gnat_entity))
5956 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5958 TYPE_VOLATILE (record)
5959 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5961 TYPE_ALIGN (record) = align;
5963 TYPE_USER_ALIGN (record) = align;
5965 TYPE_SIZE (record) = size ? size : orig_size;
5966 TYPE_SIZE_UNIT (record)
5967 = convert (sizetype,
5968 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
5969 bitsize_unit_node));
5971 /* If we are changing the alignment and the input type is a record with
5972 BLKmode and a small constant size, try to make a form that has an
5973 integral mode. This might allow the padding record to also have an
5974 integral mode, which will be much more efficient. There is no point
5975 in doing so if a size is specified unless it is also a small constant
5976 size and it is incorrect to do so if we cannot guarantee that the mode
5977 will be naturally aligned since the field must always be addressable.
5979 ??? This might not always be a win when done for a stand-alone object:
5980 since the nominal and the effective type of the object will now have
5981 different modes, a VIEW_CONVERT_EXPR will be required for converting
5982 between them and it might be hard to overcome afterwards, including
5983 at the RTL level when the stand-alone object is accessed as a whole. */
5985 && TREE_CODE (type) == RECORD_TYPE
5986 && TYPE_MODE (type) == BLKmode
5987 && TREE_CODE (orig_size) == INTEGER_CST
5988 && !TREE_OVERFLOW (orig_size)
5989 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
5991 || (TREE_CODE (size) == INTEGER_CST
5992 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
5994 tree packable_type = make_packable_type (type, true);
5995 if (TYPE_MODE (packable_type) != BLKmode
5996 && align >= TYPE_ALIGN (packable_type))
5997 type = packable_type;
6000 /* Now create the field with the original size. */
6001 field = create_field_decl (get_identifier ("F"), type, record, 0,
6002 orig_size, bitsize_zero_node, 1);
6003 DECL_INTERNAL_P (field) = 1;
6005 /* Do not finalize it until after the auxiliary record is built. */
6006 finish_record_type (record, field, 1, true);
6008 /* Set the same size for its RM size if requested; otherwise reuse
6009 the RM size of the original type. */
6010 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
6012 /* Unless debugging information isn't being written for the input type,
6013 write a record that shows what we are a subtype of and also make a
6014 variable that indicates our size, if still variable. */
6015 if (TYPE_NAME (record)
6016 && AGGREGATE_TYPE_P (type)
6017 && TREE_CODE (orig_size) != INTEGER_CST
6018 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
6019 && DECL_IGNORED_P (TYPE_NAME (type))))
6021 tree marker = make_node (RECORD_TYPE);
6022 tree name = TYPE_NAME (record);
6023 tree orig_name = TYPE_NAME (type);
6025 if (TREE_CODE (name) == TYPE_DECL)
6026 name = DECL_NAME (name);
6028 if (TREE_CODE (orig_name) == TYPE_DECL)
6029 orig_name = DECL_NAME (orig_name);
6031 TYPE_NAME (marker) = concat_name (name, "XVS");
6032 finish_record_type (marker,
6033 create_field_decl (orig_name, integer_type_node,
6034 marker, 0, NULL_TREE, NULL_TREE,
6038 add_parallel_type (TYPE_STUB_DECL (record), marker);
6040 if (size && TREE_CODE (size) != INTEGER_CST && definition)
6041 create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
6042 TYPE_SIZE_UNIT (record), false, false, false,
6043 false, NULL, gnat_entity);
6046 rest_of_record_type_compilation (record);
6048 /* If the size was widened explicitly, maybe give a warning. Take the
6049 original size as the maximum size of the input if there was an
6050 unconstrained record involved and round it up to the specified alignment,
6051 if one was specified. */
6052 if (CONTAINS_PLACEHOLDER_P (orig_size))
6053 orig_size = max_size (orig_size, true);
6056 orig_size = round_up (orig_size, align);
6058 if (size && Present (gnat_entity)
6059 && !operand_equal_p (size, orig_size, 0)
6060 && !(TREE_CODE (size) == INTEGER_CST
6061 && TREE_CODE (orig_size) == INTEGER_CST
6062 && tree_int_cst_lt (size, orig_size)))
6064 Node_Id gnat_error_node = Empty;
6066 if (Is_Packed_Array_Type (gnat_entity))
6067 gnat_entity = Original_Array_Type (gnat_entity);
6069 if ((Ekind (gnat_entity) == E_Component
6070 || Ekind (gnat_entity) == E_Discriminant)
6071 && Present (Component_Clause (gnat_entity)))
6072 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
6073 else if (Present (Size_Clause (gnat_entity)))
6074 gnat_error_node = Expression (Size_Clause (gnat_entity));
6076 /* Generate message only for entities that come from source, since
6077 if we have an entity created by expansion, the message will be
6078 generated for some other corresponding source entity. */
6079 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
6080 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
6082 size_diffop (size, orig_size));
6084 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
6085 post_error_ne_tree ("component of& padded{ by ^ bits}?",
6086 gnat_entity, gnat_entity,
6087 size_diffop (size, orig_size));
6093 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
6094 the value passed against the list of choices. */
6097 choices_to_gnu (tree operand, Node_Id choices)
6101 tree result = integer_zero_node;
6102 tree this_test, low = 0, high = 0, single = 0;
6104 for (choice = First (choices); Present (choice); choice = Next (choice))
6106 switch (Nkind (choice))
6109 low = gnat_to_gnu (Low_Bound (choice));
6110 high = gnat_to_gnu (High_Bound (choice));
6112 /* There's no good type to use here, so we might as well use
6113 integer_type_node. */
6115 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6116 build_binary_op (GE_EXPR, integer_type_node,
6118 build_binary_op (LE_EXPR, integer_type_node,
6123 case N_Subtype_Indication:
6124 gnat_temp = Range_Expression (Constraint (choice));
6125 low = gnat_to_gnu (Low_Bound (gnat_temp));
6126 high = gnat_to_gnu (High_Bound (gnat_temp));
6129 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6130 build_binary_op (GE_EXPR, integer_type_node,
6132 build_binary_op (LE_EXPR, integer_type_node,
6137 case N_Expanded_Name:
6138 /* This represents either a subtype range, an enumeration
6139 literal, or a constant Ekind says which. If an enumeration
6140 literal or constant, fall through to the next case. */
6141 if (Ekind (Entity (choice)) != E_Enumeration_Literal
6142 && Ekind (Entity (choice)) != E_Constant)
6144 tree type = gnat_to_gnu_type (Entity (choice));
6146 low = TYPE_MIN_VALUE (type);
6147 high = TYPE_MAX_VALUE (type);
6150 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
6151 build_binary_op (GE_EXPR, integer_type_node,
6153 build_binary_op (LE_EXPR, integer_type_node,
6158 /* ... fall through ... */
6160 case N_Character_Literal:
6161 case N_Integer_Literal:
6162 single = gnat_to_gnu (choice);
6163 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
6167 case N_Others_Choice:
6168 this_test = integer_one_node;
6175 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
6182 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
6183 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
6186 adjust_packed (tree field_type, tree record_type, int packed)
6188 /* If the field contains an item of variable size, we cannot pack it
6189 because we cannot create temporaries of non-fixed size in case
6190 we need to take the address of the field. See addressable_p and
6191 the notes on the addressability issues for further details. */
6192 if (is_variable_size (field_type))
6195 /* If the alignment of the record is specified and the field type
6196 is over-aligned, request Storage_Unit alignment for the field. */
6199 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
6208 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
6209 placed in GNU_RECORD_TYPE.
6211 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
6212 record has Component_Alignment of Storage_Unit, -2 if the enclosing
6213 record has a specified alignment.
6215 DEFINITION is true if this field is for a record being defined. */
6218 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
6221 tree gnu_field_id = get_entity_name (gnat_field);
6222 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
6223 tree gnu_field, gnu_size, gnu_pos;
6224 bool needs_strict_alignment
6225 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
6226 || Treat_As_Volatile (gnat_field));
6228 /* If this field requires strict alignment, we cannot pack it because
6229 it would very likely be under-aligned in the record. */
6230 if (needs_strict_alignment)
6233 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
6235 /* If a size is specified, use it. Otherwise, if the record type is packed,
6236 use the official RM size. See "Handling of Type'Size Values" in Einfo
6237 for further details. */
6238 if (Known_Static_Esize (gnat_field))
6239 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6240 gnat_field, FIELD_DECL, false, true);
6241 else if (packed == 1)
6242 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
6243 gnat_field, FIELD_DECL, false, true);
6245 gnu_size = NULL_TREE;
6247 /* If we have a specified size that's smaller than that of the field type,
6248 or a position is specified, and the field type is a record, see if we can
6249 get either an integral mode form of the type or a smaller form. If we
6250 can, show a size was specified for the field if there wasn't one already,
6251 so we know to make this a bitfield and avoid making things wider.
6253 Doing this is first useful if the record is packed because we may then
6254 place the field at a non-byte-aligned position and so achieve tighter
6257 This is in addition *required* if the field shares a byte with another
6258 field and the front-end lets the back-end handle the references, because
6259 GCC does not handle BLKmode bitfields properly.
6261 We avoid the transformation if it is not required or potentially useful,
6262 as it might entail an increase of the field's alignment and have ripple
6263 effects on the outer record type. A typical case is a field known to be
6264 byte aligned and not to share a byte with another field.
6266 Besides, we don't even look the possibility of a transformation in cases
6267 known to be in error already, for instance when an invalid size results
6268 from a component clause. */
6270 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6271 && !TYPE_IS_FAT_POINTER_P (gnu_field_type)
6272 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
6275 && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
6276 || Present (Component_Clause (gnat_field))))))
6278 /* See what the alternate type and size would be. */
6279 tree gnu_packable_type = make_packable_type (gnu_field_type, true);
6281 bool has_byte_aligned_clause
6282 = Present (Component_Clause (gnat_field))
6283 && (UI_To_Int (Component_Bit_Offset (gnat_field))
6284 % BITS_PER_UNIT == 0);
6286 /* Compute whether we should avoid the substitution. */
6288 /* There is no point substituting if there is no change... */
6289 = (gnu_packable_type == gnu_field_type)
6290 /* ... nor when the field is known to be byte aligned and not to
6291 share a byte with another field. */
6292 || (has_byte_aligned_clause
6293 && value_factor_p (gnu_size, BITS_PER_UNIT))
6294 /* The size of an aliased field must be an exact multiple of the
6295 type's alignment, which the substitution might increase. Reject
6296 substitutions that would so invalidate a component clause when the
6297 specified position is byte aligned, as the change would have no
6298 real benefit from the packing standpoint anyway. */
6299 || (Is_Aliased (gnat_field)
6300 && has_byte_aligned_clause
6301 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
6303 /* Substitute unless told otherwise. */
6306 gnu_field_type = gnu_packable_type;
6309 gnu_size = rm_size (gnu_field_type);
6313 /* If we are packing the record and the field is BLKmode, round the
6314 size up to a byte boundary. */
6315 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
6316 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
6318 if (Present (Component_Clause (gnat_field)))
6320 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
6321 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
6322 gnat_field, FIELD_DECL, false, true);
6324 /* Ensure the position does not overlap with the parent subtype,
6326 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
6329 = gnat_to_gnu_type (Parent_Subtype
6330 (Underlying_Type (Scope (gnat_field))));
6332 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
6333 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
6336 ("offset of& must be beyond parent{, minimum allowed is ^}",
6337 First_Bit (Component_Clause (gnat_field)), gnat_field,
6338 TYPE_SIZE_UNIT (gnu_parent));
6342 /* If this field needs strict alignment, ensure the record is
6343 sufficiently aligned and that that position and size are
6344 consistent with the alignment. */
6345 if (needs_strict_alignment)
6347 TYPE_ALIGN (gnu_record_type)
6348 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
6351 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
6353 if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
6355 ("atomic field& must be natural size of type{ (^)}",
6356 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6357 TYPE_SIZE (gnu_field_type));
6359 else if (Is_Aliased (gnat_field))
6361 ("size of aliased field& must be ^ bits",
6362 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6363 TYPE_SIZE (gnu_field_type));
6365 else if (Strict_Alignment (Etype (gnat_field)))
6367 ("size of & with aliased or tagged components not ^ bits",
6368 Last_Bit (Component_Clause (gnat_field)), gnat_field,
6369 TYPE_SIZE (gnu_field_type));
6371 gnu_size = NULL_TREE;
6374 if (!integer_zerop (size_binop
6375 (TRUNC_MOD_EXPR, gnu_pos,
6376 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
6378 if (Is_Aliased (gnat_field))
6380 ("position of aliased field& must be multiple of ^ bits",
6381 First_Bit (Component_Clause (gnat_field)), gnat_field,
6382 TYPE_ALIGN (gnu_field_type));
6384 else if (Treat_As_Volatile (gnat_field))
6386 ("position of volatile field& must be multiple of ^ bits",
6387 First_Bit (Component_Clause (gnat_field)), gnat_field,
6388 TYPE_ALIGN (gnu_field_type));
6390 else if (Strict_Alignment (Etype (gnat_field)))
6392 ("position of & with aliased or tagged components not multiple of ^ bits",
6393 First_Bit (Component_Clause (gnat_field)), gnat_field,
6394 TYPE_ALIGN (gnu_field_type));
6399 gnu_pos = NULL_TREE;
6403 if (Is_Atomic (gnat_field))
6404 check_ok_for_atomic (gnu_field_type, gnat_field, false);
6407 /* If the record has rep clauses and this is the tag field, make a rep
6408 clause for it as well. */
6409 else if (Has_Specified_Layout (Scope (gnat_field))
6410 && Chars (gnat_field) == Name_uTag)
6412 gnu_pos = bitsize_zero_node;
6413 gnu_size = TYPE_SIZE (gnu_field_type);
6417 gnu_pos = NULL_TREE;
6419 /* We need to make the size the maximum for the type if it is
6420 self-referential and an unconstrained type. In that case, we can't
6421 pack the field since we can't make a copy to align it. */
6422 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
6424 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
6425 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
6427 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
6431 /* If a size is specified, adjust the field's type to it. */
6434 /* If the field's type is justified modular, we would need to remove
6435 the wrapper to (better) meet the layout requirements. However we
6436 can do so only if the field is not aliased to preserve the unique
6437 layout and if the prescribed size is not greater than that of the
6438 packed array to preserve the justification. */
6439 if (!needs_strict_alignment
6440 && TREE_CODE (gnu_field_type) == RECORD_TYPE
6441 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
6442 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
6444 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
6447 = make_type_from_size (gnu_field_type, gnu_size,
6448 Has_Biased_Representation (gnat_field));
6449 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
6450 "PAD", false, definition, true);
6453 /* Otherwise (or if there was an error), don't specify a position. */
6455 gnu_pos = NULL_TREE;
6457 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
6458 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
6460 /* Now create the decl for the field. */
6461 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
6462 packed, gnu_size, gnu_pos,
6463 Is_Aliased (gnat_field));
6464 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
6465 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
6467 if (Ekind (gnat_field) == E_Discriminant)
6468 DECL_DISCRIMINANT_NUMBER (gnu_field)
6469 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
6474 /* Return true if TYPE is a type with variable size, a padding type with a
6475 field of variable size or is a record that has a field such a field. */
6478 is_variable_size (tree type)
6482 if (!TREE_CONSTANT (TYPE_SIZE (type)))
6485 if (TREE_CODE (type) == RECORD_TYPE
6486 && TYPE_IS_PADDING_P (type)
6487 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
6490 if (TREE_CODE (type) != RECORD_TYPE
6491 && TREE_CODE (type) != UNION_TYPE
6492 && TREE_CODE (type) != QUAL_UNION_TYPE)
6495 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
6496 if (is_variable_size (TREE_TYPE (field)))
6502 /* qsort comparer for the bit positions of two record components. */
6505 compare_field_bitpos (const PTR rt1, const PTR rt2)
6507 const_tree const field1 = * (const_tree const *) rt1;
6508 const_tree const field2 = * (const_tree const *) rt2;
6510 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
6512 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
6515 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
6516 of GCC trees for fields that are in the record and have already been
6517 processed. When called from gnat_to_gnu_entity during the processing of a
6518 record type definition, the GCC nodes for the discriminants will be on
6519 the chain. The other calls to this function are recursive calls from
6520 itself for the Component_List of a variant and the chain is empty.
6522 PACKED is 1 if this is for a packed record, -1 if this is for a record
6523 with Component_Alignment of Storage_Unit, -2 if this is for a record
6524 with a specified alignment.
6526 DEFINITION is true if we are defining this record.
6528 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
6529 with a rep clause is to be added. If it is nonzero, that is all that
6530 should be done with such fields.
6532 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
6533 laying out the record. This means the alignment only serves to force fields
6534 to be bitfields, but not require the record to be that aligned. This is
6537 ALL_REP, if true, means a rep clause was found for all the fields. This
6538 simplifies the logic since we know we're not in the mixed case.
6540 DO_NOT_FINALIZE, if true, means that the record type is expected to be
6541 modified afterwards so it will not be sent to the back-end for finalization.
6543 UNCHECKED_UNION, if true, means that we are building a type for a record
6544 with a Pragma Unchecked_Union.
6546 The processing of the component list fills in the chain with all of the
6547 fields of the record and then the record type is finished. */
6550 components_to_record (tree gnu_record_type, Node_Id component_list,
6551 tree gnu_field_list, int packed, bool definition,
6552 tree *p_gnu_rep_list, bool cancel_alignment,
6553 bool all_rep, bool do_not_finalize, bool unchecked_union)
6555 Node_Id component_decl;
6556 Entity_Id gnat_field;
6557 Node_Id variant_part;
6558 tree gnu_our_rep_list = NULL_TREE;
6559 tree gnu_field, gnu_last;
6560 bool layout_with_rep = false;
6561 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
6563 /* For each variable within each component declaration create a GCC field
6564 and add it to the list, skipping any pragmas in the list. */
6565 if (Present (Component_Items (component_list)))
6566 for (component_decl = First_Non_Pragma (Component_Items (component_list));
6567 Present (component_decl);
6568 component_decl = Next_Non_Pragma (component_decl))
6570 gnat_field = Defining_Entity (component_decl);
6572 if (Chars (gnat_field) == Name_uParent)
6573 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
6576 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
6577 packed, definition);
6579 /* If this is the _Tag field, put it before any discriminants,
6580 instead of after them as is the case for all other fields. */
6581 if (Chars (gnat_field) == Name_uTag)
6582 gnu_field_list = chainon (gnu_field_list, gnu_field);
6585 TREE_CHAIN (gnu_field) = gnu_field_list;
6586 gnu_field_list = gnu_field;
6590 save_gnu_tree (gnat_field, gnu_field, false);
6593 /* At the end of the component list there may be a variant part. */
6594 variant_part = Variant_Part (component_list);
6596 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
6597 mutually exclusive and should go in the same memory. To do this we need
6598 to treat each variant as a record whose elements are created from the
6599 component list for the variant. So here we create the records from the
6600 lists for the variants and put them all into the QUAL_UNION_TYPE.
6601 If this is an Unchecked_Union, we make a UNION_TYPE instead or
6602 use GNU_RECORD_TYPE if there are no fields so far. */
6603 if (Present (variant_part))
6605 Node_Id gnat_discr = Name (variant_part), variant;
6606 tree gnu_discr = gnat_to_gnu (gnat_discr);
6607 tree gnu_name = TYPE_NAME (gnu_record_type);
6609 = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
6611 tree gnu_union_type, gnu_union_name, gnu_union_field;
6612 tree gnu_variant_list = NULL_TREE;
6614 if (TREE_CODE (gnu_name) == TYPE_DECL)
6615 gnu_name = DECL_NAME (gnu_name);
6618 = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
6620 /* Reuse an enclosing union if all fields are in the variant part
6621 and there is no representation clause on the record, to match
6622 the layout of C unions. There is an associated check below. */
6624 && TREE_CODE (gnu_record_type) == UNION_TYPE
6625 && !TYPE_PACKED (gnu_record_type))
6626 gnu_union_type = gnu_record_type;
6630 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
6632 TYPE_NAME (gnu_union_type) = gnu_union_name;
6633 TYPE_ALIGN (gnu_union_type) = 0;
6634 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
6637 for (variant = First_Non_Pragma (Variants (variant_part));
6639 variant = Next_Non_Pragma (variant))
6641 tree gnu_variant_type = make_node (RECORD_TYPE);
6642 tree gnu_inner_name;
6645 Get_Variant_Encoding (variant);
6646 gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
6647 TYPE_NAME (gnu_variant_type)
6648 = concat_name (gnu_union_name,
6649 IDENTIFIER_POINTER (gnu_inner_name));
6651 /* Set the alignment of the inner type in case we need to make
6652 inner objects into bitfields, but then clear it out
6653 so the record actually gets only the alignment required. */
6654 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6655 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6657 /* Similarly, if the outer record has a size specified and all fields
6658 have record rep clauses, we can propagate the size into the
6660 if (all_rep_and_size)
6662 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6663 TYPE_SIZE_UNIT (gnu_variant_type)
6664 = TYPE_SIZE_UNIT (gnu_record_type);
6667 /* Create the record type for the variant. Note that we defer
6668 finalizing it until after we are sure to actually use it. */
6669 components_to_record (gnu_variant_type, Component_List (variant),
6670 NULL_TREE, packed, definition,
6671 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6672 true, unchecked_union);
6674 gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
6676 Set_Present_Expr (variant, annotate_value (gnu_qual));
6678 /* If this is an Unchecked_Union and we have exactly one field,
6679 use this field directly to match the layout of C unions. */
6681 && TYPE_FIELDS (gnu_variant_type)
6682 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6683 gnu_field = TYPE_FIELDS (gnu_variant_type);
6686 /* Deal with packedness like in gnat_to_gnu_field. */
6688 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6690 /* Finalize the record type now. We used to throw away
6691 empty records but we no longer do that because we need
6692 them to generate complete debug info for the variant;
6693 otherwise, the union type definition will be lacking
6694 the fields associated with these empty variants. */
6695 rest_of_record_type_compilation (gnu_variant_type);
6697 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6698 gnu_union_type, field_packed,
6700 ? TYPE_SIZE (gnu_variant_type)
6703 ? bitsize_zero_node : 0),
6706 DECL_INTERNAL_P (gnu_field) = 1;
6708 if (!unchecked_union)
6709 DECL_QUALIFIER (gnu_field) = gnu_qual;
6712 TREE_CHAIN (gnu_field) = gnu_variant_list;
6713 gnu_variant_list = gnu_field;
6716 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6717 if (gnu_variant_list)
6719 int union_field_packed;
6721 if (all_rep_and_size)
6723 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6724 TYPE_SIZE_UNIT (gnu_union_type)
6725 = TYPE_SIZE_UNIT (gnu_record_type);
6728 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6729 all_rep_and_size ? 1 : 0, false);
6731 /* If GNU_UNION_TYPE is our record type, it means we must have an
6732 Unchecked_Union with no fields. Verify that and, if so, just
6734 if (gnu_union_type == gnu_record_type)
6736 gcc_assert (unchecked_union
6738 && !gnu_our_rep_list);
6742 /* Deal with packedness like in gnat_to_gnu_field. */
6744 = adjust_packed (gnu_union_type, gnu_record_type, packed);
6747 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6749 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6750 all_rep ? bitsize_zero_node : 0, 0);
6752 DECL_INTERNAL_P (gnu_union_field) = 1;
6753 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6754 gnu_field_list = gnu_union_field;
6758 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6759 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6760 in a separate pass since we want to handle the discriminants but can't
6761 play with them until we've used them in debugging data above.
6763 ??? Note: if we then reorder them, debugging information will be wrong,
6764 but there's nothing that can be done about this at the moment. */
6765 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6767 if (DECL_FIELD_OFFSET (gnu_field))
6769 tree gnu_next = TREE_CHAIN (gnu_field);
6772 gnu_field_list = gnu_next;
6774 TREE_CHAIN (gnu_last) = gnu_next;
6776 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6777 gnu_our_rep_list = gnu_field;
6778 gnu_field = gnu_next;
6782 gnu_last = gnu_field;
6783 gnu_field = TREE_CHAIN (gnu_field);
6787 /* If we have any items in our rep'ed field list, it is not the case that all
6788 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6789 set it and ignore the items. */
6790 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6791 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6792 else if (gnu_our_rep_list)
6794 /* Otherwise, sort the fields by bit position and put them into their
6795 own record if we have any fields without rep clauses. */
6797 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6798 int len = list_length (gnu_our_rep_list);
6799 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6802 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6803 gnu_field = TREE_CHAIN (gnu_field), i++)
6804 gnu_arr[i] = gnu_field;
6806 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6808 /* Put the fields in the list in order of increasing position, which
6809 means we start from the end. */
6810 gnu_our_rep_list = NULL_TREE;
6811 for (i = len - 1; i >= 0; i--)
6813 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6814 gnu_our_rep_list = gnu_arr[i];
6815 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6820 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6821 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6822 gnu_record_type, 0, 0, 0, 1);
6823 DECL_INTERNAL_P (gnu_field) = 1;
6824 gnu_field_list = chainon (gnu_field_list, gnu_field);
6828 layout_with_rep = true;
6829 gnu_field_list = nreverse (gnu_our_rep_list);
6833 if (cancel_alignment)
6834 TYPE_ALIGN (gnu_record_type) = 0;
6836 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6837 layout_with_rep ? 1 : 0, do_not_finalize);
6840 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6841 placed into an Esize, Component_Bit_Offset, or Component_Size value
6842 in the GNAT tree. */
6845 annotate_value (tree gnu_size)
6847 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6849 Node_Ref_Or_Val ops[3], ret;
6852 struct tree_int_map **h = NULL;
6854 /* See if we've already saved the value for this node. */
6855 if (EXPR_P (gnu_size))
6857 struct tree_int_map in;
6858 if (!annotate_value_cache)
6859 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6860 tree_int_map_eq, 0);
6861 in.base.from = gnu_size;
6862 h = (struct tree_int_map **)
6863 htab_find_slot (annotate_value_cache, &in, INSERT);
6866 return (Node_Ref_Or_Val) (*h)->to;
6869 /* If we do not return inside this switch, TCODE will be set to the
6870 code to use for a Create_Node operand and LEN (set above) will be
6871 the number of recursive calls for us to make. */
6873 switch (TREE_CODE (gnu_size))
6876 if (TREE_OVERFLOW (gnu_size))
6879 /* This may have come from a conversion from some smaller type,
6880 so ensure this is in bitsizetype. */
6881 gnu_size = convert (bitsizetype, gnu_size);
6883 /* For negative values, use NEGATE_EXPR of the supplied value. */
6884 if (tree_int_cst_sgn (gnu_size) < 0)
6886 /* The ridiculous code below is to handle the case of the largest
6887 negative integer. */
6888 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6889 bool adjust = false;
6892 if (TREE_OVERFLOW (negative_size))
6895 = size_binop (MINUS_EXPR, bitsize_zero_node,
6896 size_binop (PLUS_EXPR, gnu_size,
6901 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6903 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6905 return annotate_value (temp);
6908 if (!host_integerp (gnu_size, 1))
6911 size = tree_low_cst (gnu_size, 1);
6913 /* This peculiar test is to make sure that the size fits in an int
6914 on machines where HOST_WIDE_INT is not "int". */
6915 if (tree_low_cst (gnu_size, 1) == size)
6916 return UI_From_Int (size);
6921 /* The only case we handle here is a simple discriminant reference. */
6922 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6923 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6924 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6925 return Create_Node (Discrim_Val,
6926 annotate_value (DECL_DISCRIMINANT_NUMBER
6927 (TREE_OPERAND (gnu_size, 1))),
6932 CASE_CONVERT: case NON_LVALUE_EXPR:
6933 return annotate_value (TREE_OPERAND (gnu_size, 0));
6935 /* Now just list the operations we handle. */
6936 case COND_EXPR: tcode = Cond_Expr; break;
6937 case PLUS_EXPR: tcode = Plus_Expr; break;
6938 case MINUS_EXPR: tcode = Minus_Expr; break;
6939 case MULT_EXPR: tcode = Mult_Expr; break;
6940 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
6941 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
6942 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
6943 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
6944 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
6945 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
6946 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
6947 case NEGATE_EXPR: tcode = Negate_Expr; break;
6948 case MIN_EXPR: tcode = Min_Expr; break;
6949 case MAX_EXPR: tcode = Max_Expr; break;
6950 case ABS_EXPR: tcode = Abs_Expr; break;
6951 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
6952 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
6953 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
6954 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
6955 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
6956 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
6957 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
6958 case LT_EXPR: tcode = Lt_Expr; break;
6959 case LE_EXPR: tcode = Le_Expr; break;
6960 case GT_EXPR: tcode = Gt_Expr; break;
6961 case GE_EXPR: tcode = Ge_Expr; break;
6962 case EQ_EXPR: tcode = Eq_Expr; break;
6963 case NE_EXPR: tcode = Ne_Expr; break;
6969 /* Now get each of the operands that's relevant for this code. If any
6970 cannot be expressed as a repinfo node, say we can't. */
6971 for (i = 0; i < 3; i++)
6974 for (i = 0; i < len; i++)
6976 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6977 if (ops[i] == No_Uint)
6981 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6983 /* Save the result in the cache. */
6986 *h = GGC_NEW (struct tree_int_map);
6987 (*h)->base.from = gnu_size;
6994 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6995 GCC type, set Component_Bit_Offset and Esize to the position and size
6999 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
7003 Entity_Id gnat_field;
7005 /* We operate by first making a list of all fields and their positions
7006 (we can get the sizes easily at any time) by a recursive call
7007 and then update all the sizes into the tree. */
7008 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
7009 size_zero_node, bitsize_zero_node,
7012 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
7013 gnat_field = Next_Entity (gnat_field))
7014 if ((Ekind (gnat_field) == E_Component
7015 || (Ekind (gnat_field) == E_Discriminant
7016 && !Is_Unchecked_Union (Scope (gnat_field)))))
7018 tree parent_offset = bitsize_zero_node;
7020 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
7025 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
7027 /* In this mode the tag and parent components have not been
7028 generated, so we add the appropriate offset to each
7029 component. For a component appearing in the current
7030 extension, the offset is the size of the parent. */
7031 if (Is_Derived_Type (gnat_entity)
7032 && Original_Record_Component (gnat_field) == gnat_field)
7034 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
7037 parent_offset = bitsize_int (POINTER_SIZE);
7040 Set_Component_Bit_Offset
7043 (size_binop (PLUS_EXPR,
7044 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
7045 TREE_VALUE (TREE_VALUE
7046 (TREE_VALUE (gnu_entry)))),
7049 Set_Esize (gnat_field,
7050 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
7052 else if (Is_Tagged_Type (gnat_entity)
7053 && Is_Derived_Type (gnat_entity))
7055 /* If there is no gnu_entry, this is an inherited component whose
7056 position is the same as in the parent type. */
7057 Set_Component_Bit_Offset
7059 Component_Bit_Offset (Original_Record_Component (gnat_field)));
7060 Set_Esize (gnat_field,
7061 Esize (Original_Record_Component (gnat_field)));
7066 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
7067 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
7068 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
7069 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
7070 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
7071 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
7075 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
7076 tree gnu_bitpos, unsigned int offset_align)
7079 tree gnu_result = gnu_list;
7081 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
7082 gnu_field = TREE_CHAIN (gnu_field))
7084 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
7085 DECL_FIELD_BIT_OFFSET (gnu_field));
7086 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
7087 DECL_FIELD_OFFSET (gnu_field));
7088 unsigned int our_offset_align
7089 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
7092 = tree_cons (gnu_field,
7093 tree_cons (gnu_our_offset,
7094 tree_cons (size_int (our_offset_align),
7095 gnu_our_bitpos, NULL_TREE),
7099 if (DECL_INTERNAL_P (gnu_field))
7101 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
7102 gnu_our_offset, gnu_our_bitpos,
7109 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
7110 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
7111 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
7112 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
7113 for the size of a field. COMPONENT_P is true if we are being called
7114 to process the Component_Size of GNAT_OBJECT. This is used for error
7115 message handling and to indicate to use the object size of GNU_TYPE.
7116 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
7117 it means that a size of zero should be treated as an unspecified size. */
7120 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
7121 enum tree_code kind, bool component_p, bool zero_ok)
7123 Node_Id gnat_error_node;
7124 tree type_size, size;
7126 if (kind == VAR_DECL
7127 /* If a type needs strict alignment, a component of this type in
7128 a packed record cannot be packed and thus uses the type size. */
7129 || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
7130 type_size = TYPE_SIZE (gnu_type);
7132 type_size = rm_size (gnu_type);
7134 /* Find the node to use for errors. */
7135 if ((Ekind (gnat_object) == E_Component
7136 || Ekind (gnat_object) == E_Discriminant)
7137 && Present (Component_Clause (gnat_object)))
7138 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
7139 else if (Present (Size_Clause (gnat_object)))
7140 gnat_error_node = Expression (Size_Clause (gnat_object));
7142 gnat_error_node = gnat_object;
7144 /* Return 0 if no size was specified, either because Esize was not Present or
7145 the specified size was zero. */
7146 if (No (uint_size) || uint_size == No_Uint)
7149 /* Get the size as a tree. Give an error if a size was specified, but cannot
7150 be represented as in sizetype. */
7151 size = UI_To_gnu (uint_size, bitsizetype);
7152 if (TREE_OVERFLOW (size))
7154 post_error_ne (component_p ? "component size of & is too large"
7155 : "size of & is too large",
7156 gnat_error_node, gnat_object);
7160 /* Ignore a negative size since that corresponds to our back-annotation.
7161 Also ignore a zero size unless a size clause exists. */
7162 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
7165 /* The size of objects is always a multiple of a byte. */
7166 if (kind == VAR_DECL
7167 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
7170 post_error_ne ("component size for& is not a multiple of Storage_Unit",
7171 gnat_error_node, gnat_object);
7173 post_error_ne ("size for& is not a multiple of Storage_Unit",
7174 gnat_error_node, gnat_object);
7178 /* If this is an integral type or a packed array type, the front-end has
7179 verified the size, so we need not do it here (which would entail
7180 checking against the bounds). However, if this is an aliased object, it
7181 may not be smaller than the type of the object. */
7182 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
7183 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
7186 /* If the object is a record that contains a template, add the size of
7187 the template to the specified size. */
7188 if (TREE_CODE (gnu_type) == RECORD_TYPE
7189 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7190 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
7192 /* Modify the size of the type to be that of the maximum size if it has a
7194 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
7195 type_size = max_size (type_size, true);
7197 /* If this is an access type or a fat pointer, the minimum size is that given
7198 by the smallest integral mode that's valid for pointers. */
7199 if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
7201 enum machine_mode p_mode;
7203 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
7204 !targetm.valid_pointer_mode (p_mode);
7205 p_mode = GET_MODE_WIDER_MODE (p_mode))
7208 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
7211 /* If the size of the object is a constant, the new size must not be
7213 if (TREE_CODE (type_size) != INTEGER_CST
7214 || TREE_OVERFLOW (type_size)
7215 || tree_int_cst_lt (size, type_size))
7219 ("component size for& too small{, minimum allowed is ^}",
7220 gnat_error_node, gnat_object, type_size);
7222 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
7223 gnat_error_node, gnat_object, type_size);
7225 if (kind == VAR_DECL && !component_p
7226 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
7227 && !tree_int_cst_lt (size, rm_size (gnu_type)))
7228 post_error_ne_tree_2
7229 ("\\size of ^ is not a multiple of alignment (^ bits)",
7230 gnat_error_node, gnat_object, rm_size (gnu_type),
7231 TYPE_ALIGN (gnu_type));
7233 else if (INTEGRAL_TYPE_P (gnu_type))
7234 post_error_ne ("\\size would be legal if & were not aliased!",
7235 gnat_error_node, gnat_object);
7243 /* Similarly, but both validate and process a value of RM size. This
7244 routine is only called for types. */
7247 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
7249 /* Only give an error if a Value_Size clause was explicitly given.
7250 Otherwise, we'd be duplicating an error on the Size clause. */
7251 Node_Id gnat_attr_node
7252 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
7253 tree old_size = rm_size (gnu_type);
7256 /* Get the size as a tree. Do nothing if none was specified, either
7257 because RM size was not Present or if the specified size was zero.
7258 Give an error if a size was specified, but cannot be represented as
7260 if (No (uint_size) || uint_size == No_Uint)
7263 size = UI_To_gnu (uint_size, bitsizetype);
7264 if (TREE_OVERFLOW (size))
7266 if (Present (gnat_attr_node))
7267 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
7273 /* Ignore a negative size since that corresponds to our back-annotation.
7274 Also ignore a zero size unless a size clause exists, a Value_Size
7275 clause exists, or this is an integer type, in which case the
7276 front end will have always set it. */
7277 else if (tree_int_cst_sgn (size) < 0
7278 || (integer_zerop (size) && No (gnat_attr_node)
7279 && !Has_Size_Clause (gnat_entity)
7280 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
7283 /* If the old size is self-referential, get the maximum size. */
7284 if (CONTAINS_PLACEHOLDER_P (old_size))
7285 old_size = max_size (old_size, true);
7287 /* If the size of the object is a constant, the new size must not be
7288 smaller (the front end checks this for scalar types). */
7289 if (TREE_CODE (old_size) != INTEGER_CST
7290 || TREE_OVERFLOW (old_size)
7291 || (AGGREGATE_TYPE_P (gnu_type)
7292 && tree_int_cst_lt (size, old_size)))
7294 if (Present (gnat_attr_node))
7296 ("Value_Size for& too small{, minimum allowed is ^}",
7297 gnat_attr_node, gnat_entity, old_size);
7302 /* Otherwise, set the RM size proper for numerical types... */
7303 if ((TREE_CODE (gnu_type) == INTEGER_TYPE
7304 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
7305 || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
7306 || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
7307 TYPE_RM_SIZE (gnu_type) = size;
7309 /* ...or the Ada size for record and union types. */
7310 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7311 || TREE_CODE (gnu_type) == UNION_TYPE
7312 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7313 && !TYPE_IS_FAT_POINTER_P (gnu_type))
7314 SET_TYPE_ADA_SIZE (gnu_type, size);
7317 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
7318 If TYPE is the best type, return it. Otherwise, make a new type. We
7319 only support new integral and pointer types. FOR_BIASED is true if
7320 we are making a biased type. */
7323 make_type_from_size (tree type, tree size_tree, bool for_biased)
7325 unsigned HOST_WIDE_INT size;
7329 /* If size indicates an error, just return TYPE to avoid propagating
7330 the error. Likewise if it's too large to represent. */
7331 if (!size_tree || !host_integerp (size_tree, 1))
7334 size = tree_low_cst (size_tree, 1);
7336 switch (TREE_CODE (type))
7341 biased_p = (TREE_CODE (type) == INTEGER_TYPE
7342 && TYPE_BIASED_REPRESENTATION_P (type));
7344 /* Only do something if the type is not a packed array type and
7345 doesn't already have the proper size. */
7346 if (TYPE_PACKED_ARRAY_TYPE_P (type)
7347 || (TYPE_PRECISION (type) == size && biased_p == for_biased))
7350 biased_p |= for_biased;
7351 size = MIN (size, LONG_LONG_TYPE_SIZE);
7353 if (TYPE_UNSIGNED (type) || biased_p)
7354 new_type = make_unsigned_type (size);
7356 new_type = make_signed_type (size);
7357 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
7358 TYPE_MIN_VALUE (new_type)
7359 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
7360 TYPE_MAX_VALUE (new_type)
7361 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
7362 /* Propagate the name to avoid creating a fake subrange type. */
7363 if (TYPE_NAME (type))
7365 if (TREE_CODE (TYPE_NAME (type)) == TYPE_DECL)
7366 TYPE_NAME (new_type) = DECL_NAME (TYPE_NAME (type));
7368 TYPE_NAME (new_type) = TYPE_NAME (type);
7370 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
7371 TYPE_RM_SIZE (new_type) = bitsize_int (size);
7375 /* Do something if this is a fat pointer, in which case we
7376 may need to return the thin pointer. */
7377 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
7379 enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
7380 if (!targetm.valid_pointer_mode (p_mode))
7383 build_pointer_type_for_mode
7384 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)),
7390 /* Only do something if this is a thin pointer, in which case we
7391 may need to return the fat pointer. */
7392 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
7394 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
7404 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
7405 a type or object whose present alignment is ALIGN. If this alignment is
7406 valid, return it. Otherwise, give an error and return ALIGN. */
7409 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
7411 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
7412 unsigned int new_align;
7413 Node_Id gnat_error_node;
7415 /* Don't worry about checking alignment if alignment was not specified
7416 by the source program and we already posted an error for this entity. */
7417 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
7420 /* Post the error on the alignment clause if any. */
7421 if (Present (Alignment_Clause (gnat_entity)))
7422 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
7424 gnat_error_node = gnat_entity;
7426 /* Within GCC, an alignment is an integer, so we must make sure a value is
7427 specified that fits in that range. Also, there is an upper bound to
7428 alignments we can support/allow. */
7429 if (!UI_Is_In_Int_Range (alignment)
7430 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
7431 post_error_ne_num ("largest supported alignment for& is ^",
7432 gnat_error_node, gnat_entity, max_allowed_alignment);
7433 else if (!(Present (Alignment_Clause (gnat_entity))
7434 && From_At_Mod (Alignment_Clause (gnat_entity)))
7435 && new_align * BITS_PER_UNIT < align)
7436 post_error_ne_num ("alignment for& must be at least ^",
7437 gnat_error_node, gnat_entity,
7438 align / BITS_PER_UNIT);
7441 new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
7442 if (new_align > align)
7449 /* Return the smallest alignment not less than SIZE. */
7452 ceil_alignment (unsigned HOST_WIDE_INT size)
7454 return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
7457 /* Verify that OBJECT, a type or decl, is something we can implement
7458 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
7459 if we require atomic components. */
7462 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
7464 Node_Id gnat_error_point = gnat_entity;
7466 enum machine_mode mode;
7470 /* There are three case of what OBJECT can be. It can be a type, in which
7471 case we take the size, alignment and mode from the type. It can be a
7472 declaration that was indirect, in which case the relevant values are
7473 that of the type being pointed to, or it can be a normal declaration,
7474 in which case the values are of the decl. The code below assumes that
7475 OBJECT is either a type or a decl. */
7476 if (TYPE_P (object))
7478 mode = TYPE_MODE (object);
7479 align = TYPE_ALIGN (object);
7480 size = TYPE_SIZE (object);
7482 else if (DECL_BY_REF_P (object))
7484 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
7485 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
7486 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
7490 mode = DECL_MODE (object);
7491 align = DECL_ALIGN (object);
7492 size = DECL_SIZE (object);
7495 /* Consider all floating-point types atomic and any types that that are
7496 represented by integers no wider than a machine word. */
7497 if (GET_MODE_CLASS (mode) == MODE_FLOAT
7498 || ((GET_MODE_CLASS (mode) == MODE_INT
7499 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
7500 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
7503 /* For the moment, also allow anything that has an alignment equal
7504 to its size and which is smaller than a word. */
7505 if (size && TREE_CODE (size) == INTEGER_CST
7506 && compare_tree_int (size, align) == 0
7507 && align <= BITS_PER_WORD)
7510 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
7511 gnat_node = Next_Rep_Item (gnat_node))
7513 if (!comp_p && Nkind (gnat_node) == N_Pragma
7514 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7516 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7517 else if (comp_p && Nkind (gnat_node) == N_Pragma
7518 && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
7519 == Pragma_Atomic_Components))
7520 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
7524 post_error_ne ("atomic access to component of & cannot be guaranteed",
7525 gnat_error_point, gnat_entity);
7527 post_error_ne ("atomic access to & cannot be guaranteed",
7528 gnat_error_point, gnat_entity);
7531 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
7532 have compatible signatures so that a call using one type may be safely
7533 issued if the actual target function type is the other. Return 1 if it is
7534 the case, 0 otherwise, and post errors on the incompatibilities.
7536 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
7537 that calls to the subprogram will have arguments suitable for the later
7538 underlying builtin expansion. */
7541 compatible_signatures_p (tree ftype1, tree ftype2)
7543 /* As of now, we only perform very trivial tests and consider it's the
7544 programmer's responsibility to ensure the type correctness in the Ada
7545 declaration, as in the regular Import cases.
7547 Mismatches typically result in either error messages from the builtin
7548 expander, internal compiler errors, or in a real call sequence. This
7549 should be refined to issue diagnostics helping error detection and
7552 /* Almost fake test, ensuring a use of each argument. */
7553 if (ftype1 == ftype2)
7559 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
7560 type with all size expressions that contain F in a PLACEHOLDER_EXPR
7561 updated by replacing F with R.
7563 The function doesn't update the layout of the type, i.e. it assumes
7564 that the substitution is purely formal. That's why the replacement
7565 value R must itself contain a PLACEHOLDER_EXPR. */
7568 substitute_in_type (tree t, tree f, tree r)
7572 gcc_assert (CONTAINS_PLACEHOLDER_P (r));
7574 switch (TREE_CODE (t))
7579 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7580 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7582 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7583 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7585 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7588 new = build_range_type (TREE_TYPE (t), low, high);
7589 if (TYPE_INDEX_TYPE (t))
7591 (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
7598 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
7599 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
7601 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
7602 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
7604 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
7607 new = copy_type (t);
7608 TYPE_MIN_VALUE (new) = low;
7609 TYPE_MAX_VALUE (new) = high;
7616 new = substitute_in_type (TREE_TYPE (t), f, r);
7617 if (new == TREE_TYPE (t))
7620 return build_complex_type (new);
7626 /* These should never show up here. */
7631 tree component = substitute_in_type (TREE_TYPE (t), f, r);
7632 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
7634 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
7637 new = build_array_type (component, domain);
7638 TYPE_ALIGN (new) = TYPE_ALIGN (t);
7639 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
7640 SET_TYPE_MODE (new, TYPE_MODE (t));
7641 TYPE_SIZE (new) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
7642 TYPE_SIZE_UNIT (new) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
7643 TYPE_NONALIASED_COMPONENT (new) = TYPE_NONALIASED_COMPONENT (t);
7644 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
7645 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
7651 case QUAL_UNION_TYPE:
7653 bool changed_field = false;
7656 /* Start out with no fields, make new fields, and chain them
7657 in. If we haven't actually changed the type of any field,
7658 discard everything we've done and return the old type. */
7659 new = copy_type (t);
7660 TYPE_FIELDS (new) = NULL_TREE;
7662 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
7664 tree new_field = copy_node (field), new_n;
7666 new_n = substitute_in_type (TREE_TYPE (field), f, r);
7667 if (new_n != TREE_TYPE (field))
7669 TREE_TYPE (new_field) = new_n;
7670 changed_field = true;
7673 new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
7674 if (new_n != DECL_FIELD_OFFSET (field))
7676 DECL_FIELD_OFFSET (new_field) = new_n;
7677 changed_field = true;
7680 /* Do the substitution inside the qualifier, if any. */
7681 if (TREE_CODE (t) == QUAL_UNION_TYPE)
7683 new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7684 if (new_n != DECL_QUALIFIER (field))
7686 DECL_QUALIFIER (new_field) = new_n;
7687 changed_field = true;
7691 DECL_CONTEXT (new_field) = new;
7692 SET_DECL_ORIGINAL_FIELD (new_field,
7693 (DECL_ORIGINAL_FIELD (field)
7694 ? DECL_ORIGINAL_FIELD (field) : field));
7696 TREE_CHAIN (new_field) = TYPE_FIELDS (new);
7697 TYPE_FIELDS (new) = new_field;
7703 TYPE_FIELDS (new) = nreverse (TYPE_FIELDS (new));
7704 TYPE_SIZE (new) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
7705 TYPE_SIZE_UNIT (new) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
7706 SET_TYPE_ADA_SIZE (new, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
7715 /* Return the RM size of GNU_TYPE. This is the actual number of bits
7716 needed to represent the object. */
7719 rm_size (tree gnu_type)
7721 /* For integer types, this is the precision. */
7722 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7723 return TYPE_RM_SIZE (gnu_type);
7725 /* Return the RM size of the actual data plus the size of the template. */
7726 if (TREE_CODE (gnu_type) == RECORD_TYPE
7727 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7729 size_binop (PLUS_EXPR,
7730 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7731 DECL_SIZE (TYPE_FIELDS (gnu_type)));
7733 /* For record types, we store the size explicitly. */
7734 if ((TREE_CODE (gnu_type) == RECORD_TYPE
7735 || TREE_CODE (gnu_type) == UNION_TYPE
7736 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7737 && !TYPE_IS_FAT_POINTER_P (gnu_type)
7738 && TYPE_ADA_SIZE (gnu_type))
7739 return TYPE_ADA_SIZE (gnu_type);
7741 /* For other types, this is just the size. */
7742 return TYPE_SIZE (gnu_type);
7745 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7746 fully-qualified name, possibly with type information encoding.
7747 Otherwise, return the name. */
7750 get_entity_name (Entity_Id gnat_entity)
7752 Get_Encoded_Name (gnat_entity);
7753 return get_identifier_with_length (Name_Buffer, Name_Len);
7756 /* Return an identifier representing the external name to be used for
7757 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7758 and the specified suffix. */
7761 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7763 Entity_Kind kind = Ekind (gnat_entity);
7767 String_Template temp = {1, strlen (suffix)};
7768 Fat_Pointer fp = {suffix, &temp};
7769 Get_External_Name_With_Suffix (gnat_entity, fp);
7772 Get_External_Name (gnat_entity, 0);
7774 /* A variable using the Stdcall convention lives in a DLL. We adjust
7775 its name to use the jump table, the _imp__NAME contains the address
7776 for the NAME variable. */
7777 if ((kind == E_Variable || kind == E_Constant)
7778 && Has_Stdcall_Convention (gnat_entity))
7780 const int len = 6 + Name_Len;
7781 char *new_name = (char *) alloca (len + 1);
7782 strcpy (new_name, "_imp__");
7783 strcat (new_name, Name_Buffer);
7784 return get_identifier_with_length (new_name, len);
7787 return get_identifier_with_length (Name_Buffer, Name_Len);
7790 /* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
7791 string, return a new IDENTIFIER_NODE that is the concatenation of
7792 the name followed by "___" and the specified suffix. */
7795 concat_name (tree gnu_name, const char *suffix)
7797 const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
7798 char *new_name = (char *) alloca (len + 1);
7799 strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
7800 strcat (new_name, "___");
7801 strcat (new_name, suffix);
7802 return get_identifier_with_length (new_name, len);
7805 #include "gt-ada-decl.h"