1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2007, 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 /* Convention_Stdcall should be processed in a specific way on Windows targets
57 only. The macro below is a helper to avoid having to check for a Windows
58 specific attribute throughout this unit. */
60 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
61 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
63 #define Has_Stdcall_Convention(E) (0)
68 struct incomplete *next;
73 /* These variables are used to defer recursively expanding incomplete types
74 while we are processing an array, a record or a subprogram type. */
75 static int defer_incomplete_level = 0;
76 static struct incomplete *defer_incomplete_list;
78 /* This variable is used to delay expanding From_With_Type types until the
80 static struct incomplete *defer_limited_with;
82 /* These variables are used to defer finalizing types. The element of the
83 list is the TYPE_DECL associated with the type. */
84 static int defer_finalize_level = 0;
85 static VEC (tree,heap) *defer_finalize_list;
87 /* A hash table used to cache the result of annotate_value. */
88 static GTY ((if_marked ("tree_int_map_marked_p"),
89 param_is (struct tree_int_map))) htab_t annotate_value_cache;
91 static void copy_alias_set (tree, tree);
92 static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
93 static bool allocatable_size_p (tree, bool);
94 static void prepend_one_attribute_to (struct attrib **,
95 enum attr_type, tree, tree, Node_Id);
96 static void prepend_attributes (Entity_Id, struct attrib **);
97 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
98 static bool is_variable_size (tree);
99 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
101 static tree make_packable_type (tree);
102 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
103 static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
105 static bool same_discriminant_p (Entity_Id, Entity_Id);
106 static bool array_type_has_nonaliased_component (Entity_Id, tree);
107 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
108 bool, bool, bool, bool);
109 static Uint annotate_value (tree);
110 static void annotate_rep (Entity_Id, tree);
111 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
112 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
113 static void set_rm_size (Uint, tree, Entity_Id);
114 static tree make_type_from_size (tree, tree, bool);
115 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
116 static void check_ok_for_atomic (tree, Entity_Id, bool);
117 static int compatible_signatures_p (tree ftype1, tree ftype2);
119 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
120 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
121 refer to an Ada type. */
124 gnat_to_gnu_type (Entity_Id gnat_entity)
128 /* The back end never attempts to annotate generic types */
129 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
130 return void_type_node;
132 /* Convert the ada entity type into a GCC TYPE_DECL node. */
133 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
134 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
135 return TREE_TYPE (gnu_decl);
138 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
139 entity, this routine returns the equivalent GCC tree for that entity
140 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
143 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
144 initial value (in GCC tree form). This is optional for variables.
145 For renamed entities, GNU_EXPR gives the object being renamed.
147 DEFINITION is nonzero if this call is intended for a definition. This is
148 used for separate compilation where it necessary to know whether an
149 external declaration or a definition should be created if the GCC equivalent
150 was not created previously. The value of 1 is normally used for a nonzero
151 DEFINITION, but a value of 2 is used in special circumstances, defined in
155 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
157 Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
159 tree gnu_type = NULL_TREE;
160 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
161 GNAT tree. This node will be associated with the GNAT node by calling
162 the save_gnu_tree routine at the end of the `switch' statement. */
163 tree gnu_decl = NULL_TREE;
164 /* true if we have already saved gnu_decl as a gnat association. */
166 /* Nonzero if we incremented defer_incomplete_level. */
167 bool this_deferred = false;
168 /* Nonzero if we incremented force_global. */
169 bool this_global = false;
170 /* Nonzero if we should check to see if elaborated during processing. */
171 bool maybe_present = false;
172 /* Nonzero if we made GNU_DECL and its type here. */
173 bool this_made_decl = false;
174 struct attrib *attr_list = NULL;
175 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
176 || debug_info_level == DINFO_LEVEL_VERBOSE);
177 Entity_Kind kind = Ekind (gnat_entity);
180 = ((Known_Esize (gnat_entity)
181 && UI_Is_In_Int_Range (Esize (gnat_entity)))
182 ? MIN (UI_To_Int (Esize (gnat_entity)),
183 IN (kind, Float_Kind)
184 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
185 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
186 : LONG_LONG_TYPE_SIZE)
187 : LONG_LONG_TYPE_SIZE);
190 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
191 unsigned int align = 0;
193 /* Since a use of an Itype is a definition, process it as such if it
194 is not in a with'ed unit. */
196 if (!definition && Is_Itype (gnat_entity)
197 && !present_gnu_tree (gnat_entity)
198 && In_Extended_Main_Code_Unit (gnat_entity))
200 /* Ensure that we are in a subprogram mentioned in the Scope
201 chain of this entity, our current scope is global,
202 or that we encountered a task or entry (where we can't currently
203 accurately check scoping). */
204 if (!current_function_decl
205 || DECL_ELABORATION_PROC_P (current_function_decl))
207 process_type (gnat_entity);
208 return get_gnu_tree (gnat_entity);
211 for (gnat_temp = Scope (gnat_entity);
212 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
214 if (Is_Type (gnat_temp))
215 gnat_temp = Underlying_Type (gnat_temp);
217 if (Ekind (gnat_temp) == E_Subprogram_Body)
219 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
221 if (IN (Ekind (gnat_temp), Subprogram_Kind)
222 && Present (Protected_Body_Subprogram (gnat_temp)))
223 gnat_temp = Protected_Body_Subprogram (gnat_temp);
225 if (Ekind (gnat_temp) == E_Entry
226 || Ekind (gnat_temp) == E_Entry_Family
227 || Ekind (gnat_temp) == E_Task_Type
228 || (IN (Ekind (gnat_temp), Subprogram_Kind)
229 && present_gnu_tree (gnat_temp)
230 && (current_function_decl
231 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
233 process_type (gnat_entity);
234 return get_gnu_tree (gnat_entity);
238 /* This abort means the entity "gnat_entity" has an incorrect scope,
239 i.e. that its scope does not correspond to the subprogram in which
244 /* If this is entity 0, something went badly wrong. */
245 gcc_assert (Present (gnat_entity));
247 /* If we've already processed this entity, return what we got last time.
248 If we are defining the node, we should not have already processed it.
249 In that case, we will abort below when we try to save a new GCC tree for
250 this object. We also need to handle the case of getting a dummy type
251 when a Full_View exists. */
253 if (present_gnu_tree (gnat_entity)
254 && (!definition || (Is_Type (gnat_entity) && imported_p)))
256 gnu_decl = get_gnu_tree (gnat_entity);
258 if (TREE_CODE (gnu_decl) == TYPE_DECL
259 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
260 && IN (kind, Incomplete_Or_Private_Kind)
261 && Present (Full_View (gnat_entity)))
263 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
266 save_gnu_tree (gnat_entity, NULL_TREE, false);
267 save_gnu_tree (gnat_entity, gnu_decl, false);
273 /* If this is a numeric or enumeral type, or an access type, a nonzero
274 Esize must be specified unless it was specified by the programmer. */
275 gcc_assert (!Unknown_Esize (gnat_entity)
276 || Has_Size_Clause (gnat_entity)
277 || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
278 && (!IN (kind, Access_Kind)
279 || kind == E_Access_Protected_Subprogram_Type
280 || kind == E_Anonymous_Access_Protected_Subprogram_Type
281 || kind == E_Access_Subtype)));
283 /* Likewise, RM_Size must be specified for all discrete and fixed-point
285 gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
286 || !Unknown_RM_Size (gnat_entity));
288 /* Get the name of the entity and set up the line number and filename of
289 the original definition for use in any decl we make. */
290 gnu_entity_id = get_entity_name (gnat_entity);
291 Sloc_to_locus (Sloc (gnat_entity), &input_location);
293 /* If we get here, it means we have not yet done anything with this
294 entity. If we are not defining it here, it must be external,
295 otherwise we should have defined it already. */
296 gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
297 || kind == E_Discriminant || kind == E_Component
299 || (kind == E_Constant && Present (Full_View (gnat_entity)))
300 || IN (kind, Type_Kind));
302 /* For cases when we are not defining (i.e., we are referencing from
303 another compilation unit) Public entities, show we are at global level
304 for the purpose of computing scopes. Don't do this for components or
305 discriminants since the relevant test is whether or not the record is
306 being defined. But do this for Imported functions or procedures in
308 if ((!definition && Is_Public (gnat_entity)
309 && !Is_Statically_Allocated (gnat_entity)
310 && kind != E_Discriminant && kind != E_Component)
311 || (Is_Imported (gnat_entity)
312 && (kind == E_Function || kind == E_Procedure)))
313 force_global++, this_global = true;
315 /* Handle any attributes directly attached to the entity. */
316 if (Has_Gigi_Rep_Item (gnat_entity))
317 prepend_attributes (gnat_entity, &attr_list);
319 /* Machine_Attributes on types are expected to be propagated to subtypes.
320 The corresponding Gigi_Rep_Items are only attached to the first subtype
321 though, so we handle the propagation here. */
322 if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
323 && !Is_First_Subtype (gnat_entity)
324 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
325 prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
330 /* If this is a use of a deferred constant, get its full
332 if (!definition && Present (Full_View (gnat_entity)))
334 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
340 /* If we have an external constant that we are not defining, get the
341 expression that is was defined to represent. We may throw that
342 expression away later if it is not a constant. Do not retrieve the
343 expression if it is an aggregate or allocator, because in complex
344 instantiation contexts it may not be expanded */
346 && Present (Expression (Declaration_Node (gnat_entity)))
347 && !No_Initialization (Declaration_Node (gnat_entity))
348 && (Nkind (Expression (Declaration_Node (gnat_entity)))
350 && (Nkind (Expression (Declaration_Node (gnat_entity)))
352 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
354 /* Ignore deferred constant definitions; they are processed fully in the
355 front-end. For deferred constant references get the full definition.
356 On the other hand, constants that are renamings are handled like
357 variable renamings. If No_Initialization is set, this is not a
358 deferred constant but a constant whose value is built manually. */
359 if (definition && !gnu_expr
360 && !No_Initialization (Declaration_Node (gnat_entity))
361 && No (Renamed_Object (gnat_entity)))
363 gnu_decl = error_mark_node;
367 else if (!definition && IN (kind, Incomplete_Or_Private_Kind)
368 && Present (Full_View (gnat_entity)))
370 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
379 /* We used to special case VMS exceptions here to directly map them to
380 their associated condition code. Since this code had to be masked
381 dynamically to strip off the severity bits, this caused trouble in
382 the GCC/ZCX case because the "type" pointers we store in the tables
383 have to be static. We now don't special case here anymore, and let
384 the regular processing take place, which leaves us with a regular
385 exception data object for VMS exceptions too. The condition code
386 mapping is taken care of by the front end and the bitmasking by the
393 /* The GNAT record where the component was defined. */
394 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
396 /* If the variable is an inherited record component (in the case of
397 extended record types), just return the inherited entity, which
398 must be a FIELD_DECL. Likewise for discriminants.
399 For discriminants of untagged records which have explicit
400 stored discriminants, return the entity for the corresponding
401 stored discriminant. Also use Original_Record_Component
402 if the record has a private extension. */
404 if (Present (Original_Record_Component (gnat_entity))
405 && Original_Record_Component (gnat_entity) != gnat_entity)
408 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
409 gnu_expr, definition);
414 /* If the enclosing record has explicit stored discriminants,
415 then it is an untagged record. If the Corresponding_Discriminant
416 is not empty then this must be a renamed discriminant and its
417 Original_Record_Component must point to the corresponding explicit
418 stored discriminant (i.e., we should have taken the previous
421 else if (Present (Corresponding_Discriminant (gnat_entity))
422 && Is_Tagged_Type (gnat_record))
424 /* A tagged record has no explicit stored discriminants. */
426 gcc_assert (First_Discriminant (gnat_record)
427 == First_Stored_Discriminant (gnat_record));
429 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
430 gnu_expr, definition);
435 else if (Present (CR_Discriminant (gnat_entity))
436 && type_annotate_only)
438 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
439 gnu_expr, definition);
444 /* If the enclosing record has explicit stored discriminants,
445 then it is an untagged record. If the Corresponding_Discriminant
446 is not empty then this must be a renamed discriminant and its
447 Original_Record_Component must point to the corresponding explicit
448 stored discriminant (i.e., we should have taken the first
451 else if (Present (Corresponding_Discriminant (gnat_entity))
452 && (First_Discriminant (gnat_record)
453 != First_Stored_Discriminant (gnat_record)))
456 /* Otherwise, if we are not defining this and we have no GCC type
457 for the containing record, make one for it. Then we should
458 have made our own equivalent. */
459 else if (!definition && !present_gnu_tree (gnat_record))
461 /* ??? If this is in a record whose scope is a protected
462 type and we have an Original_Record_Component, use it.
463 This is a workaround for major problems in protected type
465 Entity_Id Scop = Scope (Scope (gnat_entity));
466 if ((Is_Protected_Type (Scop)
467 || (Is_Private_Type (Scop)
468 && Present (Full_View (Scop))
469 && Is_Protected_Type (Full_View (Scop))))
470 && Present (Original_Record_Component (gnat_entity)))
473 = gnat_to_gnu_entity (Original_Record_Component
480 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
481 gnu_decl = get_gnu_tree (gnat_entity);
487 /* Here we have no GCC type and this is a reference rather than a
488 definition. This should never happen. Most likely the cause is a
489 reference before declaration in the gnat tree for gnat_entity. */
493 case E_Loop_Parameter:
494 case E_Out_Parameter:
497 /* Simple variables, loop variables, OUT parameters, and exceptions. */
500 bool used_by_ref = false;
502 = ((kind == E_Constant || kind == E_Variable)
503 && !Is_Statically_Allocated (gnat_entity)
504 && Is_True_Constant (gnat_entity)
505 && (((Nkind (Declaration_Node (gnat_entity))
506 == N_Object_Declaration)
507 && Present (Expression (Declaration_Node (gnat_entity))))
508 || Present (Renamed_Object (gnat_entity))));
509 bool inner_const_flag = const_flag;
510 bool static_p = Is_Statically_Allocated (gnat_entity);
511 bool mutable_p = false;
512 tree gnu_ext_name = NULL_TREE;
513 tree renamed_obj = NULL_TREE;
515 if (Present (Renamed_Object (gnat_entity)) && !definition)
517 if (kind == E_Exception)
518 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
521 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
524 /* Get the type after elaborating the renamed object. */
525 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
527 /* For a debug renaming declaration, build a pure debug entity. */
528 if (Present (Debug_Renaming_Link (gnat_entity)))
531 gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type);
532 /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
533 if (global_bindings_p ())
534 addr = gen_rtx_CONST (VOIDmode, const0_rtx);
536 addr = stack_pointer_rtx;
537 SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
538 gnat_pushdecl (gnu_decl, gnat_entity);
542 /* If this is a loop variable, its type should be the base type.
543 This is because the code for processing a loop determines whether
544 a normal loop end test can be done by comparing the bounds of the
545 loop against those of the base type, which is presumed to be the
546 size used for computation. But this is not correct when the size
547 of the subtype is smaller than the type. */
548 if (kind == E_Loop_Parameter)
549 gnu_type = get_base_type (gnu_type);
551 /* Reject non-renamed objects whose types are unconstrained arrays or
552 any object whose type is a dummy type or VOID_TYPE. */
554 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
555 && No (Renamed_Object (gnat_entity)))
556 || TYPE_IS_DUMMY_P (gnu_type)
557 || TREE_CODE (gnu_type) == VOID_TYPE)
559 gcc_assert (type_annotate_only);
562 return error_mark_node;
565 /* If an alignment is specified, use it if valid. Note that
566 exceptions are objects but don't have alignments. We must do this
567 before we validate the size, since the alignment can affect the
569 if (kind != E_Exception && Known_Alignment (gnat_entity))
571 gcc_assert (Present (Alignment (gnat_entity)));
572 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
573 TYPE_ALIGN (gnu_type));
574 gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
575 "PAD", false, definition, true);
578 /* If we are defining the object, see if it has a Size value and
579 validate it if so. If we are not defining the object and a Size
580 clause applies, simply retrieve the value. We don't want to ignore
581 the clause and it is expected to have been validated already. Then
582 get the new type, if any. */
584 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
585 gnat_entity, VAR_DECL, false,
586 Has_Size_Clause (gnat_entity));
587 else if (Has_Size_Clause (gnat_entity))
588 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
593 = make_type_from_size (gnu_type, gnu_size,
594 Has_Biased_Representation (gnat_entity));
596 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
597 gnu_size = NULL_TREE;
600 /* If this object has self-referential size, it must be a record with
601 a default value. We are supposed to allocate an object of the
602 maximum size in this case unless it is a constant with an
603 initializing expression, in which case we can get the size from
604 that. Note that the resulting size may still be a variable, so
605 this may end up with an indirect allocation. */
607 if (No (Renamed_Object (gnat_entity))
608 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
610 if (gnu_expr && kind == E_Constant)
612 = SUBSTITUTE_PLACEHOLDER_IN_EXPR
613 (TYPE_SIZE (TREE_TYPE (gnu_expr)), gnu_expr);
615 /* We may have no GNU_EXPR because No_Initialization is
616 set even though there's an Expression. */
617 else if (kind == E_Constant
618 && (Nkind (Declaration_Node (gnat_entity))
619 == N_Object_Declaration)
620 && Present (Expression (Declaration_Node (gnat_entity))))
622 = TYPE_SIZE (gnat_to_gnu_type
624 (Expression (Declaration_Node (gnat_entity)))));
627 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
632 /* If the size is zero bytes, make it one byte since some linkers have
633 trouble with zero-sized objects. If the object will have a
634 template, that will make it nonzero so don't bother. Also avoid
635 doing that for an object renaming or an object with an address
636 clause, as we would lose useful information on the view size
637 (e.g. for null array slices) and we are not allocating the object
639 if (((gnu_size && integer_zerop (gnu_size))
640 || (TYPE_SIZE (gnu_type) && integer_zerop (TYPE_SIZE (gnu_type))))
641 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
642 || !Is_Array_Type (Etype (gnat_entity)))
643 && !Present (Renamed_Object (gnat_entity))
644 && !Present (Address_Clause (gnat_entity)))
645 gnu_size = bitsize_unit_node;
647 /* If this is an atomic object with no specified size and alignment,
648 but where the size of the type is a constant, set the alignment to
649 the lowest power of two greater than the size, or to the
650 biggest meaningful alignment, whichever is smaller. */
652 if (Is_Atomic (gnat_entity) && !gnu_size && align == 0
653 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
655 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
656 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
658 align = BIGGEST_ALIGNMENT;
660 align = ((unsigned int) 1
661 << (floor_log2 (tree_low_cst
662 (TYPE_SIZE (gnu_type), 1) - 1)
666 /* If the object is set to have atomic components, find the component
667 type and validate it.
669 ??? Note that we ignore Has_Volatile_Components on objects; it's
670 not at all clear what to do in that case. */
672 if (Has_Atomic_Components (gnat_entity))
674 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
675 ? TREE_TYPE (gnu_type) : gnu_type);
677 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
678 && TYPE_MULTI_ARRAY_P (gnu_inner))
679 gnu_inner = TREE_TYPE (gnu_inner);
681 check_ok_for_atomic (gnu_inner, gnat_entity, true);
684 /* Now check if the type of the object allows atomic access. Note
685 that we must test the type, even if this object has size and
686 alignment to allow such access, because we will be going
687 inside the padded record to assign to the object. We could fix
688 this by always copying via an intermediate value, but it's not
689 clear it's worth the effort. */
690 if (Is_Atomic (gnat_entity))
691 check_ok_for_atomic (gnu_type, gnat_entity, false);
693 /* If this is an aliased object with an unconstrained nominal subtype,
694 make a type that includes the template. */
695 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
696 && Is_Array_Type (Etype (gnat_entity))
697 && !type_annotate_only)
700 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
703 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
704 concat_id_with_name (gnu_entity_id,
708 #ifdef MINIMUM_ATOMIC_ALIGNMENT
709 /* If the size is a constant and no alignment is specified, force
710 the alignment to be the minimum valid atomic alignment. The
711 restriction on constant size avoids problems with variable-size
712 temporaries; if the size is variable, there's no issue with
713 atomic access. Also don't do this for a constant, since it isn't
714 necessary and can interfere with constant replacement. Finally,
715 do not do it for Out parameters since that creates an
716 size inconsistency with In parameters. */
717 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
718 && !FLOAT_TYPE_P (gnu_type)
719 && !const_flag && No (Renamed_Object (gnat_entity))
720 && !imported_p && No (Address_Clause (gnat_entity))
721 && kind != E_Out_Parameter
722 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
723 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
724 align = MINIMUM_ATOMIC_ALIGNMENT;
727 /* Make a new type with the desired size and alignment, if needed. */
728 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
729 "PAD", false, definition, true);
731 /* Make a volatile version of this object's type if we are to make
732 the object volatile. We also interpret 13.3(19) conservatively
733 and disallow any optimizations for an object covered by it. */
734 if ((Treat_As_Volatile (gnat_entity)
735 || Is_Exported (gnat_entity)
736 || Is_Imported (gnat_entity)
737 || Present (Address_Clause (gnat_entity)))
738 && !TYPE_VOLATILE (gnu_type))
739 gnu_type = build_qualified_type (gnu_type,
740 (TYPE_QUALS (gnu_type)
741 | TYPE_QUAL_VOLATILE));
743 /* Convert the expression to the type of the object except in the
744 case where the object's type is unconstrained or the object's type
745 is a padded record whose field is of self-referential size. In
746 the former case, converting will generate unnecessary evaluations
747 of the CONSTRUCTOR to compute the size and in the latter case, we
748 want to only copy the actual data. */
750 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
751 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
752 && !(TREE_CODE (gnu_type) == RECORD_TYPE
753 && TYPE_IS_PADDING_P (gnu_type)
754 && (CONTAINS_PLACEHOLDER_P
755 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
756 gnu_expr = convert (gnu_type, gnu_expr);
758 /* If this is a renaming, avoid as much as possible to create a new
759 object. However, in several cases, creating it is required. */
760 if (Present (Renamed_Object (gnat_entity)))
762 bool create_normal_object = false;
764 /* If the renamed object had padding, strip off the reference
765 to the inner object and reset our type. */
766 if ((TREE_CODE (gnu_expr) == COMPONENT_REF
767 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
769 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
770 /* Strip useless conversions around the object. */
771 || TREE_CODE (gnu_expr) == NOP_EXPR)
773 gnu_expr = TREE_OPERAND (gnu_expr, 0);
774 gnu_type = TREE_TYPE (gnu_expr);
777 /* Case 1: If this is a constant renaming stemming from a function
778 call, treat it as a normal object whose initial value is what
779 is being renamed. RM 3.3 says that the result of evaluating a
780 function call is a constant object. As a consequence, it can
781 be the inner object of a constant renaming. In this case, the
782 renaming must be fully instantiated, i.e. it cannot be a mere
783 reference to (part of) an existing object. */
786 tree inner_object = gnu_expr;
787 while (handled_component_p (inner_object))
788 inner_object = TREE_OPERAND (inner_object, 0);
789 if (TREE_CODE (inner_object) == CALL_EXPR)
790 create_normal_object = true;
793 /* Otherwise, see if we can proceed with a stabilized version of
794 the renamed entity or if we need to make a new object. */
795 if (!create_normal_object)
797 tree maybe_stable_expr = NULL_TREE;
800 /* Case 2: If the renaming entity need not be materialized and
801 the renamed expression is something we can stabilize, use
802 that for the renaming. At the global level, we can only do
803 this if we know no SAVE_EXPRs need be made, because the
804 expression we return might be used in arbitrary conditional
805 branches so we must force the SAVE_EXPRs evaluation
806 immediately and this requires a function context. */
807 if (!Materialize_Entity (gnat_entity)
808 && (!global_bindings_p ()
809 || (staticp (gnu_expr)
810 && !TREE_SIDE_EFFECTS (gnu_expr))))
813 = maybe_stabilize_reference (gnu_expr, true, &stable);
817 gnu_decl = maybe_stable_expr;
818 /* ??? No DECL_EXPR is created so we need to mark
819 the expression manually lest it is shared. */
820 if (global_bindings_p ())
821 TREE_VISITED (gnu_decl) = 1;
822 save_gnu_tree (gnat_entity, gnu_decl, true);
827 /* The stabilization failed. Keep maybe_stable_expr
828 untouched here to let the pointer case below know
829 about that failure. */
832 /* Case 3: If this is a constant renaming and creating a
833 new object is allowed and cheap, treat it as a normal
834 object whose initial value is what is being renamed. */
835 if (const_flag && Is_Elementary_Type (Etype (gnat_entity)))
838 /* Case 4: Make this into a constant pointer to the object we
839 are to rename and attach the object to the pointer if it is
840 something we can stabilize.
842 From the proper scope, attached objects will be referenced
843 directly instead of indirectly via the pointer to avoid
844 subtle aliasing problems with non-addressable entities.
845 They have to be stable because we must not evaluate the
846 variables in the expression every time the renaming is used.
847 The pointer is called a "renaming" pointer in this case.
849 In the rare cases where we cannot stabilize the renamed
850 object, we just make a "bare" pointer, and the renamed
851 entity is always accessed indirectly through it. */
854 gnu_type = build_reference_type (gnu_type);
855 inner_const_flag = TREE_READONLY (gnu_expr);
858 /* If the previous attempt at stabilizing failed, there
859 is no point in trying again and we reuse the result
860 without attaching it to the pointer. In this case it
861 will only be used as the initializing expression of
862 the pointer and thus needs no special treatment with
863 regard to multiple evaluations. */
864 if (maybe_stable_expr)
867 /* Otherwise, try to stabilize and attach the expression
868 to the pointer if the stabilization succeeds.
870 Note that this might introduce SAVE_EXPRs and we don't
871 check whether we're at the global level or not. This
872 is fine since we are building a pointer initializer and
873 neither the pointer nor the initializing expression can
874 be accessed before the pointer elaboration has taken
875 place in a correct program.
877 These SAVE_EXPRs will be evaluated at the right place
878 by either the evaluation of the initializer for the
879 non-global case or the elaboration code for the global
880 case, and will be attached to the elaboration procedure
881 in the latter case. */
885 = maybe_stabilize_reference (gnu_expr, true, &stable);
888 renamed_obj = maybe_stable_expr;
890 /* Attaching is actually performed downstream, as soon
891 as we have a VAR_DECL for the pointer we make. */
895 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
897 gnu_size = NULL_TREE;
903 /* If this is an aliased object whose nominal subtype is unconstrained,
904 the object is a record that contains both the template and
905 the object. If there is an initializer, it will have already
906 been converted to the right type, but we need to create the
907 template if there is no initializer. */
908 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
909 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
910 /* Beware that padding might have been introduced
911 via maybe_pad_type above. */
912 || (TYPE_IS_PADDING_P (gnu_type)
913 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
915 && TYPE_CONTAINS_TEMPLATE_P
916 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
920 = TYPE_IS_PADDING_P (gnu_type)
921 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
922 : TYPE_FIELDS (gnu_type);
925 = gnat_build_constructor
929 build_template (TREE_TYPE (template_field),
930 TREE_TYPE (TREE_CHAIN (template_field)),
935 /* If this is a pointer and it does not have an initializing
936 expression, initialize it to NULL, unless the object is
939 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
940 && !Is_Imported (gnat_entity) && !gnu_expr)
941 gnu_expr = integer_zero_node;
943 /* If we are defining the object and it has an Address clause we must
944 get the address expression from the saved GCC tree for the
945 object if the object has a Freeze_Node. Otherwise, we elaborate
946 the address expression here since the front-end has guaranteed
947 in that case that the elaboration has no effects. Note that
948 only the latter mechanism is currently in use. */
949 if (definition && Present (Address_Clause (gnat_entity)))
952 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
953 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
955 save_gnu_tree (gnat_entity, NULL_TREE, false);
957 /* Ignore the size. It's either meaningless or was handled
959 gnu_size = NULL_TREE;
960 /* Convert the type of the object to a reference type that can
961 alias everything as per 13.3(19). */
963 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
964 gnu_address = convert (gnu_type, gnu_address);
966 const_flag = !Is_Public (gnat_entity);
968 /* If we don't have an initializing expression for the underlying
969 variable, the initializing expression for the pointer is the
970 specified address. Otherwise, we have to make a COMPOUND_EXPR
971 to assign both the address and the initial value. */
973 gnu_expr = gnu_address;
976 = build2 (COMPOUND_EXPR, gnu_type,
978 (MODIFY_EXPR, NULL_TREE,
979 build_unary_op (INDIRECT_REF, NULL_TREE,
985 /* If it has an address clause and we are not defining it, mark it
986 as an indirect object. Likewise for Stdcall objects that are
988 if ((!definition && Present (Address_Clause (gnat_entity)))
989 || (Is_Imported (gnat_entity)
990 && Has_Stdcall_Convention (gnat_entity)))
992 /* Convert the type of the object to a reference type that can
993 alias everything as per 13.3(19). */
995 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
996 gnu_size = NULL_TREE;
998 gnu_expr = NULL_TREE;
999 /* No point in taking the address of an initializing expression
1000 that isn't going to be used. */
1005 /* If we are at top level and this object is of variable size,
1006 make the actual type a hidden pointer to the real type and
1007 make the initializer be a memory allocation and initialization.
1008 Likewise for objects we aren't defining (presumed to be
1009 external references from other packages), but there we do
1010 not set up an initialization.
1012 If the object's size overflows, make an allocator too, so that
1013 Storage_Error gets raised. Note that we will never free
1014 such memory, so we presume it never will get allocated. */
1016 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1017 global_bindings_p () || !definition
1020 && ! allocatable_size_p (gnu_size,
1021 global_bindings_p () || !definition
1024 gnu_type = build_reference_type (gnu_type);
1025 gnu_size = NULL_TREE;
1029 /* In case this was a aliased object whose nominal subtype is
1030 unconstrained, the pointer above will be a thin pointer and
1031 build_allocator will automatically make the template.
1033 If we have a template initializer only (that we made above),
1034 pretend there is none and rely on what build_allocator creates
1035 again anyway. Otherwise (if we have a full initializer), get
1036 the data part and feed that to build_allocator.
1038 If we are elaborating a mutable object, tell build_allocator to
1039 ignore a possibly simpler size from the initializer, if any, as
1040 we must allocate the maximum possible size in this case. */
1044 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1046 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1047 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1050 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1052 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1053 && 1 == VEC_length (constructor_elt,
1054 CONSTRUCTOR_ELTS (gnu_expr)))
1058 = build_component_ref
1059 (gnu_expr, NULL_TREE,
1060 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1064 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1065 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1066 && !Is_Imported (gnat_entity))
1067 post_error ("?Storage_Error will be raised at run-time!",
1070 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1071 0, 0, gnat_entity, mutable_p);
1075 gnu_expr = NULL_TREE;
1080 /* If this object would go into the stack and has an alignment larger
1081 than the largest stack alignment the back-end can honor, resort to
1082 a variable of "aligning type". */
1083 if (!global_bindings_p () && !static_p && definition
1084 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1086 /* Create the new variable. No need for extra room before the
1087 aligned field as this is in automatic storage. */
1089 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1090 TYPE_SIZE_UNIT (gnu_type),
1091 BIGGEST_ALIGNMENT, 0);
1093 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1094 NULL_TREE, gnu_new_type, NULL_TREE, false,
1095 false, false, false, NULL, gnat_entity);
1097 /* Initialize the aligned field if we have an initializer. */
1100 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1102 (gnu_new_var, NULL_TREE,
1103 TYPE_FIELDS (gnu_new_type), false),
1107 /* And setup this entity as a reference to the aligned field. */
1108 gnu_type = build_reference_type (gnu_type);
1111 (ADDR_EXPR, gnu_type,
1112 build_component_ref (gnu_new_var, NULL_TREE,
1113 TYPE_FIELDS (gnu_new_type), false));
1115 gnu_size = NULL_TREE;
1121 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1122 | TYPE_QUAL_CONST));
1124 /* Convert the expression to the type of the object except in the
1125 case where the object's type is unconstrained or the object's type
1126 is a padded record whose field is of self-referential size. In
1127 the former case, converting will generate unnecessary evaluations
1128 of the CONSTRUCTOR to compute the size and in the latter case, we
1129 want to only copy the actual data. */
1131 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1132 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1133 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1134 && TYPE_IS_PADDING_P (gnu_type)
1135 && (CONTAINS_PLACEHOLDER_P
1136 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1137 gnu_expr = convert (gnu_type, gnu_expr);
1139 /* If this name is external or there was a name specified, use it,
1140 unless this is a VMS exception object since this would conflict
1141 with the symbol we need to export in addition. Don't use the
1142 Interface_Name if there is an address clause (see CD30005). */
1143 if (!Is_VMS_Exception (gnat_entity)
1144 && ((Present (Interface_Name (gnat_entity))
1145 && No (Address_Clause (gnat_entity)))
1146 || (Is_Public (gnat_entity)
1147 && (!Is_Imported (gnat_entity)
1148 || Is_Exported (gnat_entity)))))
1149 gnu_ext_name = create_concat_name (gnat_entity, 0);
1151 /* If this is constant initialized to a static constant and the
1152 object has an aggregate type, force it to be statically
1154 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1155 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1156 && (AGGREGATE_TYPE_P (gnu_type)
1157 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1158 && TYPE_IS_PADDING_P (gnu_type))))
1161 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1162 gnu_expr, const_flag,
1163 Is_Public (gnat_entity),
1164 imported_p || !definition,
1165 static_p, attr_list, gnat_entity);
1166 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1167 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1168 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1170 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1171 if (global_bindings_p ())
1173 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1174 record_global_renaming_pointer (gnu_decl);
1178 if (definition && DECL_SIZE (gnu_decl)
1179 && get_block_jmpbuf_decl ()
1180 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1181 || (flag_stack_check && !STACK_CHECK_BUILTIN
1182 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1183 STACK_CHECK_MAX_VAR_SIZE))))
1184 add_stmt_with_node (build_call_1_expr
1185 (update_setjmp_buf_decl,
1186 build_unary_op (ADDR_EXPR, NULL_TREE,
1187 get_block_jmpbuf_decl ())),
1190 /* If this is a public constant or we're not optimizing and we're not
1191 making a VAR_DECL for it, make one just for export or debugger use.
1192 Likewise if the address is taken or if either the object or type is
1193 aliased. Make an external declaration for a reference, unless this
1194 is a Standard entity since there no real symbol at the object level
1196 if (TREE_CODE (gnu_decl) == CONST_DECL
1197 && (definition || Sloc (gnat_entity) > Standard_Location)
1198 && (Is_Public (gnat_entity)
1200 || Address_Taken (gnat_entity)
1201 || Is_Aliased (gnat_entity)
1202 || Is_Aliased (Etype (gnat_entity))))
1205 = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1206 gnu_expr, true, Is_Public (gnat_entity),
1207 !definition, static_p, NULL,
1210 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1213 /* If this is declared in a block that contains a block with an
1214 exception handler, we must force this variable in memory to
1215 suppress an invalid optimization. */
1216 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1217 && Exception_Mechanism != Back_End_Exceptions)
1218 TREE_ADDRESSABLE (gnu_decl) = 1;
1220 gnu_type = TREE_TYPE (gnu_decl);
1222 /* Back-annotate Alignment and Esize of the object if not already
1223 known, except for when the object is actually a pointer to the
1224 real object, since alignment and size of a pointer don't have
1225 anything to do with those of the designated object. Note that
1226 we pick the values of the type, not those of the object, to
1227 shield ourselves from low-level platform-dependent adjustments
1228 like alignment promotion. This is both consistent with all the
1229 treatment above, where alignment and size are set on the type of
1230 the object and not on the object directly, and makes it possible
1231 to support confirming representation clauses in all cases. */
1233 if (!used_by_ref && Unknown_Alignment (gnat_entity))
1234 Set_Alignment (gnat_entity,
1235 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
1237 if (!used_by_ref && Unknown_Esize (gnat_entity))
1241 if (TREE_CODE (gnu_type) == RECORD_TYPE
1242 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
1244 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
1246 gnu_back_size = TYPE_SIZE (gnu_type);
1248 Set_Esize (gnat_entity, annotate_value (gnu_back_size));
1254 /* Return a TYPE_DECL for "void" that we previously made. */
1255 gnu_decl = void_type_decl_node;
1258 case E_Enumeration_Type:
1259 /* A special case, for the types Character and Wide_Character in
1260 Standard, we do not list all the literals. So if the literals
1261 are not specified, make this an unsigned type. */
1262 if (No (First_Literal (gnat_entity)))
1264 gnu_type = make_unsigned_type (esize);
1265 TYPE_NAME (gnu_type) = gnu_entity_id;
1267 /* Set the TYPE_STRING_FLAG for Ada Character and
1268 Wide_Character types. This is needed by the dwarf-2 debug writer to
1269 distinguish between unsigned integer types and character types. */
1270 TYPE_STRING_FLAG (gnu_type) = 1;
1274 /* Normal case of non-character type, or non-Standard character type */
1276 /* Here we have a list of enumeral constants in First_Literal.
1277 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1278 the list to be places into TYPE_FIELDS. Each node in the list
1279 is a TREE_LIST node whose TREE_VALUE is the literal name
1280 and whose TREE_PURPOSE is the value of the literal.
1282 Esize contains the number of bits needed to represent the enumeral
1283 type, Type_Low_Bound also points to the first literal and
1284 Type_High_Bound points to the last literal. */
1286 Entity_Id gnat_literal;
1287 tree gnu_literal_list = NULL_TREE;
1289 if (Is_Unsigned_Type (gnat_entity))
1290 gnu_type = make_unsigned_type (esize);
1292 gnu_type = make_signed_type (esize);
1294 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1296 for (gnat_literal = First_Literal (gnat_entity);
1297 Present (gnat_literal);
1298 gnat_literal = Next_Literal (gnat_literal))
1300 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1303 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1304 gnu_type, gnu_value, true, false, false,
1305 false, NULL, gnat_literal);
1307 save_gnu_tree (gnat_literal, gnu_literal, false);
1308 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1309 gnu_value, gnu_literal_list);
1312 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1314 /* Note that the bounds are updated at the end of this function
1315 because to avoid an infinite recursion when we get the bounds of
1316 this type, since those bounds are objects of this type. */
1320 case E_Signed_Integer_Type:
1321 case E_Ordinary_Fixed_Point_Type:
1322 case E_Decimal_Fixed_Point_Type:
1323 /* For integer types, just make a signed type the appropriate number
1325 gnu_type = make_signed_type (esize);
1328 case E_Modular_Integer_Type:
1329 /* For modular types, make the unsigned type of the proper number of
1330 bits and then set up the modulus, if required. */
1332 enum machine_mode mode;
1336 if (Is_Packed_Array_Type (gnat_entity))
1337 esize = UI_To_Int (RM_Size (gnat_entity));
1339 /* Find the smallest mode at least ESIZE bits wide and make a class
1342 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1343 GET_MODE_BITSIZE (mode) < esize;
1344 mode = GET_MODE_WIDER_MODE (mode))
1347 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1348 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1349 = Is_Packed_Array_Type (gnat_entity);
1351 /* Get the modulus in this type. If it overflows, assume it is because
1352 it is equal to 2**Esize. Note that there is no overflow checking
1353 done on unsigned type, so we detect the overflow by looking for
1354 a modulus of zero, which is otherwise invalid. */
1355 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1357 if (!integer_zerop (gnu_modulus))
1359 TYPE_MODULAR_P (gnu_type) = 1;
1360 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1361 gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1362 convert (gnu_type, integer_one_node));
1365 /* If we have to set TYPE_PRECISION different from its natural value,
1366 make a subtype to do do. Likewise if there is a modulus and
1367 it is not one greater than TYPE_MAX_VALUE. */
1368 if (TYPE_PRECISION (gnu_type) != esize
1369 || (TYPE_MODULAR_P (gnu_type)
1370 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1372 tree gnu_subtype = make_node (INTEGER_TYPE);
1374 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1375 TREE_TYPE (gnu_subtype) = gnu_type;
1376 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1377 TYPE_MAX_VALUE (gnu_subtype)
1378 = TYPE_MODULAR_P (gnu_type)
1379 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1380 TYPE_PRECISION (gnu_subtype) = esize;
1381 TYPE_UNSIGNED (gnu_subtype) = 1;
1382 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1383 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1384 = Is_Packed_Array_Type (gnat_entity);
1385 layout_type (gnu_subtype);
1387 gnu_type = gnu_subtype;
1392 case E_Signed_Integer_Subtype:
1393 case E_Enumeration_Subtype:
1394 case E_Modular_Integer_Subtype:
1395 case E_Ordinary_Fixed_Point_Subtype:
1396 case E_Decimal_Fixed_Point_Subtype:
1398 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1399 that we do not want to call build_range_type since we would
1400 like each subtype node to be distinct. This will be important
1401 when memory aliasing is implemented.
1403 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1404 parent type; this fact is used by the arithmetic conversion
1407 We elaborate the Ancestor_Subtype if it is not in the current
1408 unit and one of our bounds is non-static. We do this to ensure
1409 consistent naming in the case where several subtypes share the same
1410 bounds by always elaborating the first such subtype first, thus
1414 && Present (Ancestor_Subtype (gnat_entity))
1415 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1416 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1417 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1418 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1421 gnu_type = make_node (INTEGER_TYPE);
1422 if (Is_Packed_Array_Type (gnat_entity))
1424 esize = UI_To_Int (RM_Size (gnat_entity));
1425 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1428 TYPE_PRECISION (gnu_type) = esize;
1429 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1431 TYPE_MIN_VALUE (gnu_type)
1432 = convert (TREE_TYPE (gnu_type),
1433 elaborate_expression (Type_Low_Bound (gnat_entity),
1435 get_identifier ("L"), definition, 1,
1436 Needs_Debug_Info (gnat_entity)));
1438 TYPE_MAX_VALUE (gnu_type)
1439 = convert (TREE_TYPE (gnu_type),
1440 elaborate_expression (Type_High_Bound (gnat_entity),
1442 get_identifier ("U"), definition, 1,
1443 Needs_Debug_Info (gnat_entity)));
1445 /* One of the above calls might have caused us to be elaborated,
1446 so don't blow up if so. */
1447 if (present_gnu_tree (gnat_entity))
1449 maybe_present = true;
1453 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1454 = Has_Biased_Representation (gnat_entity);
1456 /* This should be an unsigned type if the lower bound is constant
1457 and non-negative or if the base type is unsigned; a signed type
1459 TYPE_UNSIGNED (gnu_type)
1460 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1461 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1462 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1463 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1464 || Is_Unsigned_Type (gnat_entity));
1466 layout_type (gnu_type);
1468 /* Inherit our alias set from what we're a subtype of. Subtypes
1469 are not different types and a pointer can designate any instance
1470 within a subtype hierarchy. */
1471 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1473 /* If the type we are dealing with is to represent a packed array,
1474 we need to have the bits left justified on big-endian targets
1475 and right justified on little-endian targets. We also need to
1476 ensure that when the value is read (e.g. for comparison of two
1477 such values), we only get the good bits, since the unused bits
1478 are uninitialized. Both goals are accomplished by wrapping the
1479 modular value in an enclosing struct. */
1480 if (Is_Packed_Array_Type (gnat_entity))
1482 tree gnu_field_type = gnu_type;
1485 TYPE_RM_SIZE_NUM (gnu_field_type)
1486 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1487 gnu_type = make_node (RECORD_TYPE);
1488 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1489 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1490 TYPE_USER_ALIGN (gnu_type) = TYPE_USER_ALIGN (gnu_field_type);
1491 TYPE_PACKED (gnu_type) = 1;
1493 /* Create a stripped-down declaration of the original type, mainly
1495 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1496 NULL, true, debug_info_p, gnat_entity);
1498 /* Don't notify the field as "addressable", since we won't be taking
1499 it's address and it would prevent create_field_decl from making a
1501 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1502 gnu_field_type, gnu_type, 1, 0, 0, 0);
1504 finish_record_type (gnu_type, gnu_field, 0, false);
1505 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1506 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1508 copy_alias_set (gnu_type, gnu_field_type);
1513 case E_Floating_Point_Type:
1514 /* If this is a VAX floating-point type, use an integer of the proper
1515 size. All the operations will be handled with ASM statements. */
1516 if (Vax_Float (gnat_entity))
1518 gnu_type = make_signed_type (esize);
1519 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1520 SET_TYPE_DIGITS_VALUE (gnu_type,
1521 UI_To_gnu (Digits_Value (gnat_entity),
1526 /* The type of the Low and High bounds can be our type if this is
1527 a type from Standard, so set them at the end of the function. */
1528 gnu_type = make_node (REAL_TYPE);
1529 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1530 layout_type (gnu_type);
1533 case E_Floating_Point_Subtype:
1534 if (Vax_Float (gnat_entity))
1536 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1542 && Present (Ancestor_Subtype (gnat_entity))
1543 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1544 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1545 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1546 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1549 gnu_type = make_node (REAL_TYPE);
1550 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1551 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1553 TYPE_MIN_VALUE (gnu_type)
1554 = convert (TREE_TYPE (gnu_type),
1555 elaborate_expression (Type_Low_Bound (gnat_entity),
1556 gnat_entity, get_identifier ("L"),
1558 Needs_Debug_Info (gnat_entity)));
1560 TYPE_MAX_VALUE (gnu_type)
1561 = convert (TREE_TYPE (gnu_type),
1562 elaborate_expression (Type_High_Bound (gnat_entity),
1563 gnat_entity, get_identifier ("U"),
1565 Needs_Debug_Info (gnat_entity)));
1567 /* One of the above calls might have caused us to be elaborated,
1568 so don't blow up if so. */
1569 if (present_gnu_tree (gnat_entity))
1571 maybe_present = true;
1575 layout_type (gnu_type);
1577 /* Inherit our alias set from what we're a subtype of, as for
1578 integer subtypes. */
1579 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1583 /* Array and String Types and Subtypes
1585 Unconstrained array types are represented by E_Array_Type and
1586 constrained array types are represented by E_Array_Subtype. There
1587 are no actual objects of an unconstrained array type; all we have
1588 are pointers to that type.
1590 The following fields are defined on array types and subtypes:
1592 Component_Type Component type of the array.
1593 Number_Dimensions Number of dimensions (an int).
1594 First_Index Type of first index. */
1599 tree gnu_template_fields = NULL_TREE;
1600 tree gnu_template_type = make_node (RECORD_TYPE);
1601 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1602 tree gnu_fat_type = make_node (RECORD_TYPE);
1603 int ndim = Number_Dimensions (gnat_entity);
1605 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1607 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1608 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1609 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1610 tree gnu_comp_size = 0;
1611 tree gnu_max_size = size_one_node;
1612 tree gnu_max_size_unit;
1614 Entity_Id gnat_ind_subtype;
1615 Entity_Id gnat_ind_base_subtype;
1616 tree gnu_template_reference;
1619 TYPE_NAME (gnu_template_type)
1620 = create_concat_name (gnat_entity, "XUB");
1622 /* Make a node for the array. If we are not defining the array
1623 suppress expanding incomplete types. */
1624 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1627 defer_incomplete_level++, this_deferred = true;
1629 /* Build the fat pointer type. Use a "void *" object instead of
1630 a pointer to the array type since we don't have the array type
1631 yet (it will reference the fat pointer via the bounds). */
1632 tem = chainon (chainon (NULL_TREE,
1633 create_field_decl (get_identifier ("P_ARRAY"),
1635 gnu_fat_type, 0, 0, 0, 0)),
1636 create_field_decl (get_identifier ("P_BOUNDS"),
1638 gnu_fat_type, 0, 0, 0, 0));
1640 /* Make sure we can put this into a register. */
1641 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1643 /* Do not finalize this record type since the types of its fields
1644 are still incomplete at this point. */
1645 finish_record_type (gnu_fat_type, tem, 0, true);
1646 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1648 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1649 is the fat pointer. This will be used to access the individual
1650 fields once we build them. */
1651 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1652 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1653 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1654 gnu_template_reference
1655 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1656 TREE_READONLY (gnu_template_reference) = 1;
1658 /* Now create the GCC type for each index and add the fields for
1659 that index to the template. */
1660 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1661 gnat_ind_base_subtype
1662 = First_Index (Implementation_Base_Type (gnat_entity));
1663 index < ndim && index >= 0;
1665 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1666 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1668 char field_name[10];
1669 tree gnu_ind_subtype
1670 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1671 tree gnu_base_subtype
1672 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1674 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1676 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1677 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1679 /* Make the FIELD_DECLs for the minimum and maximum of this
1680 type and then make extractions of that field from the
1682 sprintf (field_name, "LB%d", index);
1683 gnu_min_field = create_field_decl (get_identifier (field_name),
1685 gnu_template_type, 0, 0, 0, 0);
1686 field_name[0] = 'U';
1687 gnu_max_field = create_field_decl (get_identifier (field_name),
1689 gnu_template_type, 0, 0, 0, 0);
1691 Sloc_to_locus (Sloc (gnat_entity),
1692 &DECL_SOURCE_LOCATION (gnu_min_field));
1693 Sloc_to_locus (Sloc (gnat_entity),
1694 &DECL_SOURCE_LOCATION (gnu_max_field));
1695 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1697 /* We can't use build_component_ref here since the template
1698 type isn't complete yet. */
1699 gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
1700 gnu_template_reference, gnu_min_field,
1702 gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
1703 gnu_template_reference, gnu_max_field,
1705 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1707 /* Make a range type with the new ranges, but using
1708 the Ada subtype. Then we convert to sizetype. */
1709 gnu_index_types[index]
1710 = create_index_type (convert (sizetype, gnu_min),
1711 convert (sizetype, gnu_max),
1712 build_range_type (gnu_ind_subtype,
1715 /* Update the maximum size of the array, in elements. */
1717 = size_binop (MULT_EXPR, gnu_max_size,
1718 size_binop (PLUS_EXPR, size_one_node,
1719 size_binop (MINUS_EXPR, gnu_base_max,
1722 TYPE_NAME (gnu_index_types[index])
1723 = create_concat_name (gnat_entity, field_name);
1726 for (index = 0; index < ndim; index++)
1728 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1730 /* Install all the fields into the template. */
1731 finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
1732 TYPE_READONLY (gnu_template_type) = 1;
1734 /* Now make the array of arrays and update the pointer to the array
1735 in the fat pointer. Note that it is the first field. */
1736 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1738 /* Get and validate any specified Component_Size, but if Packed,
1739 ignore it since the front end will have taken care of it. */
1741 = validate_size (Component_Size (gnat_entity), tem,
1743 (Is_Bit_Packed_Array (gnat_entity)
1744 ? TYPE_DECL : VAR_DECL),
1745 true, Has_Component_Size_Clause (gnat_entity));
1747 if (Has_Atomic_Components (gnat_entity))
1748 check_ok_for_atomic (tem, gnat_entity, true);
1750 /* If the component type is a RECORD_TYPE that has a self-referential
1751 size, use the maxium size. */
1752 if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
1753 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1754 gnu_comp_size = max_size (TYPE_SIZE (tem), true);
1756 if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
1759 tem = make_type_from_size (tem, gnu_comp_size, false);
1761 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1762 "C_PAD", false, definition, true);
1763 /* If a padding record was made, declare it now since it will
1764 never be declared otherwise. This is necessary in order to
1765 ensure that its subtrees are properly marked. */
1766 if (tem != orig_tem)
1767 create_type_decl (TYPE_NAME (tem), tem, NULL, true, false,
1771 if (Has_Volatile_Components (gnat_entity))
1772 tem = build_qualified_type (tem,
1773 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1775 /* If Component_Size is not already specified, annotate it with the
1776 size of the component. */
1777 if (Unknown_Component_Size (gnat_entity))
1778 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1780 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1781 size_binop (MULT_EXPR, gnu_max_size,
1782 TYPE_SIZE_UNIT (tem)));
1783 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1784 size_binop (MULT_EXPR,
1785 convert (bitsizetype,
1789 for (index = ndim - 1; index >= 0; index--)
1791 tem = build_array_type (tem, gnu_index_types[index]);
1792 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1793 if (array_type_has_nonaliased_component (gnat_entity, tem))
1794 TYPE_NONALIASED_COMPONENT (tem) = 1;
1797 /* If an alignment is specified, use it if valid. But ignore it for
1798 types that represent the unpacked base type for packed arrays. */
1799 if (No (Packed_Array_Type (gnat_entity))
1800 && Known_Alignment (gnat_entity))
1802 gcc_assert (Present (Alignment (gnat_entity)));
1804 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1808 TYPE_CONVENTION_FORTRAN_P (tem)
1809 = (Convention (gnat_entity) == Convention_Fortran);
1810 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1812 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1813 corresponding fat pointer. */
1814 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1815 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1816 TYPE_MODE (gnu_type) = BLKmode;
1817 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1818 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1820 /* If the maximum size doesn't overflow, use it. */
1821 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1822 && !TREE_OVERFLOW (gnu_max_size))
1824 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
1825 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1826 && !TREE_OVERFLOW (gnu_max_size_unit))
1827 TYPE_SIZE_UNIT (tem)
1828 = size_binop (MIN_EXPR, gnu_max_size_unit,
1829 TYPE_SIZE_UNIT (tem));
1831 create_type_decl (create_concat_name (gnat_entity, "XUA"),
1832 tem, NULL, !Comes_From_Source (gnat_entity),
1833 debug_info_p, gnat_entity);
1835 /* Give the fat pointer type a name. */
1836 create_type_decl (create_concat_name (gnat_entity, "XUP"),
1837 gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
1838 debug_info_p, gnat_entity);
1840 /* Create the type to be used as what a thin pointer designates: an
1841 record type for the object and its template with the field offsets
1842 shifted to have the template at a negative offset. */
1843 tem = build_unc_object_type (gnu_template_type, tem,
1844 create_concat_name (gnat_entity, "XUT"));
1845 shift_unc_components_for_thin_pointers (tem);
1847 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
1848 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
1850 /* Give the thin pointer type a name. */
1851 create_type_decl (create_concat_name (gnat_entity, "XUX"),
1852 build_pointer_type (tem), NULL,
1853 !Comes_From_Source (gnat_entity), debug_info_p,
1858 case E_String_Subtype:
1859 case E_Array_Subtype:
1861 /* This is the actual data type for array variables. Multidimensional
1862 arrays are implemented in the gnu tree as arrays of arrays. Note
1863 that for the moment arrays which have sparse enumeration subtypes as
1864 index components create sparse arrays, which is obviously space
1865 inefficient but so much easier to code for now.
1867 Also note that the subtype never refers to the unconstrained
1868 array type, which is somewhat at variance with Ada semantics.
1870 First check to see if this is simply a renaming of the array
1871 type. If so, the result is the array type. */
1873 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1874 if (!Is_Constrained (gnat_entity))
1879 int array_dim = Number_Dimensions (gnat_entity);
1881 = ((Convention (gnat_entity) == Convention_Fortran)
1882 ? array_dim - 1 : 0);
1884 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
1885 Entity_Id gnat_ind_subtype;
1886 Entity_Id gnat_ind_base_subtype;
1887 tree gnu_base_type = gnu_type;
1888 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
1889 tree gnu_comp_size = NULL_TREE;
1890 tree gnu_max_size = size_one_node;
1891 tree gnu_max_size_unit;
1892 bool need_index_type_struct = false;
1893 bool max_overflow = false;
1895 /* First create the gnu types for each index. Create types for
1896 debugging information to point to the index types if the
1897 are not integer types, have variable bounds, or are
1898 wider than sizetype. */
1900 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
1901 gnat_ind_base_subtype
1902 = First_Index (Implementation_Base_Type (gnat_entity));
1903 index < array_dim && index >= 0;
1905 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1906 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1908 tree gnu_index_subtype
1909 = get_unpadded_type (Etype (gnat_ind_subtype));
1911 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
1913 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
1914 tree gnu_base_subtype
1915 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1917 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1919 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1920 tree gnu_base_type = get_base_type (gnu_base_subtype);
1921 tree gnu_base_base_min
1922 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
1923 tree gnu_base_base_max
1924 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
1928 /* If the minimum and maximum values both overflow in
1929 SIZETYPE, but the difference in the original type
1930 does not overflow in SIZETYPE, ignore the overflow
1932 if ((TYPE_PRECISION (gnu_index_subtype)
1933 > TYPE_PRECISION (sizetype)
1934 || TYPE_UNSIGNED (gnu_index_subtype)
1935 != TYPE_UNSIGNED (sizetype))
1936 && TREE_CODE (gnu_min) == INTEGER_CST
1937 && TREE_CODE (gnu_max) == INTEGER_CST
1938 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
1940 (fold_build2 (MINUS_EXPR, gnu_index_subtype,
1941 TYPE_MAX_VALUE (gnu_index_subtype),
1942 TYPE_MIN_VALUE (gnu_index_subtype)))))
1944 TREE_OVERFLOW (gnu_min) = 0;
1945 TREE_OVERFLOW (gnu_max) = 0;
1948 /* Similarly, if the range is null, use bounds of 1..0 for
1949 the sizetype bounds. */
1950 else if ((TYPE_PRECISION (gnu_index_subtype)
1951 > TYPE_PRECISION (sizetype)
1952 || TYPE_UNSIGNED (gnu_index_subtype)
1953 != TYPE_UNSIGNED (sizetype))
1954 && TREE_CODE (gnu_min) == INTEGER_CST
1955 && TREE_CODE (gnu_max) == INTEGER_CST
1956 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
1957 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
1958 TYPE_MIN_VALUE (gnu_index_subtype)))
1959 gnu_min = size_one_node, gnu_max = size_zero_node;
1961 /* Now compute the size of this bound. We need to provide
1962 GCC with an upper bound to use but have to deal with the
1963 "superflat" case. There are three ways to do this. If we
1964 can prove that the array can never be superflat, we can
1965 just use the high bound of the index subtype. If we can
1966 prove that the low bound minus one can't overflow, we
1967 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1968 the expression hb >= lb ? hb : lb - 1. */
1969 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
1971 /* See if the base array type is already flat. If it is, we
1972 are probably compiling an ACVC test, but it will cause the
1973 code below to malfunction if we don't handle it specially. */
1974 if (TREE_CODE (gnu_base_min) == INTEGER_CST
1975 && TREE_CODE (gnu_base_max) == INTEGER_CST
1976 && !TREE_OVERFLOW (gnu_base_min)
1977 && !TREE_OVERFLOW (gnu_base_max)
1978 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
1979 gnu_high = size_zero_node, gnu_min = size_one_node;
1981 /* If gnu_high is now an integer which overflowed, the array
1982 cannot be superflat. */
1983 else if (TREE_CODE (gnu_high) == INTEGER_CST
1984 && TREE_OVERFLOW (gnu_high))
1986 else if (TYPE_UNSIGNED (gnu_base_subtype)
1987 || TREE_CODE (gnu_high) == INTEGER_CST)
1988 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
1992 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
1996 gnu_index_type[index]
1997 = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
2000 /* Also compute the maximum size of the array. Here we
2001 see if any constraint on the index type of the base type
2002 can be used in the case of self-referential bound on
2003 the index type of the subtype. We look for a non-"infinite"
2004 and non-self-referential bound from any type involved and
2005 handle each bound separately. */
2007 if ((TREE_CODE (gnu_min) == INTEGER_CST
2008 && !TREE_OVERFLOW (gnu_min)
2009 && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
2010 || !CONTAINS_PLACEHOLDER_P (gnu_min)
2011 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
2012 && !TREE_OVERFLOW (gnu_base_min)))
2013 gnu_base_min = gnu_min;
2015 if ((TREE_CODE (gnu_max) == INTEGER_CST
2016 && !TREE_OVERFLOW (gnu_max)
2017 && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
2018 || !CONTAINS_PLACEHOLDER_P (gnu_max)
2019 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
2020 && !TREE_OVERFLOW (gnu_base_max)))
2021 gnu_base_max = gnu_max;
2023 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
2024 && TREE_OVERFLOW (gnu_base_min))
2025 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
2026 || (TREE_CODE (gnu_base_max) == INTEGER_CST
2027 && TREE_OVERFLOW (gnu_base_max))
2028 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
2029 max_overflow = true;
2031 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
2032 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
2035 = size_binop (MAX_EXPR,
2036 size_binop (PLUS_EXPR, size_one_node,
2037 size_binop (MINUS_EXPR, gnu_base_max,
2041 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2042 && TREE_OVERFLOW (gnu_this_max))
2043 max_overflow = true;
2046 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2048 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
2049 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
2051 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
2052 || (TREE_TYPE (gnu_index_subtype)
2053 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
2055 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
2056 || (TYPE_PRECISION (gnu_index_subtype)
2057 > TYPE_PRECISION (sizetype)))
2058 need_index_type_struct = true;
2061 /* Then flatten: create the array of arrays. */
2063 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
2065 /* One of the above calls might have caused us to be elaborated,
2066 so don't blow up if so. */
2067 if (present_gnu_tree (gnat_entity))
2069 maybe_present = true;
2073 /* Get and validate any specified Component_Size, but if Packed,
2074 ignore it since the front end will have taken care of it. */
2076 = validate_size (Component_Size (gnat_entity), gnu_type,
2078 (Is_Bit_Packed_Array (gnat_entity)
2079 ? TYPE_DECL : VAR_DECL),
2080 true, Has_Component_Size_Clause (gnat_entity));
2082 /* If the component type is a RECORD_TYPE that has a self-referential
2083 size, use the maxium size. */
2084 if (!gnu_comp_size && TREE_CODE (gnu_type) == RECORD_TYPE
2085 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2086 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
2088 if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
2091 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
2092 orig_gnu_type = gnu_type;
2093 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
2094 gnat_entity, "C_PAD", false,
2096 /* If a padding record was made, declare it now since it will
2097 never be declared otherwise. This is necessary in order to
2098 ensure that its subtrees are properly marked. */
2099 if (gnu_type != orig_gnu_type)
2100 create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
2101 false, gnat_entity);
2104 if (Has_Volatile_Components (Base_Type (gnat_entity)))
2105 gnu_type = build_qualified_type (gnu_type,
2106 (TYPE_QUALS (gnu_type)
2107 | TYPE_QUAL_VOLATILE));
2109 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2110 TYPE_SIZE_UNIT (gnu_type));
2111 gnu_max_size = size_binop (MULT_EXPR,
2112 convert (bitsizetype, gnu_max_size),
2113 TYPE_SIZE (gnu_type));
2115 for (index = array_dim - 1; index >= 0; index --)
2117 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
2118 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2119 if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
2120 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2123 /* If we are at file level and this is a multi-dimensional array, we
2124 need to make a variable corresponding to the stride of the
2125 inner dimensions. */
2126 if (global_bindings_p () && array_dim > 1)
2128 tree gnu_str_name = get_identifier ("ST");
2131 for (gnu_arr_type = TREE_TYPE (gnu_type);
2132 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2133 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2134 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
2136 tree eltype = TREE_TYPE (gnu_arr_type);
2138 TYPE_SIZE (gnu_arr_type)
2139 = elaborate_expression_1 (gnat_entity, gnat_entity,
2140 TYPE_SIZE (gnu_arr_type),
2141 gnu_str_name, definition, 0);
2143 /* ??? For now, store the size as a multiple of the
2144 alignment of the element type in bytes so that we
2145 can see the alignment from the tree. */
2146 TYPE_SIZE_UNIT (gnu_arr_type)
2148 (MULT_EXPR, sizetype,
2149 elaborate_expression_1
2150 (gnat_entity, gnat_entity,
2151 build_binary_op (EXACT_DIV_EXPR, sizetype,
2152 TYPE_SIZE_UNIT (gnu_arr_type),
2153 size_int (TYPE_ALIGN (eltype)
2155 concat_id_with_name (gnu_str_name, "A_U"),
2157 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2159 /* ??? create_type_decl is not invoked on the inner types so
2160 the MULT_EXPR node built above will never be marked. */
2161 TREE_VISITED (TYPE_SIZE_UNIT (gnu_arr_type)) = 1;
2165 /* If we need to write out a record type giving the names of
2166 the bounds, do it now. */
2167 if (need_index_type_struct && debug_info_p)
2169 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
2170 tree gnu_field_list = NULL_TREE;
2173 TYPE_NAME (gnu_bound_rec_type)
2174 = create_concat_name (gnat_entity, "XA");
2176 for (index = array_dim - 1; index >= 0; index--)
2179 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2181 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2182 gnu_type_name = DECL_NAME (gnu_type_name);
2184 gnu_field = create_field_decl (gnu_type_name,
2187 0, NULL_TREE, NULL_TREE, 0);
2188 TREE_CHAIN (gnu_field) = gnu_field_list;
2189 gnu_field_list = gnu_field;
2192 finish_record_type (gnu_bound_rec_type, gnu_field_list,
2196 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2197 = (Convention (gnat_entity) == Convention_Fortran);
2198 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2199 = Is_Packed_Array_Type (gnat_entity);
2201 /* If our size depends on a placeholder and the maximum size doesn't
2202 overflow, use it. */
2203 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2204 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2205 && TREE_OVERFLOW (gnu_max_size))
2206 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2207 && TREE_OVERFLOW (gnu_max_size_unit))
2210 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2211 TYPE_SIZE (gnu_type));
2212 TYPE_SIZE_UNIT (gnu_type)
2213 = size_binop (MIN_EXPR, gnu_max_size_unit,
2214 TYPE_SIZE_UNIT (gnu_type));
2217 /* Set our alias set to that of our base type. This gives all
2218 array subtypes the same alias set. */
2219 copy_alias_set (gnu_type, gnu_base_type);
2222 /* If this is a packed type, make this type the same as the packed
2223 array type, but do some adjusting in the type first. */
2225 if (Present (Packed_Array_Type (gnat_entity)))
2227 Entity_Id gnat_index;
2228 tree gnu_inner_type;
2230 /* First finish the type we had been making so that we output
2231 debugging information for it */
2233 = build_qualified_type (gnu_type,
2234 (TYPE_QUALS (gnu_type)
2235 | (TYPE_QUAL_VOLATILE
2236 * Treat_As_Volatile (gnat_entity))));
2237 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2238 !Comes_From_Source (gnat_entity),
2239 debug_info_p, gnat_entity);
2240 if (!Comes_From_Source (gnat_entity))
2241 DECL_ARTIFICIAL (gnu_decl) = 1;
2243 /* Save it as our equivalent in case the call below elaborates
2245 save_gnu_tree (gnat_entity, gnu_decl, false);
2247 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2249 this_made_decl = true;
2250 gnu_type = TREE_TYPE (gnu_decl);
2251 save_gnu_tree (gnat_entity, NULL_TREE, false);
2253 gnu_inner_type = gnu_type;
2254 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2255 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
2256 || TYPE_IS_PADDING_P (gnu_inner_type)))
2257 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2259 /* We need to point the type we just made to our index type so
2260 the actual bounds can be put into a template. */
2262 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2263 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
2264 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2265 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2267 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2269 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2270 If it is, we need to make another type. */
2271 if (TYPE_MODULAR_P (gnu_inner_type))
2275 gnu_subtype = make_node (INTEGER_TYPE);
2277 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2278 TYPE_MIN_VALUE (gnu_subtype)
2279 = TYPE_MIN_VALUE (gnu_inner_type);
2280 TYPE_MAX_VALUE (gnu_subtype)
2281 = TYPE_MAX_VALUE (gnu_inner_type);
2282 TYPE_PRECISION (gnu_subtype)
2283 = TYPE_PRECISION (gnu_inner_type);
2284 TYPE_UNSIGNED (gnu_subtype)
2285 = TYPE_UNSIGNED (gnu_inner_type);
2286 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2287 layout_type (gnu_subtype);
2289 gnu_inner_type = gnu_subtype;
2292 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2295 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2297 for (gnat_index = First_Index (gnat_entity);
2298 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2299 SET_TYPE_ACTUAL_BOUNDS
2301 tree_cons (NULL_TREE,
2302 get_unpadded_type (Etype (gnat_index)),
2303 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2305 if (Convention (gnat_entity) != Convention_Fortran)
2306 SET_TYPE_ACTUAL_BOUNDS
2308 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2310 if (TREE_CODE (gnu_type) == RECORD_TYPE
2311 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2312 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2316 /* Abort if packed array with no packed array type field set. */
2318 gcc_assert (!Is_Packed (gnat_entity));
2322 case E_String_Literal_Subtype:
2323 /* Create the type for a string literal. */
2325 Entity_Id gnat_full_type
2326 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2327 && Present (Full_View (Etype (gnat_entity)))
2328 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2329 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2330 tree gnu_string_array_type
2331 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2332 tree gnu_string_index_type
2333 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2334 (TYPE_DOMAIN (gnu_string_array_type))));
2335 tree gnu_lower_bound
2336 = convert (gnu_string_index_type,
2337 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2338 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2339 tree gnu_length = ssize_int (length - 1);
2340 tree gnu_upper_bound
2341 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2343 convert (gnu_string_index_type, gnu_length));
2345 = build_range_type (gnu_string_index_type,
2346 gnu_lower_bound, gnu_upper_bound);
2348 = create_index_type (convert (sizetype,
2349 TYPE_MIN_VALUE (gnu_range_type)),
2351 TYPE_MAX_VALUE (gnu_range_type)),
2352 gnu_range_type, gnat_entity);
2355 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2357 copy_alias_set (gnu_type, gnu_string_type);
2361 /* Record Types and Subtypes
2363 The following fields are defined on record types:
2365 Has_Discriminants True if the record has discriminants
2366 First_Discriminant Points to head of list of discriminants
2367 First_Entity Points to head of list of fields
2368 Is_Tagged_Type True if the record is tagged
2370 Implementation of Ada records and discriminated records:
2372 A record type definition is transformed into the equivalent of a C
2373 struct definition. The fields that are the discriminants which are
2374 found in the Full_Type_Declaration node and the elements of the
2375 Component_List found in the Record_Type_Definition node. The
2376 Component_List can be a recursive structure since each Variant of
2377 the Variant_Part of the Component_List has a Component_List.
2379 Processing of a record type definition comprises starting the list of
2380 field declarations here from the discriminants and the calling the
2381 function components_to_record to add the rest of the fields from the
2382 component list and return the gnu type node. The function
2383 components_to_record will call itself recursively as it traverses
2387 if (Has_Complex_Representation (gnat_entity))
2390 = build_complex_type
2392 (Etype (Defining_Entity
2393 (First (Component_Items
2396 (Declaration_Node (gnat_entity)))))))));
2402 Node_Id full_definition = Declaration_Node (gnat_entity);
2403 Node_Id record_definition = Type_Definition (full_definition);
2404 Entity_Id gnat_field;
2406 tree gnu_field_list = NULL_TREE;
2407 tree gnu_get_parent;
2409 = Is_Packed (gnat_entity)
2411 : Component_Alignment (gnat_entity) == Calign_Storage_Unit
2413 : Known_Alignment (gnat_entity)
2416 bool has_rep = Has_Specified_Layout (gnat_entity);
2417 bool all_rep = has_rep;
2419 = (Is_Tagged_Type (gnat_entity)
2420 && Nkind (record_definition) == N_Derived_Type_Definition);
2422 /* See if all fields have a rep clause. Stop when we find one
2424 for (gnat_field = First_Entity (gnat_entity);
2425 Present (gnat_field) && all_rep;
2426 gnat_field = Next_Entity (gnat_field))
2427 if ((Ekind (gnat_field) == E_Component
2428 || Ekind (gnat_field) == E_Discriminant)
2429 && No (Component_Clause (gnat_field)))
2432 /* If this is a record extension, go a level further to find the
2433 record definition. Also, verify we have a Parent_Subtype. */
2436 if (!type_annotate_only
2437 || Present (Record_Extension_Part (record_definition)))
2438 record_definition = Record_Extension_Part (record_definition);
2440 gcc_assert (type_annotate_only
2441 || Present (Parent_Subtype (gnat_entity)));
2444 /* Make a node for the record. If we are not defining the record,
2445 suppress expanding incomplete types. */
2446 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2447 TYPE_NAME (gnu_type) = gnu_entity_id;
2448 TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
2451 defer_incomplete_level++, this_deferred = true;
2453 /* If both a size and rep clause was specified, put the size in
2454 the record type now so that it can get the proper mode. */
2455 if (has_rep && Known_Esize (gnat_entity))
2456 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2458 /* Always set the alignment here so that it can be used to
2459 set the mode, if it is making the alignment stricter. If
2460 it is invalid, it will be checked again below. If this is to
2461 be Atomic, choose a default alignment of a word unless we know
2462 the size and it's smaller. */
2463 if (Known_Alignment (gnat_entity))
2464 TYPE_ALIGN (gnu_type)
2465 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2466 else if (Is_Atomic (gnat_entity))
2467 TYPE_ALIGN (gnu_type)
2468 = (esize >= BITS_PER_WORD ? BITS_PER_WORD
2469 : 1 << (floor_log2 (esize - 1) + 1));
2471 TYPE_ALIGN (gnu_type) = 0;
2473 /* If we have a Parent_Subtype, make a field for the parent. If
2474 this record has rep clauses, force the position to zero. */
2475 if (Present (Parent_Subtype (gnat_entity)))
2477 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2480 /* A major complexity here is that the parent subtype will
2481 reference our discriminants in its Discriminant_Constraint
2482 list. But those must reference the parent component of this
2483 record which is of the parent subtype we have not built yet!
2484 To break the circle we first build a dummy COMPONENT_REF which
2485 represents the "get to the parent" operation and initialize
2486 each of those discriminants to a COMPONENT_REF of the above
2487 dummy parent referencing the corresponding discriminant of the
2488 base type of the parent subtype. */
2489 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2490 build0 (PLACEHOLDER_EXPR, gnu_type),
2491 build_decl (FIELD_DECL, NULL_TREE,
2495 if (Has_Discriminants (gnat_entity))
2496 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2497 Present (gnat_field);
2498 gnat_field = Next_Stored_Discriminant (gnat_field))
2499 if (Present (Corresponding_Discriminant (gnat_field)))
2502 build3 (COMPONENT_REF,
2503 get_unpadded_type (Etype (gnat_field)),
2505 gnat_to_gnu_field_decl (Corresponding_Discriminant
2510 /* Then we build the parent subtype. */
2511 gnu_parent = gnat_to_gnu_type (gnat_parent);
2513 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2514 initially built. The discriminants must reference the fields
2515 of the parent subtype and not those of its base type for the
2516 placeholder machinery to properly work. */
2517 if (Has_Discriminants (gnat_entity))
2518 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2519 Present (gnat_field);
2520 gnat_field = Next_Stored_Discriminant (gnat_field))
2521 if (Present (Corresponding_Discriminant (gnat_field)))
2523 Entity_Id field = Empty;
2524 for (field = First_Stored_Discriminant (gnat_parent);
2526 field = Next_Stored_Discriminant (field))
2527 if (same_discriminant_p (gnat_field, field))
2529 gcc_assert (Present (field));
2530 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2531 = gnat_to_gnu_field_decl (field);
2534 /* The "get to the parent" COMPONENT_REF must be given its
2536 TREE_TYPE (gnu_get_parent) = gnu_parent;
2538 /* ...and reference the _parent field of this record. */
2540 = create_field_decl (get_identifier
2541 (Get_Name_String (Name_uParent)),
2542 gnu_parent, gnu_type, 0,
2543 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2544 has_rep ? bitsize_zero_node : 0, 1);
2545 DECL_INTERNAL_P (gnu_field_list) = 1;
2546 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2549 /* Make the fields for the discriminants and put them into the record
2550 unless it's an Unchecked_Union. */
2551 if (Has_Discriminants (gnat_entity))
2552 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2553 Present (gnat_field);
2554 gnat_field = Next_Stored_Discriminant (gnat_field))
2556 /* If this is a record extension and this discriminant
2557 is the renaming of another discriminant, we've already
2558 handled the discriminant above. */
2559 if (Present (Parent_Subtype (gnat_entity))
2560 && Present (Corresponding_Discriminant (gnat_field)))
2564 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2566 /* Make an expression using a PLACEHOLDER_EXPR from the
2567 FIELD_DECL node just created and link that with the
2568 corresponding GNAT defining identifier. Then add to the
2570 save_gnu_tree (gnat_field,
2571 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2572 build0 (PLACEHOLDER_EXPR,
2573 DECL_CONTEXT (gnu_field)),
2574 gnu_field, NULL_TREE),
2577 if (!Is_Unchecked_Union (gnat_entity))
2579 TREE_CHAIN (gnu_field) = gnu_field_list;
2580 gnu_field_list = gnu_field;
2584 /* Put the discriminants into the record (backwards), so we can
2585 know the appropriate discriminant to use for the names of the
2587 TYPE_FIELDS (gnu_type) = gnu_field_list;
2589 /* Add the listed fields into the record and finish it up. */
2590 components_to_record (gnu_type, Component_List (record_definition),
2591 gnu_field_list, packed, definition, NULL,
2592 false, all_rep, false,
2593 Is_Unchecked_Union (gnat_entity));
2595 /* We used to remove the associations of the discriminants and
2596 _Parent for validity checking, but we may need them if there's
2597 Freeze_Node for a subtype used in this record. */
2598 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2599 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2601 /* If it is a tagged record force the type to BLKmode to insure
2602 that these objects will always be placed in memory. Do the
2603 same thing for limited record types. */
2604 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2605 TYPE_MODE (gnu_type) = BLKmode;
2607 /* If this is a derived type, we must make the alias set of this type
2608 the same as that of the type we are derived from. We assume here
2609 that the other type is already frozen. */
2610 if (Etype (gnat_entity) != gnat_entity
2611 && !(Is_Private_Type (Etype (gnat_entity))
2612 && Full_View (Etype (gnat_entity)) == gnat_entity))
2613 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2615 /* Fill in locations of fields. */
2616 annotate_rep (gnat_entity, gnu_type);
2618 /* If there are any entities in the chain corresponding to
2619 components that we did not elaborate, ensure we elaborate their
2620 types if they are Itypes. */
2621 for (gnat_temp = First_Entity (gnat_entity);
2622 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2623 if ((Ekind (gnat_temp) == E_Component
2624 || Ekind (gnat_temp) == E_Discriminant)
2625 && Is_Itype (Etype (gnat_temp))
2626 && !present_gnu_tree (gnat_temp))
2627 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2631 case E_Class_Wide_Subtype:
2632 /* If an equivalent type is present, that is what we should use.
2633 Otherwise, fall through to handle this like a record subtype
2634 since it may have constraints. */
2635 if (gnat_equiv_type != gnat_entity)
2637 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
2638 maybe_present = true;
2642 /* ... fall through ... */
2644 case E_Record_Subtype:
2646 /* If Cloned_Subtype is Present it means this record subtype has
2647 identical layout to that type or subtype and we should use
2648 that GCC type for this one. The front end guarantees that
2649 the component list is shared. */
2650 if (Present (Cloned_Subtype (gnat_entity)))
2652 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2654 maybe_present = true;
2657 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2658 changing the type, make a new type with each field having the
2659 type of the field in the new subtype but having the position
2660 computed by transforming every discriminant reference according
2661 to the constraints. We don't see any difference between
2662 private and nonprivate type here since derivations from types should
2663 have been deferred until the completion of the private type. */
2666 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2671 defer_incomplete_level++, this_deferred = true;
2673 /* Get the base type initially for its alignment and sizes. But
2674 if it is a padded type, we do all the other work with the
2676 gnu_base_type = gnat_to_gnu_type (gnat_base_type);
2678 if (TREE_CODE (gnu_base_type) == RECORD_TYPE
2679 && TYPE_IS_PADDING_P (gnu_base_type))
2680 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
2682 gnu_type = gnu_orig_type = gnu_base_type;
2684 if (present_gnu_tree (gnat_entity))
2686 maybe_present = true;
2690 /* When the type has discriminants, and these discriminants
2691 affect the shape of what it built, factor them in.
2693 If we are making a subtype of an Unchecked_Union (must be an
2694 Itype), just return the type.
2696 We can't just use Is_Constrained because private subtypes without
2697 discriminants of full types with discriminants with default
2698 expressions are Is_Constrained but aren't constrained! */
2700 if (IN (Ekind (gnat_base_type), Record_Kind)
2701 && !Is_For_Access_Subtype (gnat_entity)
2702 && !Is_Unchecked_Union (gnat_base_type)
2703 && Is_Constrained (gnat_entity)
2704 && Stored_Constraint (gnat_entity) != No_Elist
2705 && Present (Discriminant_Constraint (gnat_entity)))
2707 Entity_Id gnat_field;
2708 tree gnu_field_list = 0;
2710 = compute_field_positions (gnu_orig_type, NULL_TREE,
2711 size_zero_node, bitsize_zero_node,
2714 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2718 gnu_type = make_node (RECORD_TYPE);
2719 TYPE_NAME (gnu_type) = gnu_entity_id;
2720 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2721 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2723 for (gnat_field = First_Entity (gnat_entity);
2724 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2725 if ((Ekind (gnat_field) == E_Component
2726 || Ekind (gnat_field) == E_Discriminant)
2727 && (Underlying_Type (Scope (Original_Record_Component
2730 && (No (Corresponding_Discriminant (gnat_field))
2731 || !Is_Tagged_Type (gnat_base_type)))
2734 = gnat_to_gnu_field_decl (Original_Record_Component
2737 = TREE_VALUE (purpose_member (gnu_old_field,
2739 tree gnu_pos = TREE_PURPOSE (gnu_offset);
2740 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
2742 = gnat_to_gnu_type (Etype (gnat_field));
2743 tree gnu_size = TYPE_SIZE (gnu_field_type);
2744 tree gnu_new_pos = 0;
2745 unsigned int offset_align
2746 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
2750 /* If there was a component clause, the field types must be
2751 the same for the type and subtype, so copy the data from
2752 the old field to avoid recomputation here. Also if the
2753 field is justified modular and the optimization in
2754 gnat_to_gnu_field was applied. */
2755 if (Present (Component_Clause
2756 (Original_Record_Component (gnat_field)))
2757 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
2758 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
2759 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
2760 == TREE_TYPE (gnu_old_field)))
2762 gnu_size = DECL_SIZE (gnu_old_field);
2763 gnu_field_type = TREE_TYPE (gnu_old_field);
2766 /* If the old field was packed and of constant size, we
2767 have to get the old size here, as it might differ from
2768 what the Etype conveys and the latter might overlap
2769 onto the following field. Try to arrange the type for
2770 possible better packing along the way. */
2771 else if (DECL_PACKED (gnu_old_field)
2772 && TREE_CODE (DECL_SIZE (gnu_old_field))
2775 gnu_size = DECL_SIZE (gnu_old_field);
2776 if (TYPE_MODE (gnu_field_type) == BLKmode
2777 && TREE_CODE (gnu_field_type) == RECORD_TYPE
2778 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
2779 gnu_field_type = make_packable_type (gnu_field_type);
2782 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
2783 for (gnu_temp = gnu_subst_list;
2784 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2785 gnu_pos = substitute_in_expr (gnu_pos,
2786 TREE_PURPOSE (gnu_temp),
2787 TREE_VALUE (gnu_temp));
2789 /* If the size is now a constant, we can set it as the
2790 size of the field when we make it. Otherwise, we need
2791 to deal with it specially. */
2792 if (TREE_CONSTANT (gnu_pos))
2793 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
2797 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
2798 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
2799 !DECL_NONADDRESSABLE_P (gnu_old_field));
2801 if (!TREE_CONSTANT (gnu_pos))
2803 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
2804 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
2805 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
2806 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
2807 DECL_SIZE (gnu_field) = gnu_size;
2808 DECL_SIZE_UNIT (gnu_field)
2809 = convert (sizetype,
2810 size_binop (CEIL_DIV_EXPR, gnu_size,
2811 bitsize_unit_node));
2812 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
2815 DECL_INTERNAL_P (gnu_field)
2816 = DECL_INTERNAL_P (gnu_old_field);
2817 SET_DECL_ORIGINAL_FIELD
2818 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
2819 ? DECL_ORIGINAL_FIELD (gnu_old_field)
2821 DECL_DISCRIMINANT_NUMBER (gnu_field)
2822 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
2823 TREE_THIS_VOLATILE (gnu_field)
2824 = TREE_THIS_VOLATILE (gnu_old_field);
2825 TREE_CHAIN (gnu_field) = gnu_field_list;
2826 gnu_field_list = gnu_field;
2827 save_gnu_tree (gnat_field, gnu_field, false);
2830 /* Now go through the entities again looking for Itypes that
2831 we have not elaborated but should (e.g., Etypes of fields
2832 that have Original_Components). */
2833 for (gnat_field = First_Entity (gnat_entity);
2834 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2835 if ((Ekind (gnat_field) == E_Discriminant
2836 || Ekind (gnat_field) == E_Component)
2837 && !present_gnu_tree (Etype (gnat_field)))
2838 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
2840 /* Do not finalize it since we're going to modify it below. */
2841 finish_record_type (gnu_type, nreverse (gnu_field_list),
2844 /* Now set the size, alignment and alias set of the new type to
2845 match that of the old one, doing any substitutions, as
2847 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2848 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2849 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2850 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2851 copy_alias_set (gnu_type, gnu_base_type);
2853 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2854 for (gnu_temp = gnu_subst_list;
2855 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2856 TYPE_SIZE (gnu_type)
2857 = substitute_in_expr (TYPE_SIZE (gnu_type),
2858 TREE_PURPOSE (gnu_temp),
2859 TREE_VALUE (gnu_temp));
2861 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2862 for (gnu_temp = gnu_subst_list;
2863 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2864 TYPE_SIZE_UNIT (gnu_type)
2865 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2866 TREE_PURPOSE (gnu_temp),
2867 TREE_VALUE (gnu_temp));
2869 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2870 for (gnu_temp = gnu_subst_list;
2871 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2873 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2874 TREE_PURPOSE (gnu_temp),
2875 TREE_VALUE (gnu_temp)));
2877 /* Reapply variable_size since we have changed the sizes. */
2878 TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
2879 TYPE_SIZE_UNIT (gnu_type)
2880 = variable_size (TYPE_SIZE_UNIT (gnu_type));
2882 /* Recompute the mode of this record type now that we know its
2884 compute_record_mode (gnu_type);
2886 /* Fill in locations of fields. */
2887 annotate_rep (gnat_entity, gnu_type);
2889 /* We've built a new type, make an XVS type to show what this
2890 is a subtype of. Some debuggers require the XVS type to be
2891 output first, so do it in that order. */
2894 tree gnu_subtype_marker = make_node (RECORD_TYPE);
2895 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
2897 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
2898 gnu_orig_name = DECL_NAME (gnu_orig_name);
2900 TYPE_NAME (gnu_subtype_marker)
2901 = create_concat_name (gnat_entity, "XVS");
2902 finish_record_type (gnu_subtype_marker,
2903 create_field_decl (gnu_orig_name,
2911 /* Now we can finalize it. */
2912 rest_of_record_type_compilation (gnu_type);
2915 /* Otherwise, go down all the components in the new type and
2916 make them equivalent to those in the base type. */
2918 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
2919 gnat_temp = Next_Entity (gnat_temp))
2920 if ((Ekind (gnat_temp) == E_Discriminant
2921 && !Is_Unchecked_Union (gnat_base_type))
2922 || Ekind (gnat_temp) == E_Component)
2923 save_gnu_tree (gnat_temp,
2924 gnat_to_gnu_field_decl
2925 (Original_Record_Component (gnat_temp)), false);
2929 case E_Access_Subprogram_Type:
2930 case E_Anonymous_Access_Subprogram_Type:
2931 /* If we are not defining this entity, and we have incomplete
2932 entities being processed above us, make a dummy type and
2933 fill it in later. */
2934 if (!definition && defer_incomplete_level != 0)
2936 struct incomplete *p
2937 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
2940 = build_pointer_type
2941 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
2942 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2943 !Comes_From_Source (gnat_entity),
2944 debug_info_p, gnat_entity);
2945 this_made_decl = true;
2946 gnu_type = TREE_TYPE (gnu_decl);
2947 save_gnu_tree (gnat_entity, gnu_decl, false);
2950 p->old_type = TREE_TYPE (gnu_type);
2951 p->full_type = Directly_Designated_Type (gnat_entity);
2952 p->next = defer_incomplete_list;
2953 defer_incomplete_list = p;
2957 /* ... fall through ... */
2959 case E_Allocator_Type:
2961 case E_Access_Attribute_Type:
2962 case E_Anonymous_Access_Type:
2963 case E_General_Access_Type:
2965 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
2966 Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
2967 bool is_from_limited_with
2968 = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
2969 && From_With_Type (gnat_desig_equiv));
2971 /* Get the "full view" of this entity. If this is an incomplete
2972 entity from a limited with, treat its non-limited view as the full
2973 view. Otherwise, if this is an incomplete or private type, use the
2974 full view. In the former case, we might point to a private type,
2975 in which case, we need its full view. Also, we want to look at the
2976 actual type used for the representation, so this takes a total of
2978 Entity_Id gnat_desig_full_direct_first
2979 = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
2980 : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
2981 ? Full_View (gnat_desig_equiv) : Empty));
2982 Entity_Id gnat_desig_full_direct
2983 = ((Present (gnat_desig_full_direct_first)
2984 && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
2985 ? Full_View (gnat_desig_full_direct_first)
2986 : gnat_desig_full_direct_first);
2987 Entity_Id gnat_desig_full
2988 = Gigi_Equivalent_Type (gnat_desig_full_direct);
2990 /* This the type actually used to represent the designated type,
2991 either gnat_desig_full or gnat_desig_equiv. */
2992 Entity_Id gnat_desig_rep;
2994 /* Nonzero if this is a pointer to an unconstrained array. */
2995 bool is_unconstrained_array;
2997 /* We want to know if we'll be seeing the freeze node for any
2998 incomplete type we may be pointing to. */
3000 = (Present (gnat_desig_full)
3001 ? In_Extended_Main_Code_Unit (gnat_desig_full)
3002 : In_Extended_Main_Code_Unit (gnat_desig_type));
3004 /* Nonzero if we make a dummy type here. */
3005 bool got_fat_p = false;
3006 /* Nonzero if the dummy is a fat pointer. */
3007 bool made_dummy = false;
3008 tree gnu_desig_type = NULL_TREE;
3009 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
3011 if (!targetm.valid_pointer_mode (p_mode))
3014 /* If either the designated type or its full view is an unconstrained
3015 array subtype, replace it with the type it's a subtype of. This
3016 avoids problems with multiple copies of unconstrained array types.
3017 Likewise, if the designated type is a subtype of an incomplete
3018 record type, use the parent type to avoid order of elaboration
3019 issues. This can lose some code efficiency, but there is no
3021 if (Ekind (gnat_desig_equiv) == E_Array_Subtype
3022 && ! Is_Constrained (gnat_desig_equiv))
3023 gnat_desig_equiv = Etype (gnat_desig_equiv);
3024 if (Present (gnat_desig_full)
3025 && ((Ekind (gnat_desig_full) == E_Array_Subtype
3026 && ! Is_Constrained (gnat_desig_full))
3027 || (Ekind (gnat_desig_full) == E_Record_Subtype
3028 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
3029 gnat_desig_full = Etype (gnat_desig_full);
3031 /* Now set the type that actually marks the representation of
3032 the designated type and also flag whether we have a unconstrained
3034 gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
3035 is_unconstrained_array
3036 = (Is_Array_Type (gnat_desig_rep)
3037 && ! Is_Constrained (gnat_desig_rep));
3039 /* If we are pointing to an incomplete type whose completion is an
3040 unconstrained array, make a fat pointer type. The two types in our
3041 fields will be pointers to dummy nodes and will be replaced in
3042 update_pointer_to. Similarly, if the type itself is a dummy type or
3043 an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
3044 in case we have any thin pointers to it. */
3045 if (is_unconstrained_array
3046 && (Present (gnat_desig_full)
3047 || (present_gnu_tree (gnat_desig_equiv)
3048 && TYPE_IS_DUMMY_P (TREE_TYPE
3049 (get_gnu_tree (gnat_desig_equiv))))
3050 || (No (gnat_desig_full) && ! in_main_unit
3051 && defer_incomplete_level != 0
3052 && ! present_gnu_tree (gnat_desig_equiv))
3053 || (in_main_unit && is_from_limited_with
3054 && Present (Freeze_Node (gnat_desig_rep)))))
3057 = (present_gnu_tree (gnat_desig_rep)
3058 ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
3059 : make_dummy_type (gnat_desig_rep));
3062 /* Show the dummy we get will be a fat pointer. */
3063 got_fat_p = made_dummy = true;
3065 /* If the call above got something that has a pointer, that
3066 pointer is our type. This could have happened either
3067 because the type was elaborated or because somebody
3068 else executed the code below. */
3069 gnu_type = TYPE_POINTER_TO (gnu_old);
3072 tree gnu_template_type = make_node (ENUMERAL_TYPE);
3073 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
3074 tree gnu_array_type = make_node (ENUMERAL_TYPE);
3075 tree gnu_ptr_array = build_pointer_type (gnu_array_type);
3077 TYPE_NAME (gnu_template_type)
3078 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3080 TYPE_DUMMY_P (gnu_template_type) = 1;
3082 TYPE_NAME (gnu_array_type)
3083 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3085 TYPE_DUMMY_P (gnu_array_type) = 1;
3087 gnu_type = make_node (RECORD_TYPE);
3088 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3089 TYPE_POINTER_TO (gnu_old) = gnu_type;
3091 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3093 = chainon (chainon (NULL_TREE,
3095 (get_identifier ("P_ARRAY"),
3097 gnu_type, 0, 0, 0, 0)),
3098 create_field_decl (get_identifier ("P_BOUNDS"),
3100 gnu_type, 0, 0, 0, 0));
3102 /* Make sure we can place this into a register. */
3103 TYPE_ALIGN (gnu_type)
3104 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3105 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
3107 /* Do not finalize this record type since the types of
3108 its fields are incomplete. */
3109 finish_record_type (gnu_type, fields, 0, true);
3111 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3112 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3113 = concat_id_with_name (get_entity_name (gnat_desig_equiv),
3115 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3119 /* If we already know what the full type is, use it. */
3120 else if (Present (gnat_desig_full)
3121 && present_gnu_tree (gnat_desig_full))
3122 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3124 /* Get the type of the thing we are to point to and build a pointer
3125 to it. If it is a reference to an incomplete or private type with a
3126 full view that is a record, make a dummy type node and get the
3127 actual type later when we have verified it is safe. */
3128 else if ((! in_main_unit
3129 && ! present_gnu_tree (gnat_desig_equiv)
3130 && Present (gnat_desig_full)
3131 && ! present_gnu_tree (gnat_desig_full)
3132 && Is_Record_Type (gnat_desig_full))
3133 /* Likewise if we are pointing to a record or array and we
3134 are to defer elaborating incomplete types. We do this
3135 since this access type may be the full view of some
3136 private type. Note that the unconstrained array case is
3138 || ((! in_main_unit || imported_p)
3139 && defer_incomplete_level != 0
3140 && ! present_gnu_tree (gnat_desig_equiv)
3141 && ((Is_Record_Type (gnat_desig_rep)
3142 || Is_Array_Type (gnat_desig_rep))))
3143 /* If this is a reference from a limited_with type back to our
3144 main unit and there's a Freeze_Node for it, either we have
3145 already processed the declaration and made the dummy type,
3146 in which case we just reuse the latter, or we have not yet,
3147 in which case we make the dummy type and it will be reused
3148 when the declaration is processed. In both cases, the
3149 pointer eventually created below will be automatically
3150 adjusted when the Freeze_Node is processed. Note that the
3151 unconstrained array case is handled above. */
3152 || (in_main_unit && is_from_limited_with
3153 && Present (Freeze_Node (gnat_desig_rep))))
3155 gnu_desig_type = make_dummy_type (gnat_desig_equiv);
3159 /* Otherwise handle the case of a pointer to itself. */
3160 else if (gnat_desig_equiv == gnat_entity)
3163 = build_pointer_type_for_mode (void_type_node, p_mode,
3164 No_Strict_Aliasing (gnat_entity));
3165 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3168 /* If expansion is disabled, the equivalent type of a concurrent
3169 type is absent, so build a dummy pointer type. */
3170 else if (type_annotate_only && No (gnat_desig_equiv))
3171 gnu_type = ptr_void_type_node;
3173 /* Finally, handle the straightforward case where we can just
3174 elaborate our designated type and point to it. */
3176 gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
3178 /* It is possible that a call to gnat_to_gnu_type above resolved our
3179 type. If so, just return it. */
3180 if (present_gnu_tree (gnat_entity))
3182 maybe_present = true;
3186 /* If we have a GCC type for the designated type, possibly modify it
3187 if we are pointing only to constant objects and then make a pointer
3188 to it. Don't do this for unconstrained arrays. */
3189 if (!gnu_type && gnu_desig_type)
3191 if (Is_Access_Constant (gnat_entity)
3192 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3195 = build_qualified_type
3197 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3199 /* Some extra processing is required if we are building a
3200 pointer to an incomplete type (in the GCC sense). We might
3201 have such a type if we just made a dummy, or directly out
3202 of the call to gnat_to_gnu_type above if we are processing
3203 an access type for a record component designating the
3204 record type itself. */
3205 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3207 /* We must ensure that the pointer to variant we make will
3208 be processed by update_pointer_to when the initial type
3209 is completed. Pretend we made a dummy and let further
3210 processing act as usual. */
3213 /* We must ensure that update_pointer_to will not retrieve
3214 the dummy variant when building a properly qualified
3215 version of the complete type. We take advantage of the
3216 fact that get_qualified_type is requiring TYPE_NAMEs to
3217 match to influence build_qualified_type and then also
3218 update_pointer_to here. */
3219 TYPE_NAME (gnu_desig_type)
3220 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3225 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3226 No_Strict_Aliasing (gnat_entity));
3229 /* If we are not defining this object and we made a dummy pointer,
3230 save our current definition, evaluate the actual type, and replace
3231 the tentative type we made with the actual one. If we are to defer
3232 actually looking up the actual type, make an entry in the
3233 deferred list. If this is from a limited with, we have to defer
3234 to the end of the current spec in two cases: first if the
3235 designated type is in the current unit and second if the access
3237 if ((! in_main_unit || is_from_limited_with) && made_dummy)
3240 = TYPE_FAT_POINTER_P (gnu_type)
3241 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3243 if (esize == POINTER_SIZE
3244 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3246 = build_pointer_type
3247 (TYPE_OBJECT_RECORD_TYPE
3248 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3250 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3251 !Comes_From_Source (gnat_entity),
3252 debug_info_p, gnat_entity);
3253 this_made_decl = true;
3254 gnu_type = TREE_TYPE (gnu_decl);
3255 save_gnu_tree (gnat_entity, gnu_decl, false);
3258 if (defer_incomplete_level == 0
3259 && ! (is_from_limited_with
3261 || In_Extended_Main_Code_Unit (gnat_entity))))
3262 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3263 gnat_to_gnu_type (gnat_desig_equiv));
3265 /* Note that the call to gnat_to_gnu_type here might have
3266 updated gnu_old_type directly, in which case it is not a
3267 dummy type any more when we get into update_pointer_to.
3269 This may happen for instance when the designated type is a
3270 record type, because their elaboration starts with an
3271 initial node from make_dummy_type, which may yield the same
3272 node as the one we got.
3274 Besides, variants of this non-dummy type might have been
3275 created along the way. update_pointer_to is expected to
3276 properly take care of those situations. */
3279 struct incomplete *p
3280 = (struct incomplete *) xmalloc (sizeof
3281 (struct incomplete));
3282 struct incomplete **head
3283 = (is_from_limited_with
3285 || In_Extended_Main_Code_Unit (gnat_entity))
3286 ? &defer_limited_with : &defer_incomplete_list);
3288 p->old_type = gnu_old_type;
3289 p->full_type = gnat_desig_equiv;
3297 case E_Access_Protected_Subprogram_Type:
3298 case E_Anonymous_Access_Protected_Subprogram_Type:
3299 if (type_annotate_only && No (gnat_equiv_type))
3300 gnu_type = ptr_void_type_node;
3303 /* The runtime representation is the equivalent type. */
3304 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3308 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3309 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3310 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3311 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3312 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3317 case E_Access_Subtype:
3319 /* We treat this as identical to its base type; any constraint is
3320 meaningful only to the front end.
3322 The designated type must be elaborated as well, if it does
3323 not have its own freeze node. Designated (sub)types created
3324 for constrained components of records with discriminants are
3325 not frozen by the front end and thus not elaborated by gigi,
3326 because their use may appear before the base type is frozen,
3327 and because it is not clear that they are needed anywhere in
3328 Gigi. With the current model, there is no correct place where
3329 they could be elaborated. */
3331 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3332 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3333 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3334 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3335 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3337 /* If we are not defining this entity, and we have incomplete
3338 entities being processed above us, make a dummy type and
3339 elaborate it later. */
3340 if (!definition && defer_incomplete_level != 0)
3342 struct incomplete *p
3343 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3345 = build_pointer_type
3346 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3348 p->old_type = TREE_TYPE (gnu_ptr_type);
3349 p->full_type = Directly_Designated_Type (gnat_entity);
3350 p->next = defer_incomplete_list;
3351 defer_incomplete_list = p;
3353 else if (!IN (Ekind (Base_Type
3354 (Directly_Designated_Type (gnat_entity))),
3355 Incomplete_Or_Private_Kind))
3356 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3360 maybe_present = true;
3363 /* Subprogram Entities
3365 The following access functions are defined for subprograms (functions
3368 First_Formal The first formal parameter.
3369 Is_Imported Indicates that the subprogram has appeared in
3370 an INTERFACE or IMPORT pragma. For now we
3371 assume that the external language is C.
3372 Is_Exported Likewise but for an EXPORT pragma.
3373 Is_Inlined True if the subprogram is to be inlined.
3375 In addition for function subprograms we have:
3377 Etype Return type of the function.
3379 Each parameter is first checked by calling must_pass_by_ref on its
3380 type to determine if it is passed by reference. For parameters which
3381 are copied in, if they are Ada IN OUT or OUT parameters, their return
3382 value becomes part of a record which becomes the return type of the
3383 function (C function - note that this applies only to Ada procedures
3384 so there is no Ada return type). Additional code to store back the
3385 parameters will be generated on the caller side. This transformation
3386 is done here, not in the front-end.
3388 The intended result of the transformation can be seen from the
3389 equivalent source rewritings that follow:
3391 struct temp {int a,b};
3392 procedure P (A,B: IN OUT ...) is temp P (int A,B)
3395 end P; return {A,B};
3402 For subprogram types we need to perform mainly the same conversions to
3403 GCC form that are needed for procedures and function declarations. The
3404 only difference is that at the end, we make a type declaration instead
3405 of a function declaration. */
3407 case E_Subprogram_Type:
3411 /* The first GCC parameter declaration (a PARM_DECL node). The
3412 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3413 actually is the head of this parameter list. */
3414 tree gnu_param_list = NULL_TREE;
3415 /* Likewise for the stub associated with an exported procedure. */
3416 tree gnu_stub_param_list = NULL_TREE;
3417 /* The type returned by a function. If the subprogram is a procedure
3418 this type should be void_type_node. */
3419 tree gnu_return_type = void_type_node;
3420 /* List of fields in return type of procedure with copy-in copy-out
3422 tree gnu_field_list = NULL_TREE;
3423 /* Non-null for subprograms containing parameters passed by copy-in
3424 copy-out (Ada IN OUT or OUT parameters not passed by reference),
3425 in which case it is the list of nodes used to specify the values of
3426 the in out/out parameters that are returned as a record upon
3427 procedure return. The TREE_PURPOSE of an element of this list is
3428 a field of the record and the TREE_VALUE is the PARM_DECL
3429 corresponding to that field. This list will be saved in the
3430 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3431 tree gnu_return_list = NULL_TREE;
3432 /* If an import pragma asks to map this subprogram to a GCC builtin,
3433 this is the builtin DECL node. */
3434 tree gnu_builtin_decl = NULL_TREE;
3435 /* For the stub associated with an exported procedure. */
3436 tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
3437 tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
3438 Entity_Id gnat_param;
3439 bool inline_flag = Is_Inlined (gnat_entity);
3440 bool public_flag = Is_Public (gnat_entity);
3442 = (Is_Public (gnat_entity) && !definition) || imported_p;
3443 bool pure_flag = Is_Pure (gnat_entity);
3444 bool volatile_flag = No_Return (gnat_entity);
3445 bool returns_by_ref = false;
3446 bool returns_unconstrained = false;
3447 bool returns_by_target_ptr = false;
3448 bool has_copy_in_out = false;
3449 bool has_stub = false;
3452 if (kind == E_Subprogram_Type && !definition)
3453 /* A parameter may refer to this type, so defer completion
3454 of any incomplete types. */
3455 defer_incomplete_level++, this_deferred = true;
3457 /* If the subprogram has an alias, it is probably inherited, so
3458 we can use the original one. If the original "subprogram"
3459 is actually an enumeration literal, it may be the first use
3460 of its type, so we must elaborate that type now. */
3461 if (Present (Alias (gnat_entity)))
3463 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3464 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3466 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3469 /* Elaborate any Itypes in the parameters of this entity. */
3470 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3471 Present (gnat_temp);
3472 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3473 if (Is_Itype (Etype (gnat_temp)))
3474 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3479 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3480 corresponding DECL node.
3482 We still want the parameter associations to take place because the
3483 proper generation of calls depends on it (a GNAT parameter without
3484 a corresponding GCC tree has a very specific meaning), so we don't
3486 if (Convention (gnat_entity) == Convention_Intrinsic)
3487 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3489 /* ??? What if we don't find the builtin node above ? warn ? err ?
3490 In the current state we neither warn nor err, and calls will just
3491 be handled as for regular subprograms. */
3493 if (kind == E_Function || kind == E_Subprogram_Type)
3494 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3496 /* If this function returns by reference, make the actual
3497 return type of this function the pointer and mark the decl. */
3498 if (Returns_By_Ref (gnat_entity))
3500 returns_by_ref = true;
3501 gnu_return_type = build_pointer_type (gnu_return_type);
3504 /* If the Mechanism is By_Reference, ensure the return type uses
3505 the machine's by-reference mechanism, which may not the same
3506 as above (e.g., it might be by passing a fake parameter). */
3507 else if (kind == E_Function
3508 && Mechanism (gnat_entity) == By_Reference)
3510 TREE_ADDRESSABLE (gnu_return_type) = 1;
3512 /* We expect this bit to be reset by gigi shortly, so can avoid a
3513 type node copy here. This actually also prevents troubles with
3514 the generation of debug information for the function, because
3515 we might have issued such info for this type already, and would
3516 be attaching a distinct type node to the function if we made a
3520 /* If we are supposed to return an unconstrained array,
3521 actually return a fat pointer and make a note of that. Return
3522 a pointer to an unconstrained record of variable size. */
3523 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3525 gnu_return_type = TREE_TYPE (gnu_return_type);
3526 returns_unconstrained = true;
3529 /* If the type requires a transient scope, the result is allocated
3530 on the secondary stack, so the result type of the function is
3532 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3534 gnu_return_type = build_pointer_type (gnu_return_type);
3535 returns_unconstrained = true;
3538 /* If the type is a padded type and the underlying type would not
3539 be passed by reference or this function has a foreign convention,
3540 return the underlying type. */
3541 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3542 && TYPE_IS_PADDING_P (gnu_return_type)
3543 && (!default_pass_by_ref (TREE_TYPE
3544 (TYPE_FIELDS (gnu_return_type)))
3545 || Has_Foreign_Convention (gnat_entity)))
3546 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3548 /* If the return type is unconstrained, that means it must have a
3549 maximum size. We convert the function into a procedure and its
3550 caller will pass a pointer to an object of that maximum size as the
3551 first parameter when we call the function. */
3552 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
3554 returns_by_target_ptr = true;
3556 = create_param_decl (get_identifier ("TARGET"),
3557 build_reference_type (gnu_return_type),
3559 gnu_return_type = void_type_node;
3562 /* If the return type has a size that overflows, we cannot have
3563 a function that returns that type. This usage doesn't make
3564 sense anyway, so give an error here. */
3565 if (TYPE_SIZE_UNIT (gnu_return_type)
3566 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3567 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3569 post_error ("cannot return type whose size overflows",
3571 gnu_return_type = copy_node (gnu_return_type);
3572 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3573 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3574 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3575 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3578 /* Look at all our parameters and get the type of
3579 each. While doing this, build a copy-out structure if
3582 /* Loop over the parameters and get their associated GCC tree.
3583 While doing this, build a copy-out structure if we need one. */
3584 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3585 Present (gnat_param);
3586 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3588 tree gnu_param_name = get_entity_name (gnat_param);
3589 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3590 tree gnu_param, gnu_field;
3591 bool copy_in_copy_out = false;
3592 Mechanism_Type mech = Mechanism (gnat_param);
3594 /* Builtins are expanded inline and there is no real call sequence
3595 involved. So the type expected by the underlying expander is
3596 always the type of each argument "as is". */
3597 if (gnu_builtin_decl)
3599 /* Handle the first parameter of a valued procedure specially. */
3600 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3601 mech = By_Copy_Return;
3602 /* Otherwise, see if a Mechanism was supplied that forced this
3603 parameter to be passed one way or another. */
3604 else if (mech == Default
3605 || mech == By_Copy || mech == By_Reference)
3607 else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
3608 mech = By_Descriptor;
3611 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3612 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3613 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3615 mech = By_Reference;
3621 post_error ("unsupported mechanism for&", gnat_param);
3626 = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
3627 Has_Foreign_Convention (gnat_entity),
3630 /* We are returned either a PARM_DECL or a type if no parameter
3631 needs to be passed; in either case, adjust the type. */
3632 if (DECL_P (gnu_param))
3633 gnu_param_type = TREE_TYPE (gnu_param);
3636 gnu_param_type = gnu_param;
3637 gnu_param = NULL_TREE;
3642 /* If it's an exported subprogram, we build a parameter list
3643 in parallel, in case we need to emit a stub for it. */
3644 if (Is_Exported (gnat_entity))
3647 = chainon (gnu_param, gnu_stub_param_list);
3648 /* Change By_Descriptor parameter to By_Reference for
3649 the internal version of an exported subprogram. */
3650 if (mech == By_Descriptor)
3653 = gnat_to_gnu_param (gnat_param, By_Reference,
3659 gnu_param = copy_node (gnu_param);
3662 gnu_param_list = chainon (gnu_param, gnu_param_list);
3663 Sloc_to_locus (Sloc (gnat_param),
3664 &DECL_SOURCE_LOCATION (gnu_param));
3665 save_gnu_tree (gnat_param, gnu_param, false);
3667 /* If a parameter is a pointer, this function may modify
3668 memory through it and thus shouldn't be considered
3669 a pure function. Also, the memory may be modified
3670 between two calls, so they can't be CSE'ed. The latter
3671 case also handles by-ref parameters. */
3672 if (POINTER_TYPE_P (gnu_param_type)
3673 || TYPE_FAT_POINTER_P (gnu_param_type))
3677 if (copy_in_copy_out)
3679 if (!has_copy_in_out)
3681 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
3682 gnu_return_type = make_node (RECORD_TYPE);
3683 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3684 has_copy_in_out = true;
3687 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3688 gnu_return_type, 0, 0, 0, 0);
3689 Sloc_to_locus (Sloc (gnat_param),
3690 &DECL_SOURCE_LOCATION (gnu_field));
3691 TREE_CHAIN (gnu_field) = gnu_field_list;
3692 gnu_field_list = gnu_field;
3693 gnu_return_list = tree_cons (gnu_field, gnu_param,
3698 /* Do not compute record for out parameters if subprogram is
3699 stubbed since structures are incomplete for the back-end. */
3700 if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
3701 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3704 /* If we have a CICO list but it has only one entry, we convert
3705 this function into a function that simply returns that one
3707 if (list_length (gnu_return_list) == 1)
3708 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3710 if (Has_Stdcall_Convention (gnat_entity))
3711 prepend_one_attribute_to
3712 (&attr_list, ATTR_MACHINE_ATTRIBUTE,
3713 get_identifier ("stdcall"), NULL_TREE,
3716 /* The lists have been built in reverse. */
3717 gnu_param_list = nreverse (gnu_param_list);
3719 gnu_stub_param_list = nreverse (gnu_stub_param_list);
3720 gnu_return_list = nreverse (gnu_return_list);
3722 if (Ekind (gnat_entity) == E_Function)
3723 Set_Mechanism (gnat_entity,
3724 (returns_by_ref || returns_unconstrained
3725 ? By_Reference : By_Copy));
3727 = create_subprog_type (gnu_return_type, gnu_param_list,
3728 gnu_return_list, returns_unconstrained,
3730 Function_Returns_With_DSP (gnat_entity),
3731 returns_by_target_ptr);
3735 = create_subprog_type (gnu_return_type, gnu_stub_param_list,
3736 gnu_return_list, returns_unconstrained,
3738 Function_Returns_With_DSP (gnat_entity),
3739 returns_by_target_ptr);
3741 /* A subprogram (something that doesn't return anything) shouldn't
3742 be considered Pure since there would be no reason for such a
3743 subprogram. Note that procedures with Out (or In Out) parameters
3744 have already been converted into a function with a return type. */
3745 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
3748 /* The semantics of "pure" in Ada essentially matches that of "const"
3749 in the back-end. In particular, both properties are orthogonal to
3750 the "nothrow" property. But this is true only if the EH circuitry
3751 is explicit in the internal representation of the back-end. If we
3752 are to completely hide the EH circuitry from it, we need to declare
3753 that calls to pure Ada subprograms that can throw have side effects
3754 since they can trigger an "abnormal" transfer of control flow; thus
3755 they can be neither "const" nor "pure" in the back-end sense. */
3757 = build_qualified_type (gnu_type,
3758 TYPE_QUALS (gnu_type)
3759 | (Exception_Mechanism == Back_End_Exceptions
3760 ? TYPE_QUAL_CONST * pure_flag : 0)
3761 | (TYPE_QUAL_VOLATILE * volatile_flag));
3763 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3767 = build_qualified_type (gnu_stub_type,
3768 TYPE_QUALS (gnu_stub_type)
3769 | (Exception_Mechanism == Back_End_Exceptions
3770 ? TYPE_QUAL_CONST * pure_flag : 0)
3771 | (TYPE_QUAL_VOLATILE * volatile_flag));
3773 /* If we have a builtin decl for that function, check the signatures
3774 compatibilities. If the signatures are compatible, use the builtin
3775 decl. If they are not, we expect the checker predicate to have
3776 posted the appropriate errors, and just continue with what we have
3778 if (gnu_builtin_decl)
3780 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
3782 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
3784 gnu_decl = gnu_builtin_decl;
3785 gnu_type = gnu_builtin_type;
3790 /* If there was no specified Interface_Name and the external and
3791 internal names of the subprogram are the same, only use the
3792 internal name to allow disambiguation of nested subprograms. */
3793 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
3794 gnu_ext_name = NULL_TREE;
3796 /* If we are defining the subprogram and it has an Address clause
3797 we must get the address expression from the saved GCC tree for the
3798 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3799 the address expression here since the front-end has guaranteed
3800 in that case that the elaboration has no effects. If there is
3801 an Address clause and we are not defining the object, just
3802 make it a constant. */
3803 if (Present (Address_Clause (gnat_entity)))
3805 tree gnu_address = NULL_TREE;
3809 = (present_gnu_tree (gnat_entity)
3810 ? get_gnu_tree (gnat_entity)
3811 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
3813 save_gnu_tree (gnat_entity, NULL_TREE, false);
3815 /* Convert the type of the object to a reference type that can
3816 alias everything as per 13.3(19). */
3818 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
3820 gnu_address = convert (gnu_type, gnu_address);
3823 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
3824 gnu_address, false, Is_Public (gnat_entity),
3825 extern_flag, false, NULL, gnat_entity);
3826 DECL_BY_REF_P (gnu_decl) = 1;
3829 else if (kind == E_Subprogram_Type)
3830 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3831 !Comes_From_Source (gnat_entity),
3832 debug_info_p, gnat_entity);
3837 gnu_stub_name = gnu_ext_name;
3838 gnu_ext_name = create_concat_name (gnat_entity, "internal");
3839 public_flag = false;
3842 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
3843 gnu_type, gnu_param_list,
3844 inline_flag, public_flag,
3845 extern_flag, attr_list,
3850 = create_subprog_decl (gnu_entity_id, gnu_stub_name,
3851 gnu_stub_type, gnu_stub_param_list,
3853 extern_flag, attr_list,
3855 SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
3858 /* This is unrelated to the stub built right above. */
3859 DECL_STUBBED_P (gnu_decl)
3860 = Convention (gnat_entity) == Convention_Stubbed;
3865 case E_Incomplete_Type:
3866 case E_Incomplete_Subtype:
3867 case E_Private_Type:
3868 case E_Private_Subtype:
3869 case E_Limited_Private_Type:
3870 case E_Limited_Private_Subtype:
3871 case E_Record_Type_With_Private:
3872 case E_Record_Subtype_With_Private:
3874 /* Get the "full view" of this entity. If this is an incomplete
3875 entity from a limited with, treat its non-limited view as the
3876 full view. Otherwise, use either the full view or the underlying
3877 full view, whichever is present. This is used in all the tests
3880 = (IN (Ekind (gnat_entity), Incomplete_Kind)
3881 && From_With_Type (gnat_entity))
3882 ? Non_Limited_View (gnat_entity)
3883 : Present (Full_View (gnat_entity))
3884 ? Full_View (gnat_entity)
3885 : Underlying_Full_View (gnat_entity);
3887 /* If this is an incomplete type with no full view, it must be a Taft
3888 Amendment type, in which case we return a dummy type. Otherwise,
3889 just get the type from its Etype. */
3892 if (kind == E_Incomplete_Type)
3893 gnu_type = make_dummy_type (gnat_entity);
3896 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
3898 maybe_present = true;
3903 /* If we already made a type for the full view, reuse it. */
3904 else if (present_gnu_tree (full_view))
3906 gnu_decl = get_gnu_tree (full_view);
3910 /* Otherwise, if we are not defining the type now, get the type
3911 from the full view. But always get the type from the full view
3912 for define on use types, since otherwise we won't see them! */
3913 else if (!definition
3914 || (Is_Itype (full_view)
3915 && No (Freeze_Node (gnat_entity)))
3916 || (Is_Itype (gnat_entity)
3917 && No (Freeze_Node (full_view))))
3919 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
3920 maybe_present = true;
3924 /* For incomplete types, make a dummy type entry which will be
3926 gnu_type = make_dummy_type (gnat_entity);
3928 /* Save this type as the full declaration's type so we can do any
3929 needed updates when we see it. */
3930 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3931 !Comes_From_Source (gnat_entity),
3932 debug_info_p, gnat_entity);
3933 save_gnu_tree (full_view, gnu_decl, 0);
3937 /* Simple class_wide types are always viewed as their root_type
3938 by Gigi unless an Equivalent_Type is specified. */
3939 case E_Class_Wide_Type:
3940 gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
3941 maybe_present = true;
3945 case E_Task_Subtype:
3946 case E_Protected_Type:
3947 case E_Protected_Subtype:
3948 if (type_annotate_only && No (gnat_equiv_type))
3949 gnu_type = void_type_node;
3951 gnu_type = gnat_to_gnu_type (gnat_equiv_type);
3953 maybe_present = true;
3957 gnu_decl = create_label_decl (gnu_entity_id);
3962 /* Nothing at all to do here, so just return an ERROR_MARK and claim
3963 we've already saved it, so we don't try to. */
3964 gnu_decl = error_mark_node;
3972 /* If we had a case where we evaluated another type and it might have
3973 defined this one, handle it here. */
3974 if (maybe_present && present_gnu_tree (gnat_entity))
3976 gnu_decl = get_gnu_tree (gnat_entity);
3980 /* If we are processing a type and there is either no decl for it or
3981 we just made one, do some common processing for the type, such as
3982 handling alignment and possible padding. */
3984 if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
3986 if (Is_Tagged_Type (gnat_entity)
3987 || Is_Class_Wide_Equivalent_Type (gnat_entity))
3988 TYPE_ALIGN_OK (gnu_type) = 1;
3990 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
3991 TYPE_BY_REFERENCE_P (gnu_type) = 1;
3993 /* ??? Don't set the size for a String_Literal since it is either
3994 confirming or we don't handle it properly (if the low bound is
3996 if (!gnu_size && kind != E_String_Literal_Subtype)
3997 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
3999 Has_Size_Clause (gnat_entity));
4001 /* If a size was specified, see if we can make a new type of that size
4002 by rearranging the type, for example from a fat to a thin pointer. */
4006 = make_type_from_size (gnu_type, gnu_size,
4007 Has_Biased_Representation (gnat_entity));
4009 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4010 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4014 /* If the alignment hasn't already been processed and this is
4015 not an unconstrained array, see if an alignment is specified.
4016 If not, we pick a default alignment for atomic objects. */
4017 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4019 else if (Known_Alignment (gnat_entity))
4020 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4021 TYPE_ALIGN (gnu_type));
4022 else if (Is_Atomic (gnat_entity) && !gnu_size
4023 && host_integerp (TYPE_SIZE (gnu_type), 1)
4024 && integer_pow2p (TYPE_SIZE (gnu_type)))
4025 align = MIN (BIGGEST_ALIGNMENT,
4026 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4027 else if (Is_Atomic (gnat_entity) && gnu_size
4028 && host_integerp (gnu_size, 1)
4029 && integer_pow2p (gnu_size))
4030 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4032 /* See if we need to pad the type. If we did, and made a record,
4033 the name of the new type may be changed. So get it back for
4034 us when we make the new TYPE_DECL below. */
4035 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, "PAD",
4036 true, definition, false);
4037 if (TREE_CODE (gnu_type) == RECORD_TYPE
4038 && TYPE_IS_PADDING_P (gnu_type))
4040 gnu_entity_id = TYPE_NAME (gnu_type);
4041 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
4042 gnu_entity_id = DECL_NAME (gnu_entity_id);
4045 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4047 /* If we are at global level, GCC will have applied variable_size to
4048 the type, but that won't have done anything. So, if it's not
4049 a constant or self-referential, call elaborate_expression_1 to
4050 make a variable for the size rather than calculating it each time.
4051 Handle both the RM size and the actual size. */
4052 if (global_bindings_p ()
4053 && TYPE_SIZE (gnu_type)
4054 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4055 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4057 if (TREE_CODE (gnu_type) == RECORD_TYPE
4058 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4059 TYPE_SIZE (gnu_type), 0))
4061 TYPE_SIZE (gnu_type)
4062 = elaborate_expression_1 (gnat_entity, gnat_entity,
4063 TYPE_SIZE (gnu_type),
4064 get_identifier ("SIZE"),
4066 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4070 TYPE_SIZE (gnu_type)
4071 = elaborate_expression_1 (gnat_entity, gnat_entity,
4072 TYPE_SIZE (gnu_type),
4073 get_identifier ("SIZE"),
4076 /* ??? For now, store the size as a multiple of the alignment
4077 in bytes so that we can see the alignment from the tree. */
4078 TYPE_SIZE_UNIT (gnu_type)
4080 (MULT_EXPR, sizetype,
4081 elaborate_expression_1
4082 (gnat_entity, gnat_entity,
4083 build_binary_op (EXACT_DIV_EXPR, sizetype,
4084 TYPE_SIZE_UNIT (gnu_type),
4085 size_int (TYPE_ALIGN (gnu_type)
4087 get_identifier ("SIZE_A_UNIT"),
4089 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4091 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4094 elaborate_expression_1 (gnat_entity,
4096 TYPE_ADA_SIZE (gnu_type),
4097 get_identifier ("RM_SIZE"),
4102 /* If this is a record type or subtype, call elaborate_expression_1 on
4103 any field position. Do this for both global and local types.
4104 Skip any fields that we haven't made trees for to avoid problems with
4105 class wide types. */
4106 if (IN (kind, Record_Kind))
4107 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4108 gnat_temp = Next_Entity (gnat_temp))
4109 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4111 tree gnu_field = get_gnu_tree (gnat_temp);
4113 /* ??? Unfortunately, GCC needs to be able to prove the
4114 alignment of this offset and if it's a variable, it can't.
4115 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4116 right now, we have to put in an explicit multiply and
4117 divide by that value. */
4118 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4120 DECL_FIELD_OFFSET (gnu_field)
4122 (MULT_EXPR, sizetype,
4123 elaborate_expression_1
4124 (gnat_temp, gnat_temp,
4125 build_binary_op (EXACT_DIV_EXPR, sizetype,
4126 DECL_FIELD_OFFSET (gnu_field),
4127 size_int (DECL_OFFSET_ALIGN (gnu_field)
4129 get_identifier ("OFFSET"),
4131 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4133 /* ??? The context of gnu_field is not necessarily gnu_type so
4134 the MULT_EXPR node built above may not be marked by the call
4135 to create_type_decl below. Mark it manually for now. */
4136 if (global_bindings_p ())
4137 TREE_VISITED (DECL_FIELD_OFFSET (gnu_field)) = 1;
4141 gnu_type = build_qualified_type (gnu_type,
4142 (TYPE_QUALS (gnu_type)
4143 | (TYPE_QUAL_VOLATILE
4144 * Treat_As_Volatile (gnat_entity))));
4146 if (Is_Atomic (gnat_entity))
4147 check_ok_for_atomic (gnu_type, gnat_entity, false);
4149 if (Present (Alignment_Clause (gnat_entity)))
4150 TYPE_USER_ALIGN (gnu_type) = 1;
4152 if (Universal_Aliasing (gnat_entity))
4153 TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
4156 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4157 !Comes_From_Source (gnat_entity),
4158 debug_info_p, gnat_entity);
4160 TREE_TYPE (gnu_decl) = gnu_type;
4163 if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4165 gnu_type = TREE_TYPE (gnu_decl);
4167 /* Back-annotate the Alignment of the type if not already in the
4168 tree. Likewise for sizes. */
4169 if (Unknown_Alignment (gnat_entity))
4170 Set_Alignment (gnat_entity,
4171 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4173 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4175 /* If the size is self-referential, we annotate the maximum
4176 value of that size. */
4177 tree gnu_size = TYPE_SIZE (gnu_type);
4179 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4180 gnu_size = max_size (gnu_size, true);
4182 Set_Esize (gnat_entity, annotate_value (gnu_size));
4184 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4186 /* In this mode the tag and the parent components are not
4187 generated by the front-end, so the sizes must be adjusted
4189 int size_offset, new_size;
4191 if (Is_Derived_Type (gnat_entity))
4194 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4195 Set_Alignment (gnat_entity,
4196 Alignment (Etype (Base_Type (gnat_entity))));
4199 size_offset = POINTER_SIZE;
4201 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4202 Set_Esize (gnat_entity,
4203 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4204 / POINTER_SIZE) * POINTER_SIZE));
4205 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4209 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4210 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4213 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4214 DECL_ARTIFICIAL (gnu_decl) = 1;
4216 if (!debug_info_p && DECL_P (gnu_decl)
4217 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4218 && No (Renamed_Object (gnat_entity)))
4219 DECL_IGNORED_P (gnu_decl) = 1;
4221 /* If we haven't already, associate the ..._DECL node that we just made with
4222 the input GNAT entity node. */
4224 save_gnu_tree (gnat_entity, gnu_decl, false);
4226 /* If this is an enumeral or floating-point type, we were not able to set
4227 the bounds since they refer to the type. These bounds are always static.
4229 For enumeration types, also write debugging information and declare the
4230 enumeration literal table, if needed. */
4232 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4233 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4235 tree gnu_scalar_type = gnu_type;
4237 /* If this is a padded type, we need to use the underlying type. */
4238 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
4239 && TYPE_IS_PADDING_P (gnu_scalar_type))
4240 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4242 /* If this is a floating point type and we haven't set a floating
4243 point type yet, use this in the evaluation of the bounds. */
4244 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4245 longest_float_type_node = gnu_type;
4247 TYPE_MIN_VALUE (gnu_scalar_type)
4248 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4249 TYPE_MAX_VALUE (gnu_scalar_type)
4250 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4252 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4254 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
4256 /* Since this has both a typedef and a tag, avoid outputting
4258 DECL_ARTIFICIAL (gnu_decl) = 1;
4259 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
4263 /* If we deferred processing of incomplete types, re-enable it. If there
4264 were no other disables and we have some to process, do so. */
4265 if (this_deferred && --defer_incomplete_level == 0)
4267 if (defer_incomplete_list)
4269 struct incomplete *incp, *next;
4271 /* We are back to level 0 for the deferring of incomplete types.
4272 But processing these incomplete types below may itself require
4273 deferring, so preserve what we have and restart from scratch. */
4274 incp = defer_incomplete_list;
4275 defer_incomplete_list = NULL;
4277 /* For finalization, however, all types must be complete so we
4278 cannot do the same because deferred incomplete types may end up
4279 referencing each other. Process them all recursively first. */
4280 defer_finalize_level++;
4282 for (; incp; incp = next)
4287 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4288 gnat_to_gnu_type (incp->full_type));
4292 defer_finalize_level--;
4295 /* All the deferred incomplete types have been processed so we can
4296 now proceed with the finalization of the deferred types. */
4297 if (defer_finalize_level == 0 && defer_finalize_list)
4299 int toplev = global_bindings_p ();
4303 for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
4304 rest_of_decl_compilation (t, toplev, 0);
4306 VEC_free (tree, heap, defer_finalize_list);
4310 /* If we are not defining this type, see if it's in the incomplete list.
4311 If so, handle that list entry now. */
4312 else if (!definition)
4314 struct incomplete *incp;
4316 for (incp = defer_incomplete_list; incp; incp = incp->next)
4317 if (incp->old_type && incp->full_type == gnat_entity)
4319 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4320 TREE_TYPE (gnu_decl));
4321 incp->old_type = NULL_TREE;
4328 if (Is_Packed_Array_Type (gnat_entity)
4329 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4330 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4331 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4332 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4337 /* Similar, but if the returned value is a COMPONENT_REF, return the
4341 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4343 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4345 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4346 gnu_field = TREE_OPERAND (gnu_field, 1);
4351 /* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */
4354 rest_of_type_decl_compilation (tree t)
4356 /* We need to defer finalizing the type if incomplete types
4357 are being deferred or if they are being processed. */
4358 if (defer_incomplete_level || defer_finalize_level)
4359 VEC_safe_push (tree, heap, defer_finalize_list, t);
4361 rest_of_decl_compilation (t, global_bindings_p (), 0);
4364 /* Finalize any From_With_Type incomplete types. We do this after processing
4365 our compilation unit and after processing its spec, if this is a body. */
4368 finalize_from_with_types (void)
4370 struct incomplete *incp = defer_limited_with;
4371 struct incomplete *next;
4373 defer_limited_with = 0;
4374 for (; incp; incp = next)
4378 if (incp->old_type != 0)
4379 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4380 gnat_to_gnu_type (incp->full_type));
4385 /* Return the equivalent type to be used for GNAT_ENTITY, if it's a
4386 kind of type (such E_Task_Type) that has a different type which Gigi
4387 uses for its representation. If the type does not have a special type
4388 for its representation, return GNAT_ENTITY. If a type is supposed to
4389 exist, but does not, abort unless annotating types, in which case
4390 return Empty. If GNAT_ENTITY is Empty, return Empty. */
4393 Gigi_Equivalent_Type (Entity_Id gnat_entity)
4395 Entity_Id gnat_equiv = gnat_entity;
4397 if (No (gnat_entity))
4400 switch (Ekind (gnat_entity))
4402 case E_Class_Wide_Subtype:
4403 if (Present (Equivalent_Type (gnat_entity)))
4404 gnat_equiv = Equivalent_Type (gnat_entity);
4407 case E_Access_Protected_Subprogram_Type:
4408 case E_Anonymous_Access_Protected_Subprogram_Type:
4409 gnat_equiv = Equivalent_Type (gnat_entity);
4412 case E_Class_Wide_Type:
4413 gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
4414 ? Equivalent_Type (gnat_entity)
4415 : Root_Type (gnat_entity));
4419 case E_Task_Subtype:
4420 case E_Protected_Type:
4421 case E_Protected_Subtype:
4422 gnat_equiv = Corresponding_Record_Type (gnat_entity);
4429 gcc_assert (Present (gnat_equiv) || type_annotate_only);
4433 /* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
4434 using MECH as its passing mechanism, to be placed in the parameter
4435 list built for GNAT_SUBPROG. Assume a foreign convention for the
4436 latter if FOREIGN is true. Also set CICO to true if the parameter
4437 must use the copy-in copy-out implementation mechanism.
4439 The returned tree is a PARM_DECL, except for those cases where no
4440 parameter needs to be actually passed to the subprogram; the type
4441 of this "shadow" parameter is then returned instead. */
4444 gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
4445 Entity_Id gnat_subprog, bool foreign, bool *cico)
4447 tree gnu_param_name = get_entity_name (gnat_param);
4448 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
4449 bool in_param = (Ekind (gnat_param) == E_In_Parameter);
4450 bool by_return = false, by_component_ptr = false, by_ref = false;
4453 /* Copy-return is used only for the first parameter of a valued procedure.
4454 It's a copy mechanism for which a parameter is never allocated. */
4455 if (mech == By_Copy_Return)
4457 gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
4462 /* If this is either a foreign function or if the underlying type won't
4463 be passed by reference, strip off possible padding type. */
4464 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
4465 && TYPE_IS_PADDING_P (gnu_param_type))
4467 tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
4469 if (mech == By_Reference
4471 || (!must_pass_by_ref (unpadded_type)
4472 && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
4473 gnu_param_type = unpadded_type;
4476 /* If this is an IN parameter, it is read-only, so make a variant of the
4477 type that is read-only. ??? However, if this is an unconstrained array,
4478 that type can be very complex, so skip it for now. Likewise for any
4479 other self-referential type. */
4481 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
4482 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
4483 gnu_param_type = build_qualified_type (gnu_param_type,
4484 (TYPE_QUALS (gnu_param_type)
4485 | TYPE_QUAL_CONST));
4487 /* For foreign conventions, pass arrays as pointers to the element type.
4488 First check for unconstrained array and get the underlying array. */
4489 if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
4491 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
4493 /* VMS descriptors are themselves passed by reference. */
4494 if (mech == By_Descriptor)
4496 = build_pointer_type (build_vms_descriptor (gnu_param_type,
4497 Mechanism (gnat_param),
4500 /* Arrays are passed as pointers to element type for foreign conventions. */
4503 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
4505 /* Strip off any multi-dimensional entries, then strip
4506 off the last array to get the component type. */
4507 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
4508 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
4509 gnu_param_type = TREE_TYPE (gnu_param_type);
4511 by_component_ptr = true;
4512 gnu_param_type = TREE_TYPE (gnu_param_type);
4515 gnu_param_type = build_qualified_type (gnu_param_type,
4516 (TYPE_QUALS (gnu_param_type)
4517 | TYPE_QUAL_CONST));
4519 gnu_param_type = build_pointer_type (gnu_param_type);
4522 /* Fat pointers are passed as thin pointers for foreign conventions. */
4523 else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
4525 = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
4527 /* If we must pass or were requested to pass by reference, do so.
4528 If we were requested to pass by copy, do so.
4529 Otherwise, for foreign conventions, pass IN OUT or OUT parameters
4530 or aggregates by reference. For COBOL and Fortran, pass all
4531 integer and FP types that way too. For Convention Ada, use
4532 the standard Ada default. */
4533 else if (must_pass_by_ref (gnu_param_type)
4534 || mech == By_Reference
4537 && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
4539 && (Convention (gnat_subprog) == Convention_Fortran
4540 || Convention (gnat_subprog) == Convention_COBOL)
4541 && (INTEGRAL_TYPE_P (gnu_param_type)
4542 || FLOAT_TYPE_P (gnu_param_type)))
4544 && default_pass_by_ref (gnu_param_type)))))
4546 gnu_param_type = build_reference_type (gnu_param_type);
4550 /* Pass IN OUT or OUT parameters using copy-in copy-out mechanism. */
4554 if (mech == By_Copy && (by_ref || by_component_ptr))
4555 post_error ("?cannot pass & by copy", gnat_param);
4557 /* If this is an OUT parameter that isn't passed by reference and isn't
4558 a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
4559 it will be a VAR_DECL created when we process the procedure, so just
4560 return its type. For the special parameter of a valued procedure,
4563 An exception is made to cover the RM-6.4.1 rule requiring "by copy"
4564 OUT parameters with discriminants or implicit initial values to be
4565 handled like IN OUT parameters. These type are normally built as
4566 aggregates, hence passed by reference, except for some packed arrays
4567 which end up encoded in special integer types.
4569 The exception we need to make is then for packed arrays of records
4570 with discriminants or implicit initial values. We have no light/easy
4571 way to check for the latter case, so we merely check for packed arrays
4572 of records. This may lead to useless copy-in operations, but in very
4573 rare cases only, as these would be exceptions in a set of already
4574 exceptional situations. */
4575 if (Ekind (gnat_param) == E_Out_Parameter
4578 || (mech != By_Descriptor
4579 && !POINTER_TYPE_P (gnu_param_type)
4580 && !AGGREGATE_TYPE_P (gnu_param_type)))
4581 && !(Is_Array_Type (Etype (gnat_param))
4582 && Is_Packed (Etype (gnat_param))
4583 && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
4584 return gnu_param_type;
4586 gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
4587 by_ref || by_component_ptr || in_param);
4588 DECL_BY_REF_P (gnu_param) = by_ref;
4589 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
4590 DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
4591 DECL_POINTS_TO_READONLY_P (gnu_param)
4592 = (in_param && (by_ref || by_component_ptr));
4594 /* If no Mechanism was specified, indicate what we're using, then
4595 back-annotate it. */
4596 if (mech == Default)
4597 mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
4599 Set_Mechanism (gnat_param, mech);
4603 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4606 same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4608 while (Present (Corresponding_Discriminant (discr1)))
4609 discr1 = Corresponding_Discriminant (discr1);
4611 while (Present (Corresponding_Discriminant (discr2)))
4612 discr2 = Corresponding_Discriminant (discr2);
4615 Original_Record_Component (discr1) == Original_Record_Component (discr2);
4618 /* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
4619 a non-aliased component in the back-end sense. */
4622 array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
4624 /* If the type below this is a multi-array type, then
4625 this does not have aliased components. */
4626 if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
4627 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
4630 if (Has_Aliased_Components (gnat_type))
4633 return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
4636 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4637 be elaborated at the point of its definition, but do nothing else. */
4640 elaborate_entity (Entity_Id gnat_entity)
4642 switch (Ekind (gnat_entity))
4644 case E_Signed_Integer_Subtype:
4645 case E_Modular_Integer_Subtype:
4646 case E_Enumeration_Subtype:
4647 case E_Ordinary_Fixed_Point_Subtype:
4648 case E_Decimal_Fixed_Point_Subtype:
4649 case E_Floating_Point_Subtype:
4651 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4652 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4654 /* ??? Tests for avoiding static constraint error expression
4655 is needed until the front stops generating bogus conversions
4656 on bounds of real types. */
4658 if (!Raises_Constraint_Error (gnat_lb))
4659 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4660 1, 0, Needs_Debug_Info (gnat_entity));
4661 if (!Raises_Constraint_Error (gnat_hb))
4662 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4663 1, 0, Needs_Debug_Info (gnat_entity));
4669 Node_Id full_definition = Declaration_Node (gnat_entity);
4670 Node_Id record_definition = Type_Definition (full_definition);
4672 /* If this is a record extension, go a level further to find the
4673 record definition. */
4674 if (Nkind (record_definition) == N_Derived_Type_Definition)
4675 record_definition = Record_Extension_Part (record_definition);
4679 case E_Record_Subtype:
4680 case E_Private_Subtype:
4681 case E_Limited_Private_Subtype:
4682 case E_Record_Subtype_With_Private:
4683 if (Is_Constrained (gnat_entity)
4684 && Has_Discriminants (Base_Type (gnat_entity))
4685 && Present (Discriminant_Constraint (gnat_entity)))
4687 Node_Id gnat_discriminant_expr;
4688 Entity_Id gnat_field;
4690 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
4691 gnat_discriminant_expr
4692 = First_Elmt (Discriminant_Constraint (gnat_entity));
4693 Present (gnat_field);
4694 gnat_field = Next_Discriminant (gnat_field),
4695 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
4696 /* ??? For now, ignore access discriminants. */
4697 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
4698 elaborate_expression (Node (gnat_discriminant_expr),
4700 get_entity_name (gnat_field), 1, 0, 0);
4707 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4708 any entities on its entity chain similarly. */
4711 mark_out_of_scope (Entity_Id gnat_entity)
4713 Entity_Id gnat_sub_entity;
4714 unsigned int kind = Ekind (gnat_entity);
4716 /* If this has an entity list, process all in the list. */
4717 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
4718 || IN (kind, Private_Kind)
4719 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
4720 || kind == E_Function || kind == E_Generic_Function
4721 || kind == E_Generic_Package || kind == E_Generic_Procedure
4722 || kind == E_Loop || kind == E_Operator || kind == E_Package
4723 || kind == E_Package_Body || kind == E_Procedure
4724 || kind == E_Record_Type || kind == E_Record_Subtype
4725 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
4726 for (gnat_sub_entity = First_Entity (gnat_entity);
4727 Present (gnat_sub_entity);
4728 gnat_sub_entity = Next_Entity (gnat_sub_entity))
4729 if (Scope (gnat_sub_entity) == gnat_entity
4730 && gnat_sub_entity != gnat_entity)
4731 mark_out_of_scope (gnat_sub_entity);
4733 /* Now clear this if it has been defined, but only do so if it isn't
4734 a subprogram or parameter. We could refine this, but it isn't
4735 worth it. If this is statically allocated, it is supposed to
4736 hang around out of cope. */
4737 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
4738 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
4740 save_gnu_tree (gnat_entity, NULL_TREE, true);
4741 save_gnu_tree (gnat_entity, error_mark_node, true);
4745 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4746 is a multi-dimensional array type, do this recursively. */
4749 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
4751 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
4752 of a one-dimensional array, since the padding has the same alias set
4753 as the field type, but if it's a multi-dimensional array, we need to
4754 see the inner types. */
4755 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
4756 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
4757 || TYPE_IS_PADDING_P (gnu_old_type)))
4758 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
4760 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4761 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4762 so we need to go down to what does. */
4763 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
4765 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
4767 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
4768 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
4769 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
4770 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
4772 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
4773 record_component_aliases (gnu_new_type);
4776 /* Return a TREE_LIST describing the substitutions needed to reflect
4777 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4778 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4779 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
4780 gives the tree for the discriminant and TREE_VALUES is the replacement
4781 value. They are in the form of operands to substitute_in_expr.
4782 DEFINITION is as in gnat_to_gnu_entity. */
4785 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
4786 tree gnu_list, bool definition)
4788 Entity_Id gnat_discrim;
4792 gnat_type = Implementation_Base_Type (gnat_subtype);
4794 if (Has_Discriminants (gnat_type))
4795 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
4796 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
4797 Present (gnat_discrim);
4798 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
4799 gnat_value = Next_Elmt (gnat_value))
4800 /* Ignore access discriminants. */
4801 if (!Is_Access_Type (Etype (Node (gnat_value))))
4802 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
4803 elaborate_expression
4804 (Node (gnat_value), gnat_subtype,
4805 get_entity_name (gnat_discrim), definition,
4812 /* Return true if the size represented by GNU_SIZE can be handled by an
4813 allocation. If STATIC_P is true, consider only what can be done with a
4814 static allocation. */
4817 allocatable_size_p (tree gnu_size, bool static_p)
4819 HOST_WIDE_INT our_size;
4821 /* If this is not a static allocation, the only case we want to forbid
4822 is an overflowing size. That will be converted into a raise a
4825 return !(TREE_CODE (gnu_size) == INTEGER_CST
4826 && TREE_OVERFLOW (gnu_size));
4828 /* Otherwise, we need to deal with both variable sizes and constant
4829 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4830 since assemblers may not like very large sizes. */
4831 if (!host_integerp (gnu_size, 1))
4834 our_size = tree_low_cst (gnu_size, 1);
4835 return (int) our_size == our_size;
4838 /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
4839 NAME, ARGS and ERROR_POINT. */
4842 prepend_one_attribute_to (struct attrib ** attr_list,
4843 enum attr_type attr_type,
4846 Node_Id attr_error_point)
4848 struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
4850 attr->type = attr_type;
4851 attr->name = attr_name;
4852 attr->args = attr_args;
4853 attr->error_point = attr_error_point;
4855 attr->next = *attr_list;
4859 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
4862 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
4866 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
4867 gnat_temp = Next_Rep_Item (gnat_temp))
4868 if (Nkind (gnat_temp) == N_Pragma)
4870 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
4871 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
4872 enum attr_type etype;
4874 if (Present (gnat_assoc) && Present (First (gnat_assoc))
4875 && Present (Next (First (gnat_assoc)))
4876 && (Nkind (Expression (Next (First (gnat_assoc))))
4877 == N_String_Literal))
4879 gnu_arg0 = get_identifier (TREE_STRING_POINTER
4882 (First (gnat_assoc))))));
4883 if (Present (Next (Next (First (gnat_assoc))))
4884 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
4885 == N_String_Literal))
4886 gnu_arg1 = get_identifier (TREE_STRING_POINTER
4890 (First (gnat_assoc)))))));
4893 switch (Get_Pragma_Id (Chars (gnat_temp)))
4895 case Pragma_Machine_Attribute:
4896 etype = ATTR_MACHINE_ATTRIBUTE;
4899 case Pragma_Linker_Alias:
4900 etype = ATTR_LINK_ALIAS;
4903 case Pragma_Linker_Section:
4904 etype = ATTR_LINK_SECTION;
4907 case Pragma_Linker_Constructor:
4908 etype = ATTR_LINK_CONSTRUCTOR;
4911 case Pragma_Linker_Destructor:
4912 etype = ATTR_LINK_DESTRUCTOR;
4915 case Pragma_Weak_External:
4916 etype = ATTR_WEAK_EXTERNAL;
4924 /* Prepend to the list now. Make a list of the argument we might
4925 have, as GCC expects it. */
4926 prepend_one_attribute_to
4929 (gnu_arg1 != NULL_TREE)
4930 ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
4931 Present (Next (First (gnat_assoc)))
4932 ? Expression (Next (First (gnat_assoc))) : gnat_temp);
4936 /* Get the unpadded version of a GNAT type. */
4939 get_unpadded_type (Entity_Id gnat_entity)
4941 tree type = gnat_to_gnu_type (gnat_entity);
4943 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4944 type = TREE_TYPE (TYPE_FIELDS (type));
4949 /* Called when we need to protect a variable object using a save_expr. */
4952 maybe_variable (tree gnu_operand)
4954 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
4955 || TREE_CODE (gnu_operand) == SAVE_EXPR
4956 || TREE_CODE (gnu_operand) == NULL_EXPR)
4959 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
4961 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
4962 TREE_TYPE (gnu_operand),
4963 variable_size (TREE_OPERAND (gnu_operand, 0)));
4965 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
4966 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
4970 return variable_size (gnu_operand);
4973 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4974 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4975 return the GCC tree to use for that expression. GNU_NAME is the
4976 qualification to use if an external name is appropriate and DEFINITION is
4977 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4978 we need a result. Otherwise, we are just elaborating this for
4979 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4980 purposes even if it isn't needed for code generation. */
4983 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
4984 tree gnu_name, bool definition, bool need_value,
4989 /* If we already elaborated this expression (e.g., it was involved
4990 in the definition of a private type), use the old value. */
4991 if (present_gnu_tree (gnat_expr))
4992 return get_gnu_tree (gnat_expr);
4994 /* If we don't need a value and this is static or a discriminant, we
4995 don't need to do anything. */
4996 else if (!need_value
4997 && (Is_OK_Static_Expression (gnat_expr)
4998 || (Nkind (gnat_expr) == N_Identifier
4999 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
5002 /* Otherwise, convert this tree to its GCC equivalent. */
5004 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
5005 gnu_name, definition, need_debug);
5007 /* Save the expression in case we try to elaborate this entity again. Since
5008 this is not a DECL, don't check it. Don't save if it's a discriminant. */
5009 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
5010 save_gnu_tree (gnat_expr, gnu_expr, true);
5012 return need_value ? gnu_expr : error_mark_node;
5015 /* Similar, but take a GNU expression. */
5018 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
5019 tree gnu_expr, tree gnu_name, bool definition,
5022 tree gnu_decl = NULL_TREE;
5023 /* Strip any conversions to see if the expression is a readonly variable.
5024 ??? This really should remain readonly, but we have to think about
5025 the typing of the tree here. */
5026 tree gnu_inner_expr = remove_conversions (gnu_expr, true);
5027 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
5030 /* In most cases, we won't see a naked FIELD_DECL here because a
5031 discriminant reference will have been replaced with a COMPONENT_REF
5032 when the type is being elaborated. However, there are some cases
5033 involving child types where we will. So convert it to a COMPONENT_REF
5034 here. We have to hope it will be at the highest level of the
5035 expression in these cases. */
5036 if (TREE_CODE (gnu_expr) == FIELD_DECL)
5037 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
5038 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
5039 gnu_expr, NULL_TREE);
5041 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
5042 that is a constant, make a variable that is initialized to contain the
5043 bound when the package containing the definition is elaborated. If
5044 this entity is defined at top level and a bound or discriminant value
5045 isn't a constant or a reference to a discriminant, replace the bound
5046 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
5047 rely here on the fact that an expression cannot contain both the
5048 discriminant and some other variable. */
5050 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
5051 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
5052 && (TREE_READONLY (gnu_inner_expr)
5053 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
5054 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
5056 /* If this is a static expression or contains a discriminant, we don't
5057 need the variable for debugging (and can't elaborate anyway if a
5060 && (Is_OK_Static_Expression (gnat_expr)
5061 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
5064 /* Now create the variable if we need it. */
5065 if (need_debug || (expr_variable && expr_global))
5067 = create_var_decl (create_concat_name (gnat_entity,
5068 IDENTIFIER_POINTER (gnu_name)),
5069 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
5070 !need_debug, Is_Public (gnat_entity),
5071 !definition, false, NULL, gnat_entity);
5073 /* We only need to use this variable if we are in global context since GCC
5074 can do the right thing in the local case. */
5075 if (expr_global && expr_variable)
5077 else if (!expr_variable)
5080 return maybe_variable (gnu_expr);
5083 /* Create a record type that contains a SIZE bytes long field of TYPE with a
5084 starting bit position so that it is aligned to ALIGN bits, and leaving at
5085 least ROOM bytes free before the field. BASE_ALIGN is the alignment the
5086 record is guaranteed to get. */
5089 make_aligning_type (tree type, unsigned int align, tree size,
5090 unsigned int base_align, int room)
5092 /* We will be crafting a record type with one field at a position set to be
5093 the next multiple of ALIGN past record'address + room bytes. We use a
5094 record placeholder to express record'address. */
5096 tree record_type = make_node (RECORD_TYPE);
5097 tree record = build0 (PLACEHOLDER_EXPR, record_type);
5100 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
5102 /* The diagram below summarizes the shape of what we manipulate:
5104 <--------- pos ---------->
5105 { +------------+-------------+-----------------+
5106 record =>{ |############| ... | field (type) |
5107 { +------------+-------------+-----------------+
5108 |<-- room -->|<- voffset ->|<---- size ----->|
5111 record_addr vblock_addr
5113 Every length is in sizetype bytes there, except "pos" which has to be
5114 set as a bit position in the GCC tree for the record. */
5116 tree room_st = size_int (room);
5117 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
5118 tree voffset_st, pos, field;
5120 tree name = TYPE_NAME (type);
5122 if (TREE_CODE (name) == TYPE_DECL)
5123 name = DECL_NAME (name);
5125 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
5127 /* Compute VOFFSET and then POS. The next byte position multiple of some
5128 alignment after some address is obtained by "and"ing the alignment minus
5129 1 with the two's complement of the address. */
5131 voffset_st = size_binop (BIT_AND_EXPR,
5132 size_diffop (size_zero_node, vblock_addr_st),
5133 ssize_int ((align / BITS_PER_UNIT) - 1));
5135 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
5137 pos = size_binop (MULT_EXPR,
5138 convert (bitsizetype,
5139 size_binop (PLUS_EXPR, room_st, voffset_st)),
5142 /* Craft the GCC record representation. The sizes are set manually to
5143 account for the maximum possible value of voffset, which avoids complex
5144 self-references in the size expression and corresponds to what should be
5145 "alloc"ated for this type anyway.
5147 Use -1 as the 'addressable' indication for the field to prevent the
5148 creation of a bitfield. We don't need one, it would have damaging
5149 consequences on the alignment computation, and create_field_decl would
5150 make one without this special argument, for instance because of the
5151 complex position expression. */
5153 field = create_field_decl (get_identifier ("F"), type, record_type,
5155 TYPE_FIELDS (record_type) = field;
5157 TYPE_ALIGN (record_type) = base_align;
5158 TYPE_USER_ALIGN (record_type) = 1;
5160 TYPE_SIZE (record_type)
5161 = size_binop (PLUS_EXPR,
5162 size_binop (MULT_EXPR, convert (bitsizetype, size),
5164 bitsize_int (align + room * BITS_PER_UNIT));
5165 TYPE_SIZE_UNIT (record_type)
5166 = size_binop (PLUS_EXPR, size,
5167 size_int (room + align / BITS_PER_UNIT));
5169 copy_alias_set (record_type, type);
5173 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
5174 being used as the field type of a packed record. See if we can rewrite it
5175 as a record that has a non-BLKmode type, which we can pack tighter. If so,
5176 return the new type. If not, return the original type. */
5179 make_packable_type (tree type)
5181 tree new_type = make_node (TREE_CODE (type));
5182 tree field_list = NULL_TREE;
5185 /* Copy the name and flags from the old type to that of the new and set
5186 the alignment to try for an integral type. For QUAL_UNION_TYPE,
5187 also copy the size. */
5188 TYPE_NAME (new_type) = TYPE_NAME (type);
5189 TYPE_JUSTIFIED_MODULAR_P (new_type)
5190 = TYPE_JUSTIFIED_MODULAR_P (type);
5191 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
5193 if (TREE_CODE (type) == RECORD_TYPE)
5194 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
5195 else if (TREE_CODE (type) == QUAL_UNION_TYPE)
5197 TYPE_SIZE (new_type) = TYPE_SIZE (type);
5198 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
5201 TYPE_ALIGN (new_type)
5202 = ((HOST_WIDE_INT) 1
5203 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
5204 TYPE_USER_ALIGN (new_type) = 1;
5206 /* Now copy the fields, keeping the position and size. */
5207 for (old_field = TYPE_FIELDS (type); old_field;
5208 old_field = TREE_CHAIN (old_field))
5210 tree new_field_type = TREE_TYPE (old_field);
5213 if (TYPE_MODE (new_field_type) == BLKmode
5214 && (TREE_CODE (new_field_type) == RECORD_TYPE
5215 || TREE_CODE (new_field_type) == UNION_TYPE
5216 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
5217 && host_integerp (TYPE_SIZE (new_field_type), 1))
5218 new_field_type = make_packable_type (new_field_type);
5220 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
5221 new_type, TYPE_PACKED (type),
5222 DECL_SIZE (old_field),
5223 bit_position (old_field),
5224 !DECL_NONADDRESSABLE_P (old_field));
5226 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
5227 SET_DECL_ORIGINAL_FIELD
5228 (new_field, (DECL_ORIGINAL_FIELD (old_field)
5229 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
5231 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
5232 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
5234 TREE_CHAIN (new_field) = field_list;
5235 field_list = new_field;
5238 finish_record_type (new_type, nreverse (field_list), 1, true);
5239 copy_alias_set (new_type, type);
5241 /* Try harder to get a packable type if necessary, for example
5242 in case the record itself contains a BLKmode field. */
5243 if (TYPE_MODE (new_type) == BLKmode)
5244 TYPE_MODE (new_type)
5245 = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
5247 return TYPE_MODE (new_type) == BLKmode ? type : new_type;
5250 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
5251 if needed. We have already verified that SIZE and TYPE are large enough.
5253 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
5256 IS_USER_TYPE is true if we must be sure we complete the original type.
5258 DEFINITION is true if this type is being defined.
5260 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
5261 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
5265 maybe_pad_type (tree type, tree size, unsigned int align,
5266 Entity_Id gnat_entity, const char *name_trailer,
5267 bool is_user_type, bool definition, bool same_rm_size)
5269 tree orig_size = TYPE_SIZE (type);
5270 unsigned int orig_align = align;
5274 /* If TYPE is a padded type, see if it agrees with any size and alignment
5275 we were given. If so, return the original type. Otherwise, strip
5276 off the padding, since we will either be returning the inner type
5277 or repadding it. If no size or alignment is specified, use that of
5278 the original padded type. */
5280 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
5283 || operand_equal_p (round_up (size,
5284 MAX (align, TYPE_ALIGN (type))),
5285 round_up (TYPE_SIZE (type),
5286 MAX (align, TYPE_ALIGN (type))),
5288 && (align == 0 || align == TYPE_ALIGN (type)))
5292 size = TYPE_SIZE (type);
5294 align = TYPE_ALIGN (type);
5296 type = TREE_TYPE (TYPE_FIELDS (type));
5297 orig_size = TYPE_SIZE (type);
5300 /* If the size is either not being changed or is being made smaller (which
5301 is not done here (and is only valid for bitfields anyway), show the size
5302 isn't changing. Likewise, clear the alignment if it isn't being
5303 changed. Then return if we aren't doing anything. */
5306 && (operand_equal_p (size, orig_size, 0)
5307 || (TREE_CODE (orig_size) == INTEGER_CST
5308 && tree_int_cst_lt (size, orig_size))))
5311 if (align == TYPE_ALIGN (type))
5314 if (align == 0 && !size)
5317 /* We used to modify the record in place in some cases, but that could
5318 generate incorrect debugging information. So make a new record
5320 record = make_node (RECORD_TYPE);
5322 if (Present (gnat_entity))
5323 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5325 /* If we were making a type, complete the original type and give it a
5328 create_type_decl (get_entity_name (gnat_entity), type,
5329 NULL, !Comes_From_Source (gnat_entity),
5331 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5332 && DECL_IGNORED_P (TYPE_NAME (type))),
5335 /* If we are changing the alignment and the input type is a record with
5336 BLKmode and a small constant size, try to make a form that has an
5337 integral mode. That might allow this record to have an integral mode,
5338 which will be much more efficient. There is no point in doing this if a
5339 size is specified unless it is also smaller than the biggest alignment
5340 and it is incorrect to do this if the size of the original type is not a
5341 multiple of the alignment. */
5343 && TREE_CODE (type) == RECORD_TYPE
5344 && TYPE_MODE (type) == BLKmode
5345 && host_integerp (orig_size, 1)
5346 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
5348 || (TREE_CODE (size) == INTEGER_CST
5349 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
5350 && tree_low_cst (orig_size, 1) % align == 0)
5351 type = make_packable_type (type);
5353 field = create_field_decl (get_identifier ("F"), type, record, 0,
5354 NULL_TREE, bitsize_zero_node, 1);
5356 DECL_INTERNAL_P (field) = 1;
5357 TYPE_SIZE (record) = size ? size : orig_size;
5358 TYPE_SIZE_UNIT (record)
5359 = (size ? convert (sizetype,
5360 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node))
5361 : TYPE_SIZE_UNIT (type));
5363 TYPE_ALIGN (record) = align;
5365 TYPE_USER_ALIGN (record) = align;
5367 TYPE_IS_PADDING_P (record) = 1;
5368 TYPE_VOLATILE (record)
5369 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5370 /* Do not finalize it until after the auxiliary record is built. */
5371 finish_record_type (record, field, 1, true);
5373 /* Keep the RM_Size of the padded record as that of the old record
5375 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
5377 /* Unless debugging information isn't being written for the input type,
5378 write a record that shows what we are a subtype of and also make a
5379 variable that indicates our size, if variable. */
5380 if (TYPE_NAME (record) && AGGREGATE_TYPE_P (type)
5381 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
5382 || !DECL_IGNORED_P (TYPE_NAME (type))))
5384 tree marker = make_node (RECORD_TYPE);
5385 tree name = (TREE_CODE (TYPE_NAME (record)) == TYPE_DECL
5386 ? DECL_NAME (TYPE_NAME (record))
5387 : TYPE_NAME (record));
5388 tree orig_name = TYPE_NAME (type);
5390 if (TREE_CODE (orig_name) == TYPE_DECL)
5391 orig_name = DECL_NAME (orig_name);
5393 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5394 finish_record_type (marker,
5395 create_field_decl (orig_name, integer_type_node,
5396 marker, 0, NULL_TREE, NULL_TREE,
5400 if (size && TREE_CODE (size) != INTEGER_CST && definition)
5401 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5402 bitsizetype, TYPE_SIZE (record), false, false, false,
5403 false, NULL, gnat_entity);
5406 rest_of_record_type_compilation (record);
5408 /* If the size was widened explicitly, maybe give a warning. Take the
5409 original size as the maximum size of the input if there was an
5410 unconstrained record involved and round it up to the specified alignment,
5411 if one was specified. */
5412 if (CONTAINS_PLACEHOLDER_P (orig_size))
5413 orig_size = max_size (orig_size, true);
5416 orig_size = round_up (orig_size, align);
5418 if (size && Present (gnat_entity)
5419 && !operand_equal_p (size, orig_size, 0)
5420 && !(TREE_CODE (size) == INTEGER_CST
5421 && TREE_CODE (orig_size) == INTEGER_CST
5422 && tree_int_cst_lt (size, orig_size)))
5424 Node_Id gnat_error_node = Empty;
5426 if (Is_Packed_Array_Type (gnat_entity))
5427 gnat_entity = Associated_Node_For_Itype (gnat_entity);
5429 if ((Ekind (gnat_entity) == E_Component
5430 || Ekind (gnat_entity) == E_Discriminant)
5431 && Present (Component_Clause (gnat_entity)))
5432 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5433 else if (Present (Size_Clause (gnat_entity)))
5434 gnat_error_node = Expression (Size_Clause (gnat_entity));
5436 /* Generate message only for entities that come from source, since
5437 if we have an entity created by expansion, the message will be
5438 generated for some other corresponding source entity. */
5439 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5440 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5442 size_diffop (size, orig_size));
5444 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5445 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5446 gnat_entity, gnat_entity,
5447 size_diffop (size, orig_size));
5453 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5454 the value passed against the list of choices. */
5457 choices_to_gnu (tree operand, Node_Id choices)
5461 tree result = integer_zero_node;
5462 tree this_test, low = 0, high = 0, single = 0;
5464 for (choice = First (choices); Present (choice); choice = Next (choice))
5466 switch (Nkind (choice))
5469 low = gnat_to_gnu (Low_Bound (choice));
5470 high = gnat_to_gnu (High_Bound (choice));
5472 /* There's no good type to use here, so we might as well use
5473 integer_type_node. */
5475 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5476 build_binary_op (GE_EXPR, integer_type_node,
5478 build_binary_op (LE_EXPR, integer_type_node,
5483 case N_Subtype_Indication:
5484 gnat_temp = Range_Expression (Constraint (choice));
5485 low = gnat_to_gnu (Low_Bound (gnat_temp));
5486 high = gnat_to_gnu (High_Bound (gnat_temp));
5489 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5490 build_binary_op (GE_EXPR, integer_type_node,
5492 build_binary_op (LE_EXPR, integer_type_node,
5497 case N_Expanded_Name:
5498 /* This represents either a subtype range, an enumeration
5499 literal, or a constant Ekind says which. If an enumeration
5500 literal or constant, fall through to the next case. */
5501 if (Ekind (Entity (choice)) != E_Enumeration_Literal
5502 && Ekind (Entity (choice)) != E_Constant)
5504 tree type = gnat_to_gnu_type (Entity (choice));
5506 low = TYPE_MIN_VALUE (type);
5507 high = TYPE_MAX_VALUE (type);
5510 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5511 build_binary_op (GE_EXPR, integer_type_node,
5513 build_binary_op (LE_EXPR, integer_type_node,
5517 /* ... fall through ... */
5518 case N_Character_Literal:
5519 case N_Integer_Literal:
5520 single = gnat_to_gnu (choice);
5521 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5525 case N_Others_Choice:
5526 this_test = integer_one_node;
5533 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5540 /* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
5541 type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
5544 adjust_packed (tree field_type, tree record_type, int packed)
5546 /* If the field contains an item of variable size, we cannot pack it
5547 because we cannot create temporaries of non-fixed size. */
5548 if (is_variable_size (field_type))
5551 /* If the alignment of the record is specified and the field type
5552 is over-aligned, request Storage_Unit alignment for the field. */
5555 if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
5564 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5565 placed in GNU_RECORD_TYPE.
5567 PACKED is 1 if the enclosing record is packed, -1 if the enclosing
5568 record has Component_Alignment of Storage_Unit, -2 if the enclosing
5569 record has a specified alignment.
5571 DEFINITION is true if this field is for a record being defined. */
5574 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
5577 tree gnu_field_id = get_entity_name (gnat_field);
5578 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
5582 bool needs_strict_alignment
5583 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
5584 || Treat_As_Volatile (gnat_field));
5586 /* If this field requires strict alignment, we cannot pack it because
5587 it would very likely be under-aligned in the record. */
5588 if (needs_strict_alignment)
5591 packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
5593 /* For packed records, this is one of the few occasions on which we use
5594 the official RM size for discrete or fixed-point components, instead
5595 of the normal GNAT size stored in Esize. See description in Einfo:
5596 "Handling of Type'Size Values" for further details. */
5599 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
5600 gnat_field, FIELD_DECL, false, true);
5602 if (Known_Static_Esize (gnat_field))
5603 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5604 gnat_field, FIELD_DECL, false, true);
5606 /* If we have a specified size that's smaller than that of the field type,
5607 or a position is specified, and the field type is also a record that's
5608 BLKmode and with a small constant size, see if we can get an integral
5609 mode form of the type when appropriate. If we can, show a size was
5610 specified for the field if there wasn't one already, so we know to make
5611 this a bitfield and avoid making things wider.
5613 Doing this is first useful if the record is packed because we can then
5614 place the field at a non-byte-aligned position and so achieve tighter
5617 This is in addition *required* if the field shares a byte with another
5618 field and the front-end lets the back-end handle the references, because
5619 GCC does not handle BLKmode bitfields properly.
5621 We avoid the transformation if it is not required or potentially useful,
5622 as it might entail an increase of the field's alignment and have ripple
5623 effects on the outer record type. A typical case is a field known to be
5624 byte aligned and not to share a byte with another field.
5626 Besides, we don't even look the possibility of a transformation in cases
5627 known to be in error already, for instance when an invalid size results
5628 from a component clause. */
5630 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5631 && TYPE_MODE (gnu_field_type) == BLKmode
5632 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
5633 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
5636 && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))
5637 || (Present (Component_Clause (gnat_field)) && gnu_size != 0)))
5639 /* See what the alternate type and size would be. */
5640 tree gnu_packable_type = make_packable_type (gnu_field_type);
5642 bool has_byte_aligned_clause
5643 = Present (Component_Clause (gnat_field))
5644 && (UI_To_Int (Component_Bit_Offset (gnat_field))
5645 % BITS_PER_UNIT == 0);
5647 /* Compute whether we should avoid the substitution. */
5649 /* There is no point substituting if there is no change... */
5650 = (gnu_packable_type == gnu_field_type)
5651 /* ... nor when the field is known to be byte aligned and not to
5652 share a byte with another field. */
5653 || (has_byte_aligned_clause
5654 && value_factor_p (gnu_size, BITS_PER_UNIT))
5655 /* The size of an aliased field must be an exact multiple of the
5656 type's alignment, which the substitution might increase. Reject
5657 substitutions that would so invalidate a component clause when the
5658 specified position is byte aligned, as the change would have no
5659 real benefit from the packing standpoint anyway. */
5660 || (Is_Aliased (gnat_field)
5661 && has_byte_aligned_clause
5662 && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
5664 /* Substitute unless told otherwise. */
5667 gnu_field_type = gnu_packable_type;
5670 gnu_size = rm_size (gnu_field_type);
5674 /* If we are packing the record and the field is BLKmode, round the
5675 size up to a byte boundary. */
5676 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
5677 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
5679 if (Present (Component_Clause (gnat_field)))
5681 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
5682 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5683 gnat_field, FIELD_DECL, false, true);
5685 /* Ensure the position does not overlap with the parent subtype,
5687 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
5690 = gnat_to_gnu_type (Parent_Subtype
5691 (Underlying_Type (Scope (gnat_field))));
5693 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
5694 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
5697 ("offset of& must be beyond parent{, minimum allowed is ^}",
5698 First_Bit (Component_Clause (gnat_field)), gnat_field,
5699 TYPE_SIZE_UNIT (gnu_parent));
5703 /* If this field needs strict alignment, ensure the record is
5704 sufficiently aligned and that that position and size are
5705 consistent with the alignment. */
5706 if (needs_strict_alignment)
5708 tree gnu_rounded_size = round_up (rm_size (gnu_field_type),
5709 TYPE_ALIGN (gnu_field_type));
5711 TYPE_ALIGN (gnu_record_type)
5712 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
5714 /* If Atomic, the size must match exactly that of the field. */
5715 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
5716 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
5719 ("atomic field& must be natural size of type{ (^)}",
5720 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5721 TYPE_SIZE (gnu_field_type));
5723 gnu_size = NULL_TREE;
5726 /* If Aliased, the size must match exactly the rounded size. We
5727 used to be more accommodating here and accept greater sizes, but
5728 fully supporting this case on big-endian platforms would require
5729 switching to a more involved layout for the field. */
5730 else if (Is_Aliased (gnat_field)
5732 && ! operand_equal_p (gnu_size, gnu_rounded_size, 0))
5735 ("size of aliased field& must be ^ bits",
5736 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5738 gnu_size = NULL_TREE;
5741 if (!integer_zerop (size_binop
5742 (TRUNC_MOD_EXPR, gnu_pos,
5743 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
5745 if (Is_Aliased (gnat_field))
5747 ("position of aliased field& must be multiple of ^ bits",
5748 First_Bit (Component_Clause (gnat_field)), gnat_field,
5749 TYPE_ALIGN (gnu_field_type));
5751 else if (Treat_As_Volatile (gnat_field))
5753 ("position of volatile field& must be multiple of ^ bits",
5754 First_Bit (Component_Clause (gnat_field)), gnat_field,
5755 TYPE_ALIGN (gnu_field_type));
5757 else if (Strict_Alignment (Etype (gnat_field)))
5759 ("position of & with aliased or tagged components not multiple of ^ bits",
5760 First_Bit (Component_Clause (gnat_field)), gnat_field,
5761 TYPE_ALIGN (gnu_field_type));
5765 gnu_pos = NULL_TREE;
5769 if (Is_Atomic (gnat_field))
5770 check_ok_for_atomic (gnu_field_type, gnat_field, false);
5773 /* If the record has rep clauses and this is the tag field, make a rep
5774 clause for it as well. */
5775 else if (Has_Specified_Layout (Scope (gnat_field))
5776 && Chars (gnat_field) == Name_uTag)
5778 gnu_pos = bitsize_zero_node;
5779 gnu_size = TYPE_SIZE (gnu_field_type);
5782 /* We need to make the size the maximum for the type if it is
5783 self-referential and an unconstrained type. In that case, we can't
5784 pack the field since we can't make a copy to align it. */
5785 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5787 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
5788 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
5790 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
5794 /* If no size is specified (or if there was an error), don't specify a
5797 gnu_pos = NULL_TREE;
5800 /* If the field's type is justified modular, we would need to remove
5801 the wrapper to (better) meet the layout requirements. However we
5802 can do so only if the field is not aliased to preserve the unique
5803 layout and if the prescribed size is not greater than that of the
5804 packed array to preserve the justification. */
5805 if (!needs_strict_alignment
5806 && TREE_CODE (gnu_field_type) == RECORD_TYPE
5807 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
5808 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
5810 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5813 = make_type_from_size (gnu_field_type, gnu_size,
5814 Has_Biased_Representation (gnat_field));
5815 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
5816 "PAD", false, definition, true);
5819 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
5820 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
5822 /* Now create the decl for the field. */
5823 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
5824 packed, gnu_size, gnu_pos,
5825 Is_Aliased (gnat_field));
5826 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
5827 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
5829 if (Ekind (gnat_field) == E_Discriminant)
5830 DECL_DISCRIMINANT_NUMBER (gnu_field)
5831 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
5836 /* Return true if TYPE is a type with variable size, a padding type with a
5837 field of variable size or is a record that has a field such a field. */
5840 is_variable_size (tree type)
5844 /* We need not be concerned about this at all if we don't have
5845 strict alignment. */
5846 if (!STRICT_ALIGNMENT)
5848 else if (!TREE_CONSTANT (TYPE_SIZE (type)))
5850 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
5851 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
5853 else if (TREE_CODE (type) != RECORD_TYPE
5854 && TREE_CODE (type) != UNION_TYPE
5855 && TREE_CODE (type) != QUAL_UNION_TYPE)
5858 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
5859 if (is_variable_size (TREE_TYPE (field)))
5865 /* qsort comparer for the bit positions of two record components. */
5868 compare_field_bitpos (const PTR rt1, const PTR rt2)
5870 const_tree const field1 = * (const_tree const *) rt1;
5871 const_tree const field2 = * (const_tree const *) rt2;
5873 = tree_int_cst_compare (bit_position (field1), bit_position (field2));
5875 return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
5878 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5879 of GCC trees for fields that are in the record and have already been
5880 processed. When called from gnat_to_gnu_entity during the processing of a
5881 record type definition, the GCC nodes for the discriminants will be on
5882 the chain. The other calls to this function are recursive calls from
5883 itself for the Component_List of a variant and the chain is empty.
5885 PACKED is 1 if this is for a packed record, -1 if this is for a record
5886 with Component_Alignment of Storage_Unit, -2 if this is for a record
5887 with a specified alignment.
5889 DEFINITION is true if we are defining this record.
5891 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5892 with a rep clause is to be added. If it is nonzero, that is all that
5893 should be done with such fields.
5895 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
5896 laying out the record. This means the alignment only serves to force fields
5897 to be bitfields, but not require the record to be that aligned. This is
5900 ALL_REP, if true, means a rep clause was found for all the fields. This
5901 simplifies the logic since we know we're not in the mixed case.
5903 DO_NOT_FINALIZE, if true, means that the record type is expected to be
5904 modified afterwards so it will not be sent to the back-end for finalization.
5906 UNCHECKED_UNION, if true, means that we are building a type for a record
5907 with a Pragma Unchecked_Union.
5909 The processing of the component list fills in the chain with all of the
5910 fields of the record and then the record type is finished. */
5913 components_to_record (tree gnu_record_type, Node_Id component_list,
5914 tree gnu_field_list, int packed, bool definition,
5915 tree *p_gnu_rep_list, bool cancel_alignment,
5916 bool all_rep, bool do_not_finalize, bool unchecked_union)
5918 Node_Id component_decl;
5919 Entity_Id gnat_field;
5920 Node_Id variant_part;
5921 tree gnu_our_rep_list = NULL_TREE;
5922 tree gnu_field, gnu_last;
5923 bool layout_with_rep = false;
5924 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
5926 /* For each variable within each component declaration create a GCC field
5927 and add it to the list, skipping any pragmas in the list. */
5928 if (Present (Component_Items (component_list)))
5929 for (component_decl = First_Non_Pragma (Component_Items (component_list));
5930 Present (component_decl);
5931 component_decl = Next_Non_Pragma (component_decl))
5933 gnat_field = Defining_Entity (component_decl);
5935 if (Chars (gnat_field) == Name_uParent)
5936 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
5939 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
5940 packed, definition);
5942 /* If this is the _Tag field, put it before any discriminants,
5943 instead of after them as is the case for all other fields.
5944 Ignore field of void type if only annotating. */
5945 if (Chars (gnat_field) == Name_uTag)
5946 gnu_field_list = chainon (gnu_field_list, gnu_field);
5949 TREE_CHAIN (gnu_field) = gnu_field_list;
5950 gnu_field_list = gnu_field;
5954 save_gnu_tree (gnat_field, gnu_field, false);
5957 /* At the end of the component list there may be a variant part. */
5958 variant_part = Variant_Part (component_list);
5960 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5961 mutually exclusive and should go in the same memory. To do this we need
5962 to treat each variant as a record whose elements are created from the
5963 component list for the variant. So here we create the records from the
5964 lists for the variants and put them all into the QUAL_UNION_TYPE.
5965 If this is an Unchecked_Union, we make a UNION_TYPE instead or
5966 use GNU_RECORD_TYPE if there are no fields so far. */
5967 if (Present (variant_part))
5969 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
5971 tree gnu_name = TYPE_NAME (gnu_record_type);
5973 = concat_id_with_name (get_identifier (Get_Name_String
5974 (Chars (Name (variant_part)))),
5976 tree gnu_union_type;
5977 tree gnu_union_name;
5978 tree gnu_union_field;
5979 tree gnu_variant_list = NULL_TREE;
5981 if (TREE_CODE (gnu_name) == TYPE_DECL)
5982 gnu_name = DECL_NAME (gnu_name);
5984 gnu_union_name = concat_id_with_name (gnu_name,
5985 IDENTIFIER_POINTER (gnu_var_name));
5987 if (!gnu_field_list && TREE_CODE (gnu_record_type) == UNION_TYPE)
5988 gnu_union_type = gnu_record_type;
5993 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
5995 TYPE_NAME (gnu_union_type) = gnu_union_name;
5996 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
5999 for (variant = First_Non_Pragma (Variants (variant_part));
6001 variant = Next_Non_Pragma (variant))
6003 tree gnu_variant_type = make_node (RECORD_TYPE);
6004 tree gnu_inner_name;
6007 Get_Variant_Encoding (variant);
6008 gnu_inner_name = get_identifier (Name_Buffer);
6009 TYPE_NAME (gnu_variant_type)
6010 = concat_id_with_name (gnu_union_name,
6011 IDENTIFIER_POINTER (gnu_inner_name));
6013 /* Set the alignment of the inner type in case we need to make
6014 inner objects into bitfields, but then clear it out
6015 so the record actually gets only the alignment required. */
6016 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
6017 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
6019 /* Similarly, if the outer record has a size specified and all fields
6020 have record rep clauses, we can propagate the size into the
6022 if (all_rep_and_size)
6024 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
6025 TYPE_SIZE_UNIT (gnu_variant_type)
6026 = TYPE_SIZE_UNIT (gnu_record_type);
6029 /* Create the record type for the variant. Note that we defer
6030 finalizing it until after we are sure to actually use it. */
6031 components_to_record (gnu_variant_type, Component_List (variant),
6032 NULL_TREE, packed, definition,
6033 &gnu_our_rep_list, !all_rep_and_size, all_rep,
6034 true, unchecked_union);
6036 gnu_qual = choices_to_gnu (gnu_discriminant,
6037 Discrete_Choices (variant));
6039 Set_Present_Expr (variant, annotate_value (gnu_qual));
6041 /* If this is an Unchecked_Union and we have exactly one field,
6042 use that field here. */
6043 if (unchecked_union && TYPE_FIELDS (gnu_variant_type)
6044 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
6045 gnu_field = TYPE_FIELDS (gnu_variant_type);
6048 /* Deal with packedness like in gnat_to_gnu_field. */
6050 = adjust_packed (gnu_variant_type, gnu_record_type, packed);
6052 /* Finalize the record type now. We used to throw away
6053 empty records but we no longer do that because we need
6054 them to generate complete debug info for the variant;
6055 otherwise, the union type definition will be lacking
6056 the fields associated with these empty variants. */
6057 rest_of_record_type_compilation (gnu_variant_type);
6059 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
6060 gnu_union_type, field_packed,
6062 ? TYPE_SIZE (gnu_variant_type)
6065 ? bitsize_zero_node : 0),
6068 DECL_INTERNAL_P (gnu_field) = 1;
6070 if (!unchecked_union)
6071 DECL_QUALIFIER (gnu_field) = gnu_qual;
6074 TREE_CHAIN (gnu_field) = gnu_variant_list;
6075 gnu_variant_list = gnu_field;
6078 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
6079 if (gnu_variant_list)
6081 if (all_rep_and_size)
6083 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
6084 TYPE_SIZE_UNIT (gnu_union_type)
6085 = TYPE_SIZE_UNIT (gnu_record_type);
6088 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
6089 all_rep_and_size ? 1 : 0, false);
6091 /* If GNU_UNION_TYPE is our record type, it means we must have an
6092 Unchecked_Union with no fields. Verify that and, if so, just
6094 if (gnu_union_type == gnu_record_type)
6096 gcc_assert (!gnu_field_list && unchecked_union);
6101 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
6103 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
6104 all_rep ? bitsize_zero_node : 0, 0);
6106 DECL_INTERNAL_P (gnu_union_field) = 1;
6107 TREE_CHAIN (gnu_union_field) = gnu_field_list;
6108 gnu_field_list = gnu_union_field;
6112 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
6113 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
6114 in a separate pass since we want to handle the discriminants but can't
6115 play with them until we've used them in debugging data above.
6117 ??? Note: if we then reorder them, debugging information will be wrong,
6118 but there's nothing that can be done about this at the moment. */
6119 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
6121 if (DECL_FIELD_OFFSET (gnu_field))
6123 tree gnu_next = TREE_CHAIN (gnu_field);
6126 gnu_field_list = gnu_next;
6128 TREE_CHAIN (gnu_last) = gnu_next;
6130 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
6131 gnu_our_rep_list = gnu_field;
6132 gnu_field = gnu_next;
6136 gnu_last = gnu_field;
6137 gnu_field = TREE_CHAIN (gnu_field);
6141 /* If we have any items in our rep'ed field list, it is not the case that all
6142 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
6143 set it and ignore the items. */
6144 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
6145 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
6146 else if (gnu_our_rep_list)
6148 /* Otherwise, sort the fields by bit position and put them into their
6149 own record if we have any fields without rep clauses. */
6151 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
6152 int len = list_length (gnu_our_rep_list);
6153 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
6156 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
6157 gnu_field = TREE_CHAIN (gnu_field), i++)
6158 gnu_arr[i] = gnu_field;
6160 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
6162 /* Put the fields in the list in order of increasing position, which
6163 means we start from the end. */
6164 gnu_our_rep_list = NULL_TREE;
6165 for (i = len - 1; i >= 0; i--)
6167 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
6168 gnu_our_rep_list = gnu_arr[i];
6169 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
6174 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
6175 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
6176 gnu_record_type, 0, 0, 0, 1);
6177 DECL_INTERNAL_P (gnu_field) = 1;
6178 gnu_field_list = chainon (gnu_field_list, gnu_field);
6182 layout_with_rep = true;
6183 gnu_field_list = nreverse (gnu_our_rep_list);
6187 if (cancel_alignment)
6188 TYPE_ALIGN (gnu_record_type) = 0;
6190 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
6191 layout_with_rep ? 1 : 0, do_not_finalize);
6194 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
6195 placed into an Esize, Component_Bit_Offset, or Component_Size value
6196 in the GNAT tree. */
6199 annotate_value (tree gnu_size)
6201 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
6203 Node_Ref_Or_Val ops[3], ret;
6206 struct tree_int_map **h = NULL;
6208 /* See if we've already saved the value for this node. */
6209 if (EXPR_P (gnu_size))
6211 struct tree_int_map in;
6212 if (!annotate_value_cache)
6213 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
6214 tree_int_map_eq, 0);
6215 in.base.from = gnu_size;
6216 h = (struct tree_int_map **)
6217 htab_find_slot (annotate_value_cache, &in, INSERT);
6220 return (Node_Ref_Or_Val) (*h)->to;
6223 /* If we do not return inside this switch, TCODE will be set to the
6224 code to use for a Create_Node operand and LEN (set above) will be
6225 the number of recursive calls for us to make. */
6227 switch (TREE_CODE (gnu_size))
6230 if (TREE_OVERFLOW (gnu_size))
6233 /* This may have come from a conversion from some smaller type,
6234 so ensure this is in bitsizetype. */
6235 gnu_size = convert (bitsizetype, gnu_size);
6237 /* For negative values, use NEGATE_EXPR of the supplied value. */
6238 if (tree_int_cst_sgn (gnu_size) < 0)
6240 /* The ridiculous code below is to handle the case of the largest
6241 negative integer. */
6242 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
6243 bool adjust = false;
6246 if (TREE_OVERFLOW (negative_size))
6249 = size_binop (MINUS_EXPR, bitsize_zero_node,
6250 size_binop (PLUS_EXPR, gnu_size,
6255 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
6257 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
6259 return annotate_value (temp);
6262 if (!host_integerp (gnu_size, 1))
6265 size = tree_low_cst (gnu_size, 1);
6267 /* This peculiar test is to make sure that the size fits in an int
6268 on machines where HOST_WIDE_INT is not "int". */
6269 if (tree_low_cst (gnu_size, 1) == size)
6270 return UI_From_Int (size);
6275 /* The only case we handle here is a simple discriminant reference. */
6276 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
6277 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
6278 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
6279 return Create_Node (Discrim_Val,
6280 annotate_value (DECL_DISCRIMINANT_NUMBER
6281 (TREE_OPERAND (gnu_size, 1))),
6286 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
6287 return annotate_value (TREE_OPERAND (gnu_size, 0));
6289 /* Now just list the operations we handle. */
6290 case COND_EXPR: tcode = Cond_Expr; break;
6291 case PLUS_EXPR: tcode = Plus_Expr; break;
6292 case MINUS_EXPR: tcode = Minus_Expr; break;
6293 case MULT_EXPR: tcode = Mult_Expr; break;
6294 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
6295 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
6296 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
6297 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
6298 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
6299 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
6300 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
6301 case NEGATE_EXPR: tcode = Negate_Expr; break;
6302 case MIN_EXPR: tcode = Min_Expr; break;
6303 case MAX_EXPR: tcode = Max_Expr; break;
6304 case ABS_EXPR: tcode = Abs_Expr; break;
6305 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
6306 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
6307 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
6308 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
6309 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
6310 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
6311 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
6312 case LT_EXPR: tcode = Lt_Expr; break;
6313 case LE_EXPR: tcode = Le_Expr; break;
6314 case GT_EXPR: tcode = Gt_Expr; break;
6315 case GE_EXPR: tcode = Ge_Expr; break;
6316 case EQ_EXPR: tcode = Eq_Expr; break;
6317 case NE_EXPR: tcode = Ne_Expr; break;
6323 /* Now get each of the operands that's relevant for this code. If any
6324 cannot be expressed as a repinfo node, say we can't. */
6325 for (i = 0; i < 3; i++)
6328 for (i = 0; i < len; i++)
6330 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6331 if (ops[i] == No_Uint)
6335 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6337 /* Save the result in the cache. */
6340 *h = ggc_alloc (sizeof (struct tree_int_map));
6341 (*h)->base.from = gnu_size;
6348 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6349 GCC type, set Component_Bit_Offset and Esize to the position and size
6353 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6357 Entity_Id gnat_field;
6359 /* We operate by first making a list of all fields and their positions
6360 (we can get the sizes easily at any time) by a recursive call
6361 and then update all the sizes into the tree. */
6362 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6363 size_zero_node, bitsize_zero_node,
6366 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6367 gnat_field = Next_Entity (gnat_field))
6368 if ((Ekind (gnat_field) == E_Component
6369 || (Ekind (gnat_field) == E_Discriminant
6370 && !Is_Unchecked_Union (Scope (gnat_field)))))
6372 tree parent_offset = bitsize_zero_node;
6374 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6379 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6381 /* In this mode the tag and parent components have not been
6382 generated, so we add the appropriate offset to each
6383 component. For a component appearing in the current
6384 extension, the offset is the size of the parent. */
6385 if (Is_Derived_Type (gnat_entity)
6386 && Original_Record_Component (gnat_field) == gnat_field)
6388 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6391 parent_offset = bitsize_int (POINTER_SIZE);
6394 Set_Component_Bit_Offset
6397 (size_binop (PLUS_EXPR,
6398 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6399 TREE_VALUE (TREE_VALUE
6400 (TREE_VALUE (gnu_entry)))),
6403 Set_Esize (gnat_field,
6404 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6406 else if (Is_Tagged_Type (gnat_entity)
6407 && Is_Derived_Type (gnat_entity))
6409 /* If there is no gnu_entry, this is an inherited component whose
6410 position is the same as in the parent type. */
6411 Set_Component_Bit_Offset
6413 Component_Bit_Offset (Original_Record_Component (gnat_field)));
6414 Set_Esize (gnat_field,
6415 Esize (Original_Record_Component (gnat_field)));
6420 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6421 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6422 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6423 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6424 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6425 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6429 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6430 tree gnu_bitpos, unsigned int offset_align)
6433 tree gnu_result = gnu_list;
6435 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6436 gnu_field = TREE_CHAIN (gnu_field))
6438 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6439 DECL_FIELD_BIT_OFFSET (gnu_field));
6440 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6441 DECL_FIELD_OFFSET (gnu_field));
6442 unsigned int our_offset_align
6443 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6446 = tree_cons (gnu_field,
6447 tree_cons (gnu_our_offset,
6448 tree_cons (size_int (our_offset_align),
6449 gnu_our_bitpos, NULL_TREE),
6453 if (DECL_INTERNAL_P (gnu_field))
6455 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6456 gnu_our_offset, gnu_our_bitpos,
6463 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6464 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6465 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6466 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6467 for the size of a field. COMPONENT_P is true if we are being called
6468 to process the Component_Size of GNAT_OBJECT. This is used for error
6469 message handling and to indicate to use the object size of GNU_TYPE.
6470 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6471 it means that a size of zero should be treated as an unspecified size. */
6474 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6475 enum tree_code kind, bool component_p, bool zero_ok)
6477 Node_Id gnat_error_node;
6479 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
6482 /* Find the node to use for errors. */
6483 if ((Ekind (gnat_object) == E_Component
6484 || Ekind (gnat_object) == E_Discriminant)
6485 && Present (Component_Clause (gnat_object)))
6486 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6487 else if (Present (Size_Clause (gnat_object)))
6488 gnat_error_node = Expression (Size_Clause (gnat_object));
6490 gnat_error_node = gnat_object;
6492 /* Return 0 if no size was specified, either because Esize was not Present or
6493 the specified size was zero. */
6494 if (No (uint_size) || uint_size == No_Uint)
6497 /* Get the size as a tree. Give an error if a size was specified, but cannot
6498 be represented as in sizetype. */
6499 size = UI_To_gnu (uint_size, bitsizetype);
6500 if (TREE_OVERFLOW (size))
6502 post_error_ne (component_p ? "component size of & is too large"
6503 : "size of & is too large",
6504 gnat_error_node, gnat_object);
6508 /* Ignore a negative size since that corresponds to our back-annotation.
6509 Also ignore a zero size unless a size clause exists. */
6510 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6513 /* The size of objects is always a multiple of a byte. */
6514 if (kind == VAR_DECL
6515 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6518 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6519 gnat_error_node, gnat_object);
6521 post_error_ne ("size for& is not a multiple of Storage_Unit",
6522 gnat_error_node, gnat_object);
6526 /* If this is an integral type or a packed array type, the front-end has
6527 verified the size, so we need not do it here (which would entail
6528 checking against the bounds). However, if this is an aliased object, it
6529 may not be smaller than the type of the object. */
6530 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
6531 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
6534 /* If the object is a record that contains a template, add the size of
6535 the template to the specified size. */
6536 if (TREE_CODE (gnu_type) == RECORD_TYPE
6537 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6538 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
6540 /* Modify the size of the type to be that of the maximum size if it has a
6541 discriminant or the size of a thin pointer if this is a fat pointer. */
6542 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
6543 type_size = max_size (type_size, true);
6544 else if (TYPE_FAT_POINTER_P (gnu_type))
6545 type_size = bitsize_int (POINTER_SIZE);
6547 /* If this is an access type, the minimum size is that given by the smallest
6548 integral mode that's valid for pointers. */
6549 if (TREE_CODE (gnu_type) == POINTER_TYPE)
6551 enum machine_mode p_mode;
6553 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
6554 !targetm.valid_pointer_mode (p_mode);
6555 p_mode = GET_MODE_WIDER_MODE (p_mode))
6558 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
6561 /* If the size of the object is a constant, the new size must not be
6563 if (TREE_CODE (type_size) != INTEGER_CST
6564 || TREE_OVERFLOW (type_size)
6565 || tree_int_cst_lt (size, type_size))
6569 ("component size for& too small{, minimum allowed is ^}",
6570 gnat_error_node, gnat_object, type_size);
6572 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
6573 gnat_error_node, gnat_object, type_size);
6575 if (kind == VAR_DECL && !component_p
6576 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
6577 && !tree_int_cst_lt (size, rm_size (gnu_type)))
6578 post_error_ne_tree_2
6579 ("\\size of ^ is not a multiple of alignment (^ bits)",
6580 gnat_error_node, gnat_object, rm_size (gnu_type),
6581 TYPE_ALIGN (gnu_type));
6583 else if (INTEGRAL_TYPE_P (gnu_type))
6584 post_error_ne ("\\size would be legal if & were not aliased!",
6585 gnat_error_node, gnat_object);
6593 /* Similarly, but both validate and process a value of RM_Size. This
6594 routine is only called for types. */
6597 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
6599 /* Only give an error if a Value_Size clause was explicitly given.
6600 Otherwise, we'd be duplicating an error on the Size clause. */
6601 Node_Id gnat_attr_node
6602 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
6603 tree old_size = rm_size (gnu_type);
6606 /* Get the size as a tree. Do nothing if none was specified, either
6607 because RM_Size was not Present or if the specified size was zero.
6608 Give an error if a size was specified, but cannot be represented as
6610 if (No (uint_size) || uint_size == No_Uint)
6613 size = UI_To_gnu (uint_size, bitsizetype);
6614 if (TREE_OVERFLOW (size))
6616 if (Present (gnat_attr_node))
6617 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
6623 /* Ignore a negative size since that corresponds to our back-annotation.
6624 Also ignore a zero size unless a size clause exists, a Value_Size
6625 clause exists, or this is an integer type, in which case the
6626 front end will have always set it. */
6627 else if (tree_int_cst_sgn (size) < 0
6628 || (integer_zerop (size) && No (gnat_attr_node)
6629 && !Has_Size_Clause (gnat_entity)
6630 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
6633 /* If the old size is self-referential, get the maximum size. */
6634 if (CONTAINS_PLACEHOLDER_P (old_size))
6635 old_size = max_size (old_size, true);
6637 /* If the size of the object is a constant, the new size must not be
6638 smaller (the front end checks this for scalar types). */
6639 if (TREE_CODE (old_size) != INTEGER_CST
6640 || TREE_OVERFLOW (old_size)
6641 || (AGGREGATE_TYPE_P (gnu_type)
6642 && tree_int_cst_lt (size, old_size)))
6644 if (Present (gnat_attr_node))
6646 ("Value_Size for& too small{, minimum allowed is ^}",
6647 gnat_attr_node, gnat_entity, old_size);
6652 /* Otherwise, set the RM_Size. */
6653 if (TREE_CODE (gnu_type) == INTEGER_TYPE
6654 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
6655 TYPE_RM_SIZE_NUM (gnu_type) = size;
6656 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
6657 TYPE_RM_SIZE_NUM (gnu_type) = size;
6658 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6659 || TREE_CODE (gnu_type) == UNION_TYPE
6660 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6661 && !TYPE_IS_FAT_POINTER_P (gnu_type))
6662 SET_TYPE_ADA_SIZE (gnu_type, size);
6665 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
6666 If TYPE is the best type, return it. Otherwise, make a new type. We
6667 only support new integral and pointer types. BIASED_P is nonzero if
6668 we are making a biased type. */
6671 make_type_from_size (tree type, tree size_tree, bool biased_p)
6674 unsigned HOST_WIDE_INT size;
6677 /* If size indicates an error, just return TYPE to avoid propagating the
6678 error. Likewise if it's too large to represent. */
6679 if (!size_tree || !host_integerp (size_tree, 1))
6682 size = tree_low_cst (size_tree, 1);
6683 switch (TREE_CODE (type))
6687 /* Only do something if the type is not already the proper size and is
6688 not a packed array type. */
6689 if (TYPE_PACKED_ARRAY_TYPE_P (type)
6690 || (TYPE_PRECISION (type) == size
6691 && biased_p == (TREE_CODE (type) == INTEGER_CST
6692 && TYPE_BIASED_REPRESENTATION_P (type))))
6695 biased_p |= (TREE_CODE (type) == INTEGER_TYPE
6696 && TYPE_BIASED_REPRESENTATION_P (type));
6697 unsigned_p = TYPE_UNSIGNED (type) || biased_p;
6699 size = MIN (size, LONG_LONG_TYPE_SIZE);
6701 = unsigned_p ? make_unsigned_type (size) : make_signed_type (size);
6702 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
6703 TYPE_MIN_VALUE (new_type)
6704 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
6705 TYPE_MAX_VALUE (new_type)
6706 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
6707 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
6708 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
6712 /* Do something if this is a fat pointer, in which case we
6713 may need to return the thin pointer. */
6714 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
6717 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
6721 /* Only do something if this is a thin pointer, in which case we
6722 may need to return the fat pointer. */
6723 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
6725 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
6736 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6737 a type or object whose present alignment is ALIGN. If this alignment is
6738 valid, return it. Otherwise, give an error and return ALIGN. */
6741 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
6743 Node_Id gnat_error_node = gnat_entity;
6744 unsigned int new_align;
6746 unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
6748 if (Present (Alignment_Clause (gnat_entity)))
6749 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
6751 /* Don't worry about checking alignment if alignment was not specified
6752 by the source program and we already posted an error for this entity. */
6754 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
6757 /* Within GCC, an alignment is an integer, so we must make sure a value is
6758 specified that fits in that range. Also, there is an upper bound to
6759 alignments we can support/allow. */
6761 if (! UI_Is_In_Int_Range (alignment)
6762 || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
6763 post_error_ne_num ("largest supported alignment for& is ^",
6764 gnat_error_node, gnat_entity, max_allowed_alignment);
6765 else if (!(Present (Alignment_Clause (gnat_entity))
6766 && From_At_Mod (Alignment_Clause (gnat_entity)))
6767 && new_align * BITS_PER_UNIT < align)
6768 post_error_ne_num ("alignment for& must be at least ^",
6769 gnat_error_node, gnat_entity,
6770 align / BITS_PER_UNIT);
6772 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
6777 /* Verify that OBJECT, a type or decl, is something we can implement
6778 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
6779 if we require atomic components. */
6782 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
6784 Node_Id gnat_error_point = gnat_entity;
6786 enum machine_mode mode;
6790 /* There are three case of what OBJECT can be. It can be a type, in which
6791 case we take the size, alignment and mode from the type. It can be a
6792 declaration that was indirect, in which case the relevant values are
6793 that of the type being pointed to, or it can be a normal declaration,
6794 in which case the values are of the decl. The code below assumes that
6795 OBJECT is either a type or a decl. */
6796 if (TYPE_P (object))
6798 mode = TYPE_MODE (object);
6799 align = TYPE_ALIGN (object);
6800 size = TYPE_SIZE (object);
6802 else if (DECL_BY_REF_P (object))
6804 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
6805 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
6806 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
6810 mode = DECL_MODE (object);
6811 align = DECL_ALIGN (object);
6812 size = DECL_SIZE (object);
6815 /* Consider all floating-point types atomic and any types that that are
6816 represented by integers no wider than a machine word. */
6817 if (GET_MODE_CLASS (mode) == MODE_FLOAT
6818 || ((GET_MODE_CLASS (mode) == MODE_INT
6819 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
6820 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
6823 /* For the moment, also allow anything that has an alignment equal
6824 to its size and which is smaller than a word. */
6825 if (size && TREE_CODE (size) == INTEGER_CST
6826 && compare_tree_int (size, align) == 0
6827 && align <= BITS_PER_WORD)
6830 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
6831 gnat_node = Next_Rep_Item (gnat_node))
6833 if (!comp_p && Nkind (gnat_node) == N_Pragma
6834 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
6835 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6836 else if (comp_p && Nkind (gnat_node) == N_Pragma
6837 && (Get_Pragma_Id (Chars (gnat_node))
6838 == Pragma_Atomic_Components))
6839 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6843 post_error_ne ("atomic access to component of & cannot be guaranteed",
6844 gnat_error_point, gnat_entity);
6846 post_error_ne ("atomic access to & cannot be guaranteed",
6847 gnat_error_point, gnat_entity);
6850 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
6851 have compatible signatures so that a call using one type may be safely
6852 issued if the actual target function type is the other. Return 1 if it is
6853 the case, 0 otherwise, and post errors on the incompatibilities.
6855 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
6856 that calls to the subprogram will have arguments suitable for the later
6857 underlying builtin expansion. */
6860 compatible_signatures_p (tree ftype1, tree ftype2)
6862 /* As of now, we only perform very trivial tests and consider it's the
6863 programmer's responsibility to ensure the type correctness in the Ada
6864 declaration, as in the regular Import cases.
6866 Mismatches typically result in either error messages from the builtin
6867 expander, internal compiler errors, or in a real call sequence. This
6868 should be refined to issue diagnostics helping error detection and
6871 /* Almost fake test, ensuring a use of each argument. */
6872 if (ftype1 == ftype2)
6878 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
6879 type with all size expressions that contain F updated by replacing F
6880 with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
6881 nothing has changed. */
6884 substitute_in_type (tree t, tree f, tree r)
6889 switch (TREE_CODE (t))
6894 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6895 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6897 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
6898 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
6900 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6903 new = build_range_type (TREE_TYPE (t), low, high);
6904 if (TYPE_INDEX_TYPE (t))
6906 (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
6913 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6914 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6916 tree low = NULL_TREE, high = NULL_TREE;
6918 if (TYPE_MIN_VALUE (t))
6919 low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
6920 if (TYPE_MAX_VALUE (t))
6921 high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
6923 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6927 TYPE_MIN_VALUE (t) = low;
6928 TYPE_MAX_VALUE (t) = high;
6933 tem = substitute_in_type (TREE_TYPE (t), f, r);
6934 if (tem == TREE_TYPE (t))
6937 return build_complex_type (tem);
6943 /* Don't know how to do these yet. */
6948 tree component = substitute_in_type (TREE_TYPE (t), f, r);
6949 tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
6951 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
6954 new = build_array_type (component, domain);
6955 TYPE_SIZE (new) = 0;
6956 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
6957 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
6959 TYPE_ALIGN (new) = TYPE_ALIGN (t);
6960 TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
6962 /* If we had bounded the sizes of T by a constant, bound the sizes of
6963 NEW by the same constant. */
6964 if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
6966 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
6968 if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
6969 TYPE_SIZE_UNIT (new)
6970 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
6971 TYPE_SIZE_UNIT (new));
6977 case QUAL_UNION_TYPE:
6981 = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
6982 bool field_has_rep = false;
6983 tree last_field = NULL_TREE;
6985 tree new = copy_type (t);
6987 /* Start out with no fields, make new fields, and chain them
6988 in. If we haven't actually changed the type of any field,
6989 discard everything we've done and return the old type. */
6991 TYPE_FIELDS (new) = NULL_TREE;
6992 TYPE_SIZE (new) = NULL_TREE;
6994 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
6996 tree new_field = copy_node (field);
6998 TREE_TYPE (new_field)
6999 = substitute_in_type (TREE_TYPE (new_field), f, r);
7001 if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
7002 field_has_rep = true;
7003 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
7004 changed_field = true;
7006 /* If this is an internal field and the type of this field is
7007 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
7008 the type just has one element, treat that as the field.
7009 But don't do this if we are processing a QUAL_UNION_TYPE. */
7010 if (TREE_CODE (t) != QUAL_UNION_TYPE
7011 && DECL_INTERNAL_P (new_field)
7012 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
7013 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
7015 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
7018 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
7021 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
7023 /* Make sure omitting the union doesn't change
7025 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
7026 new_field = next_new_field;
7030 DECL_CONTEXT (new_field) = new;
7031 SET_DECL_ORIGINAL_FIELD (new_field,
7032 (DECL_ORIGINAL_FIELD (field)
7033 ? DECL_ORIGINAL_FIELD (field) : field));
7035 /* If the size of the old field was set at a constant,
7036 propagate the size in case the type's size was variable.
7037 (This occurs in the case of a variant or discriminated
7038 record with a default size used as a field of another
7040 DECL_SIZE (new_field)
7041 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
7042 ? DECL_SIZE (field) : NULL_TREE;
7043 DECL_SIZE_UNIT (new_field)
7044 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
7045 ? DECL_SIZE_UNIT (field) : NULL_TREE;
7047 if (TREE_CODE (t) == QUAL_UNION_TYPE)
7049 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
7051 if (new_q != DECL_QUALIFIER (new_field))
7052 changed_field = true;
7054 /* Do the substitution inside the qualifier and if we find
7055 that this field will not be present, omit it. */
7056 DECL_QUALIFIER (new_field) = new_q;
7058 if (integer_zerop (DECL_QUALIFIER (new_field)))
7063 TYPE_FIELDS (new) = new_field;
7065 TREE_CHAIN (last_field) = new_field;
7067 last_field = new_field;
7069 /* If this is a qualified type and this field will always be
7070 present, we are done. */
7071 if (TREE_CODE (t) == QUAL_UNION_TYPE
7072 && integer_onep (DECL_QUALIFIER (new_field)))
7076 /* If this used to be a qualified union type, but we now know what
7077 field will be present, make this a normal union. */
7078 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
7079 && (!TYPE_FIELDS (new)
7080 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
7081 TREE_SET_CODE (new, UNION_TYPE);
7082 else if (!changed_field)
7085 gcc_assert (!field_has_rep);
7088 /* If the size was originally a constant use it. */
7089 if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
7090 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
7092 TYPE_SIZE (new) = TYPE_SIZE (t);
7093 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
7094 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
7105 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
7106 needed to represent the object. */
7109 rm_size (tree gnu_type)
7111 /* For integer types, this is the precision. For record types, we store
7112 the size explicitly. For other types, this is just the size. */
7114 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
7115 return TYPE_RM_SIZE (gnu_type);
7116 else if (TREE_CODE (gnu_type) == RECORD_TYPE
7117 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
7118 /* Return the rm_size of the actual data plus the size of the template. */
7120 size_binop (PLUS_EXPR,
7121 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
7122 DECL_SIZE (TYPE_FIELDS (gnu_type)));
7123 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
7124 || TREE_CODE (gnu_type) == UNION_TYPE
7125 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
7126 && !TYPE_IS_FAT_POINTER_P (gnu_type)
7127 && TYPE_ADA_SIZE (gnu_type))
7128 return TYPE_ADA_SIZE (gnu_type);
7130 return TYPE_SIZE (gnu_type);
7133 /* Return an identifier representing the external name to be used for
7134 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
7135 and the specified suffix. */
7138 create_concat_name (Entity_Id gnat_entity, const char *suffix)
7140 Entity_Kind kind = Ekind (gnat_entity);
7142 const char *str = (!suffix ? "" : suffix);
7143 String_Template temp = {1, strlen (str)};
7144 Fat_Pointer fp = {str, &temp};
7146 Get_External_Name_With_Suffix (gnat_entity, fp);
7148 /* A variable using the Stdcall convention (meaning we are running
7149 on a Windows box) live in a DLL. Here we adjust its name to use
7150 the jump-table, the _imp__NAME contains the address for the NAME
7152 if ((kind == E_Variable || kind == E_Constant)
7153 && Has_Stdcall_Convention (gnat_entity))
7155 const char *prefix = "_imp__";
7156 int k, plen = strlen (prefix);
7158 for (k = 0; k <= Name_Len; k++)
7159 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
7160 strncpy (Name_Buffer, prefix, plen);
7163 return get_identifier (Name_Buffer);
7166 /* Return the name to be used for GNAT_ENTITY. If a type, create a
7167 fully-qualified name, possibly with type information encoding.
7168 Otherwise, return the name. */
7171 get_entity_name (Entity_Id gnat_entity)
7173 Get_Encoded_Name (gnat_entity);
7174 return get_identifier (Name_Buffer);
7177 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
7178 string, return a new IDENTIFIER_NODE that is the concatenation of
7179 the name in GNU_ID and SUFFIX. */
7182 concat_id_with_name (tree gnu_id, const char *suffix)
7184 int len = IDENTIFIER_LENGTH (gnu_id);
7186 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
7187 IDENTIFIER_LENGTH (gnu_id));
7188 strncpy (Name_Buffer + len, "___", 3);
7190 strcpy (Name_Buffer + len, suffix);
7191 return get_identifier (Name_Buffer);
7194 #include "gt-ada-decl.h"