1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, 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 2, 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 distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
54 /* Setting this to 1 suppresses hashing of types. */
55 extern int debug_no_type_hash;
57 /* Provide default values for the macros controlling stack checking.
58 This is copied from GCC's expr.h. */
60 #ifndef STACK_CHECK_BUILTIN
61 #define STACK_CHECK_BUILTIN 0
63 #ifndef STACK_CHECK_PROBE_INTERVAL
64 #define STACK_CHECK_PROBE_INTERVAL 4096
66 #ifndef STACK_CHECK_MAX_FRAME_SIZE
67 #define STACK_CHECK_MAX_FRAME_SIZE \
68 (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
70 #ifndef STACK_CHECK_MAX_VAR_SIZE
71 #define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
74 /* These two variables are used to defer recursively expanding incomplete
75 types while we are processing a record or subprogram type. */
77 static int defer_incomplete_level = 0;
78 static struct incomplete
80 struct incomplete *next;
83 } *defer_incomplete_list = 0;
85 static void copy_alias_set (tree, tree);
86 static tree substitution_list (Entity_Id, Entity_Id, tree, int);
87 static int allocatable_size_p (tree, int);
88 static struct attrib *build_attr_list (Entity_Id);
89 static tree elaborate_expression (Node_Id, Entity_Id, tree, int, int, int);
90 static int is_variable_size (tree);
91 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, int, int);
92 static tree make_packable_type (tree);
93 static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *,
95 static tree gnat_to_gnu_field (Entity_Id, tree, int, int);
96 static void components_to_record (tree, Node_Id, tree, int, int, tree *,
98 static int compare_field_bitpos (const PTR, const PTR);
99 static Uint annotate_value (tree);
100 static void annotate_rep (Entity_Id, tree);
101 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
102 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, int, int);
103 static void set_rm_size (Uint, tree, Entity_Id);
104 static tree make_type_from_size (tree, tree, int);
105 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
106 static void check_ok_for_atomic (tree, Entity_Id, int);
108 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
109 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
110 refer to an Ada type. */
113 gnat_to_gnu_type (Entity_Id gnat_entity)
117 /* The back end never attempts to annotate generic types */
118 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
119 return void_type_node;
121 /* Convert the ada entity type into a GCC TYPE_DECL node. */
122 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
123 if (TREE_CODE (gnu_decl) != TYPE_DECL)
126 return TREE_TYPE (gnu_decl);
129 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
130 entity, this routine returns the equivalent GCC tree for that entity
131 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
134 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
135 initial value (in GCC tree form). This is optional for variables.
136 For renamed entities, GNU_EXPR gives the object being renamed.
138 DEFINITION is nonzero if this call is intended for a definition. This is
139 used for separate compilation where it necessary to know whether an
140 external declaration or a definition should be created if the GCC equivalent
141 was not created previously. The value of 1 is normally used for a non-zero
142 DEFINITION, but a value of 2 is used in special circumstances, defined in
146 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
150 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
151 GNAT tree. This node will be associated with the GNAT node by calling
152 the save_gnu_tree routine at the end of the `switch' statement. */
154 /* Nonzero if we have already saved gnu_decl as a gnat association. */
156 /* Nonzero if we incremented defer_incomplete_level. */
157 int this_deferred = 0;
158 /* Nonzero if we incremented force_global. */
160 /* Nonzero if we should check to see if elaborated during processing. */
161 int maybe_present = 0;
162 /* Nonzero if we made GNU_DECL and its type here. */
163 int this_made_decl = 0;
164 struct attrib *attr_list = 0;
165 int debug_info_p = (Needs_Debug_Info (gnat_entity)
166 || debug_info_level == DINFO_LEVEL_VERBOSE);
167 Entity_Kind kind = Ekind (gnat_entity);
170 = ((Known_Esize (gnat_entity)
171 && UI_Is_In_Int_Range (Esize (gnat_entity)))
172 ? MIN (UI_To_Int (Esize (gnat_entity)),
173 IN (kind, Float_Kind)
174 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
175 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
176 : LONG_LONG_TYPE_SIZE)
177 : LONG_LONG_TYPE_SIZE);
180 = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
181 || From_With_Type (gnat_entity));
182 unsigned int align = 0;
184 /* Since a use of an Itype is a definition, process it as such if it
185 is not in a with'ed unit. */
187 if (! definition && Is_Itype (gnat_entity)
188 && ! present_gnu_tree (gnat_entity)
189 && In_Extended_Main_Code_Unit (gnat_entity))
191 /* Ensure that we are in a subprogram mentioned in the Scope
192 chain of this entity, our current scope is global,
193 or that we encountered a task or entry (where we can't currently
194 accurately check scoping). */
195 if (current_function_decl == 0
196 || DECL_ELABORATION_PROC_P (current_function_decl))
198 process_type (gnat_entity);
199 return get_gnu_tree (gnat_entity);
202 for (gnat_temp = Scope (gnat_entity);
203 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
205 if (Is_Type (gnat_temp))
206 gnat_temp = Underlying_Type (gnat_temp);
208 if (Ekind (gnat_temp) == E_Subprogram_Body)
210 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
212 if (IN (Ekind (gnat_temp), Subprogram_Kind)
213 && Present (Protected_Body_Subprogram (gnat_temp)))
214 gnat_temp = Protected_Body_Subprogram (gnat_temp);
216 if (Ekind (gnat_temp) == E_Entry
217 || Ekind (gnat_temp) == E_Entry_Family
218 || Ekind (gnat_temp) == E_Task_Type
219 || (IN (Ekind (gnat_temp), Subprogram_Kind)
220 && present_gnu_tree (gnat_temp)
221 && (current_function_decl
222 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
224 process_type (gnat_entity);
225 return get_gnu_tree (gnat_entity);
229 /* gigi abort 122 means that the entity "gnat_entity" has an incorrect
230 scope, i.e. that its scope does not correspond to the subprogram
231 in which it is declared */
235 /* If this is entity 0, something went badly wrong. */
236 if (gnat_entity == 0)
239 /* If we've already processed this entity, return what we got last time.
240 If we are defining the node, we should not have already processed it.
241 In that case, we will abort below when we try to save a new GCC tree for
242 this object. We also need to handle the case of getting a dummy type
243 when a Full_View exists. */
245 if (present_gnu_tree (gnat_entity)
247 || (Is_Type (gnat_entity) && imported_p)))
249 gnu_decl = get_gnu_tree (gnat_entity);
251 if (TREE_CODE (gnu_decl) == TYPE_DECL
252 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
253 && IN (kind, Incomplete_Or_Private_Kind)
254 && Present (Full_View (gnat_entity)))
256 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
259 save_gnu_tree (gnat_entity, NULL_TREE, 0);
260 save_gnu_tree (gnat_entity, gnu_decl, 0);
266 /* If this is a numeric or enumeral type, or an access type, a nonzero
267 Esize must be specified unless it was specified by the programmer. */
268 if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind)
269 || (IN (kind, Access_Kind)
270 && kind != E_Access_Protected_Subprogram_Type
271 && kind != E_Access_Subtype))
272 && Unknown_Esize (gnat_entity)
273 && ! Has_Size_Clause (gnat_entity))
276 /* Likewise, RM_Size must be specified for all discrete and fixed-point
278 if (IN (kind, Discrete_Or_Fixed_Point_Kind)
279 && Unknown_RM_Size (gnat_entity))
282 /* Get the name of the entity and set up the line number and filename of
283 the original definition for use in any decl we make. */
285 gnu_entity_id = get_entity_name (gnat_entity);
286 set_lineno (gnat_entity, 0);
288 /* If we get here, it means we have not yet done anything with this
289 entity. If we are not defining it here, it must be external,
290 otherwise we should have defined it already. */
291 if (! definition && ! Is_Public (gnat_entity)
292 && ! type_annotate_only
293 && kind != E_Discriminant && kind != E_Component
295 && ! (kind == E_Constant && Present (Full_View (gnat_entity)))
297 && !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 sizes. Don't do this for components or
305 discriminants since the relevant test is whether or not the record is
307 if (! definition && Is_Public (gnat_entity)
308 && ! Is_Statically_Allocated (gnat_entity)
309 && kind != E_Discriminant && kind != E_Component)
310 force_global++, this_global = 1;
312 /* Handle any attributes. */
313 if (Has_Gigi_Rep_Item (gnat_entity))
314 attr_list = build_attr_list (gnat_entity);
319 /* If this is a use of a deferred constant, get its full
321 if (! definition && Present (Full_View (gnat_entity)))
323 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
324 gnu_expr, definition);
329 /* If we have an external constant that we are not defining,
330 get the expression that is was defined to represent. We
331 may throw that expression away later if it is not a
333 Do not retrieve the expression if it is an aggregate, because
334 in complex instantiation contexts it may not be expanded */
337 && Present (Expression (Declaration_Node (gnat_entity)))
338 && ! No_Initialization (Declaration_Node (gnat_entity))
339 && Nkind (Expression (Declaration_Node (gnat_entity)))
341 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
343 /* Ignore deferred constant definitions; they are processed fully in the
344 front-end. For deferred constant references, get the full
345 definition. On the other hand, constants that are renamings are
346 handled like variable renamings. If No_Initialization is set, this is
347 not a deferred constant but a constant whose value is built
350 if (definition && gnu_expr == 0
351 && ! No_Initialization (Declaration_Node (gnat_entity))
352 && No (Renamed_Object (gnat_entity)))
354 gnu_decl = error_mark_node;
358 else if (! definition && IN (kind, Incomplete_Or_Private_Kind)
359 && Present (Full_View (gnat_entity)))
361 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
370 /* If this is not a VMS exception, treat it as a normal object.
371 Otherwise, make an object at the specific address of character
372 type, point to it, and convert it to integer, and mask off
374 if (! Is_VMS_Exception (gnat_entity))
377 /* Allocate the global object that we use to get the value of the
379 gnu_decl = create_var_decl (gnu_entity_id,
380 (Present (Interface_Name (gnat_entity))
381 ? create_concat_name (gnat_entity, 0)
383 char_type_node, NULL_TREE, 0, 0, 1, 1,
386 /* Now return the expression giving the desired value. */
388 = build_binary_op (BIT_AND_EXPR, integer_type_node,
389 convert (integer_type_node,
390 build_unary_op (ADDR_EXPR, NULL_TREE,
392 build_unary_op (NEGATE_EXPR, integer_type_node,
393 build_int_2 (7, 0)));
395 save_gnu_tree (gnat_entity, gnu_decl, 1);
402 /* The GNAT record where the component was defined. */
403 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
405 /* If the variable is an inherited record component (in the case of
406 extended record types), just return the inherited entity, which
407 must be a FIELD_DECL. Likewise for discriminants.
408 For discriminants of untagged records which have explicit
409 stored discriminants, return the entity for the corresponding
410 stored discriminant. Also use Original_Record_Component
411 if the record has a private extension. */
413 if ((Base_Type (gnat_record) == gnat_record
414 || Ekind (Scope (gnat_entity)) == E_Private_Subtype
415 || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
416 || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
417 && Present (Original_Record_Component (gnat_entity))
418 && Original_Record_Component (gnat_entity) != gnat_entity)
421 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
422 gnu_expr, definition);
427 /* If the enclosing record has explicit stored discriminants,
428 then it is an untagged record. If the Corresponding_Discriminant
429 is not empty then this must be a renamed discriminant and its
430 Original_Record_Component must point to the corresponding explicit
431 stored discriminant (i.e., we should have taken the previous
434 else if (Present (Corresponding_Discriminant (gnat_entity))
435 && Is_Tagged_Type (gnat_record))
437 /* A tagged record has no explicit stored discriminants. */
439 if (First_Discriminant (gnat_record)
440 != First_Stored_Discriminant (gnat_record))
444 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
445 gnu_expr, definition);
450 /* If the enclosing record has explicit stored discriminants,
451 then it is an untagged record. If the Corresponding_Discriminant
452 is not empty then this must be a renamed discriminant and its
453 Original_Record_Component must point to the corresponding explicit
454 stored discriminant (i.e., we should have taken the first
457 else if (Present (Corresponding_Discriminant (gnat_entity))
458 && (First_Discriminant (gnat_record)
459 != First_Stored_Discriminant (gnat_record)))
462 /* Otherwise, if we are not defining this and we have no GCC type
463 for the containing record, make one for it. Then we should
464 have made our own equivalent. */
465 else if (! definition && ! present_gnu_tree (gnat_record))
467 /* ??? If this is in a record whose scope is a protected
468 type and we have an Original_Record_Component, use it.
469 This is a workaround for major problems in protected type
472 Entity_Id Scop = Scope (Scope (gnat_entity));
473 if ((Is_Protected_Type (Scop)
474 || (Is_Private_Type (Scop)
475 && Present (Full_View (Scop))
476 && Is_Protected_Type (Full_View (Scop))))
477 && Present (Original_Record_Component (gnat_entity)))
480 = gnat_to_gnu_entity (Original_Record_Component
482 gnu_expr, definition);
487 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
488 gnu_decl = get_gnu_tree (gnat_entity);
493 /* Here we have no GCC type and this is a reference rather than a
494 definition. This should never happen. Most likely the cause is a
495 reference before declaration in the gnat tree for gnat_entity. */
500 case E_Loop_Parameter:
501 case E_Out_Parameter:
504 /* Simple variables, loop variables, OUT parameters, and exceptions. */
509 = ((kind == E_Constant || kind == E_Variable)
510 && ! Is_Statically_Allocated (gnat_entity)
511 && Is_True_Constant (gnat_entity)
512 && (((Nkind (Declaration_Node (gnat_entity))
513 == N_Object_Declaration)
514 && Present (Expression (Declaration_Node (gnat_entity))))
515 || Present (Renamed_Object (gnat_entity))));
516 int inner_const_flag = const_flag;
517 int static_p = Is_Statically_Allocated (gnat_entity);
518 tree gnu_ext_name = NULL_TREE;
520 if (Present (Renamed_Object (gnat_entity)) && ! definition)
522 if (kind == E_Exception)
523 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
526 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
529 /* Get the type after elaborating the renamed object. */
530 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
532 /* If this is a loop variable, its type should be the base type.
533 This is because the code for processing a loop determines whether
534 a normal loop end test can be done by comparing the bounds of the
535 loop against those of the base type, which is presumed to be the
536 size used for computation. But this is not correct when the size
537 of the subtype is smaller than the type. */
538 if (kind == E_Loop_Parameter)
539 gnu_type = get_base_type (gnu_type);
541 /* Reject non-renamed objects whose types are unconstrained arrays or
542 any object whose type is a dummy type or VOID_TYPE. */
544 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
545 && No (Renamed_Object (gnat_entity)))
546 || TYPE_IS_DUMMY_P (gnu_type)
547 || TREE_CODE (gnu_type) == VOID_TYPE)
549 if (type_annotate_only)
550 return error_mark_node;
555 /* If we are defining the object, see if it has a Size value and
556 validate it if so. If we are not defining the object and a Size
557 clause applies, simply retrieve the value. We don't want to ignore
558 the clause and it is expected to have been validated already. Then
559 get the new type, if any. */
561 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
562 gnat_entity, VAR_DECL, 0,
563 Has_Size_Clause (gnat_entity));
564 else if (Has_Size_Clause (gnat_entity))
565 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
570 = make_type_from_size (gnu_type, gnu_size,
571 Has_Biased_Representation (gnat_entity));
573 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
577 /* If this object has self-referential size, it must be a record with
578 a default value. We are supposed to allocate an object of the
579 maximum size in this case unless it is a constant with an
580 initializing expression, in which case we can get the size from
581 that. Note that the resulting size may still be a variable, so
582 this may end up with an indirect allocation. */
584 if (No (Renamed_Object (gnat_entity))
585 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
587 if (gnu_expr != 0 && kind == E_Constant)
589 gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
590 if (CONTAINS_PLACEHOLDER_P (gnu_size))
591 gnu_size = build (WITH_RECORD_EXPR, bitsizetype,
595 /* We may have no GNU_EXPR because No_Initialization is
596 set even though there's an Expression. */
597 else if (kind == E_Constant
598 && (Nkind (Declaration_Node (gnat_entity))
599 == N_Object_Declaration)
600 && Present (Expression (Declaration_Node (gnat_entity))))
602 = TYPE_SIZE (gnat_to_gnu_type
604 (Expression (Declaration_Node (gnat_entity)))));
606 gnu_size = max_size (TYPE_SIZE (gnu_type), 1);
609 /* If the size is zero bytes, make it one byte since some linkers have
610 trouble with zero-sized objects. If the object will have a
611 template, that will make it nonzero so don't bother. Also avoid
612 doing that for an object renaming or an object with an address
613 clause, as we would lose useful information on the view size
614 (e.g. for null array slices) and we are not allocating the object
616 if (((gnu_size != 0 && integer_zerop (gnu_size))
617 || (TYPE_SIZE (gnu_type) != 0
618 && integer_zerop (TYPE_SIZE (gnu_type))))
619 && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
620 || ! Is_Array_Type (Etype (gnat_entity)))
621 && ! Present (Renamed_Object (gnat_entity))
622 && ! Present (Address_Clause (gnat_entity)))
623 gnu_size = bitsize_unit_node;
625 /* If an alignment is specified, use it if valid. Note that
626 exceptions are objects but don't have alignments. */
627 if (kind != E_Exception && Known_Alignment (gnat_entity))
629 if (No (Alignment (gnat_entity)))
633 = validate_alignment (Alignment (gnat_entity), gnat_entity,
634 TYPE_ALIGN (gnu_type));
637 /* If this is an atomic object with no specified size and alignment,
638 but where the size of the type is a constant, set the alignment to
639 the lowest power of two greater than the size, or to the
640 biggest meaningful alignment, whichever is smaller. */
642 if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0
643 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
645 if (! host_integerp (TYPE_SIZE (gnu_type), 1)
646 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
648 align = BIGGEST_ALIGNMENT;
650 align = ((unsigned int) 1
651 << (floor_log2 (tree_low_cst
652 (TYPE_SIZE (gnu_type), 1) - 1)
656 /* If the object is set to have atomic components, find the component
657 type and validate it.
659 ??? Note that we ignore Has_Volatile_Components on objects; it's
660 not at all clear what to do in that case. */
662 if (Has_Atomic_Components (gnat_entity))
665 = (TREE_CODE (gnu_type) == ARRAY_TYPE
666 ? TREE_TYPE (gnu_type) : gnu_type);
668 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
669 && TYPE_MULTI_ARRAY_P (gnu_inner))
670 gnu_inner = TREE_TYPE (gnu_inner);
672 check_ok_for_atomic (gnu_inner, gnat_entity, 1);
675 /* Now check if the type of the object allows atomic access. Note
676 that we must test the type, even if this object has size and
677 alignment to allow such access, because we will be going
678 inside the padded record to assign to the object. We could fix
679 this by always copying via an intermediate value, but it's not
680 clear it's worth the effort. */
681 if (Is_Atomic (gnat_entity))
682 check_ok_for_atomic (gnu_type, gnat_entity, 0);
684 /* If this is an aliased object with an unconstrained nominal subtype,
685 make a type that includes the template. */
686 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
687 && Is_Array_Type (Etype (gnat_entity))
688 && ! type_annotate_only)
691 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
693 = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
696 = build_unc_object_type (gnu_temp_type, gnu_type,
697 concat_id_with_name (gnu_entity_id,
701 #ifdef MINIMUM_ATOMIC_ALIGNMENT
702 /* If the size is a constant and no alignment is specified, force
703 the alignment to be the minimum valid atomic alignment. The
704 restriction on constant size avoids problems with variable-size
705 temporaries; if the size is variable, there's no issue with
706 atomic access. Also don't do this for a constant, since it isn't
707 necessary and can interfere with constant replacement. Finally,
708 do not do it for Out parameters since that creates an
709 size inconsistency with In parameters. */
710 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
711 && ! FLOAT_TYPE_P (gnu_type)
712 && ! const_flag && No (Renamed_Object (gnat_entity))
713 && ! imported_p && No (Address_Clause (gnat_entity))
714 && kind != E_Out_Parameter
715 && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
716 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
717 align = MINIMUM_ATOMIC_ALIGNMENT;
720 /* Make a new type with the desired size and alignment, if needed. */
721 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
722 gnat_entity, "PAD", 0, definition, 1);
724 /* Make a volatile version of this object's type if we are to
725 make the object volatile. Note that 13.3(19) says that we
726 should treat other types of objects as volatile as well. */
727 if ((Treat_As_Volatile (gnat_entity)
728 || Is_Exported (gnat_entity)
729 || Is_Imported (gnat_entity)
730 || Present (Address_Clause (gnat_entity)))
731 && ! TYPE_VOLATILE (gnu_type))
732 gnu_type = build_qualified_type (gnu_type,
733 (TYPE_QUALS (gnu_type)
734 | TYPE_QUAL_VOLATILE));
736 /* Convert the expression to the type of the object except in the
737 case where the object's type is unconstrained or the object's type
738 is a padded record whose field is of self-referential size. In
739 the former case, converting will generate unnecessary evaluations
740 of the CONSTRUCTOR to compute the size and in the latter case, we
741 want to only copy the actual data. */
743 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
744 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
745 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
746 && TYPE_IS_PADDING_P (gnu_type)
747 && (CONTAINS_PLACEHOLDER_P
748 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
749 gnu_expr = convert (gnu_type, gnu_expr);
751 /* See if this is a renaming. If this is a constant renaming,
752 treat it as a normal variable whose initial value is what
753 is being renamed. We cannot do this if the type is
754 unconstrained or class-wide.
756 Otherwise, if what we are renaming is a reference, we can simply
757 return a stabilized version of that reference, after forcing
758 any SAVE_EXPRs to be evaluated. But, if this is at global level,
759 we can only do this if we know no SAVE_EXPRs will be made.
760 Otherwise, make this into a constant pointer to the object we are
763 if (Present (Renamed_Object (gnat_entity)))
765 /* If the renamed object had padding, strip off the reference
766 to the inner object and reset our type. */
767 if (TREE_CODE (gnu_expr) == COMPONENT_REF
768 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
770 && (TYPE_IS_PADDING_P
771 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
773 gnu_expr = TREE_OPERAND (gnu_expr, 0);
774 gnu_type = TREE_TYPE (gnu_expr);
778 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
779 && TYPE_MODE (gnu_type) != BLKmode
780 && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
781 && !Is_Array_Type (Etype (gnat_entity)))
784 /* If this is a declaration or reference, we can just use that
785 declaration or reference as this entity. */
786 else if ((DECL_P (gnu_expr)
787 || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r')
788 && ! Materialize_Entity (gnat_entity)
789 && (! global_bindings_p ()
790 || (staticp (gnu_expr)
791 && ! TREE_SIDE_EFFECTS (gnu_expr))))
793 set_lineno (gnat_entity, ! global_bindings_p ());
794 gnu_decl = gnat_stabilize_reference (gnu_expr, 1);
795 save_gnu_tree (gnat_entity, gnu_decl, 1);
798 if (! global_bindings_p ())
799 expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node,
805 inner_const_flag = TREE_READONLY (gnu_expr);
807 gnu_type = build_reference_type (gnu_type);
808 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
814 /* If this is an aliased object whose nominal subtype is unconstrained,
815 the object is a record that contains both the template and
816 the object. If there is an initializer, it will have already
817 been converted to the right type, but we need to create the
818 template if there is no initializer. */
819 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
820 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
821 /* Beware that padding might have been introduced
822 via maybe_pad_type above. */
823 || (TYPE_IS_PADDING_P (gnu_type)
824 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
826 && TYPE_CONTAINS_TEMPLATE_P
827 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
831 = TYPE_IS_PADDING_P (gnu_type)
832 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
833 : TYPE_FIELDS (gnu_type);
836 = gnat_build_constructor
840 build_template (TREE_TYPE (template_field),
841 TREE_TYPE (TREE_CHAIN (template_field)),
846 /* If this is a pointer and it does not have an initializing
847 expression, initialize it to NULL, unless the obect is
850 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
851 && !Is_Imported (gnat_entity)
853 gnu_expr = integer_zero_node;
855 /* If we are defining the object and it has an Address clause we must
856 get the address expression from the saved GCC tree for the
857 object if the object has a Freeze_Node. Otherwise, we elaborate
858 the address expression here since the front-end has guaranteed
859 in that case that the elaboration has no effects. Note that
860 only the latter mechanism is currently in use. */
861 if (definition && Present (Address_Clause (gnat_entity)))
864 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
865 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
867 save_gnu_tree (gnat_entity, NULL_TREE, 0);
869 /* Ignore the size. It's either meaningless or was handled
872 gnu_type = build_reference_type (gnu_type);
873 gnu_address = convert (gnu_type, gnu_address);
875 const_flag = ! Is_Public (gnat_entity);
877 /* If we don't have an initializing expression for the underlying
878 variable, the initializing expression for the pointer is the
879 specified address. Otherwise, we have to make a COMPOUND_EXPR
880 to assign both the address and the initial value. */
882 gnu_expr = gnu_address;
885 = build (COMPOUND_EXPR, gnu_type,
887 (MODIFY_EXPR, NULL_TREE,
888 build_unary_op (INDIRECT_REF, NULL_TREE,
894 /* If it has an address clause and we are not defining it, mark it
895 as an indirect object. Likewise for Stdcall objects that are
897 if ((! definition && Present (Address_Clause (gnat_entity)))
898 || (Is_Imported (gnat_entity)
899 && Convention (gnat_entity) == Convention_Stdcall))
901 gnu_type = build_reference_type (gnu_type);
906 /* If we are at top level and this object is of variable size,
907 make the actual type a hidden pointer to the real type and
908 make the initializer be a memory allocation and initialization.
909 Likewise for objects we aren't defining (presumed to be
910 external references from other packages), but there we do
911 not set up an initialization.
913 If the object's size overflows, make an allocator too, so that
914 Storage_Error gets raised. Note that we will never free
915 such memory, so we presume it never will get allocated. */
917 if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
918 global_bindings_p () || ! definition
921 && ! allocatable_size_p (gnu_size,
922 global_bindings_p () || ! definition
925 gnu_type = build_reference_type (gnu_type);
930 /* Get the data part of GNU_EXPR in case this was a
931 aliased object whose nominal subtype is unconstrained.
932 In that case the pointer above will be a thin pointer and
933 build_allocator will automatically make the template and
934 constructor already made above. */
938 tree gnu_alloc_type = TREE_TYPE (gnu_type);
940 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
941 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
944 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
946 = build_component_ref
947 (gnu_expr, NULL_TREE,
948 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0);
951 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
952 && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
953 && ! Is_Imported (gnat_entity))
954 post_error ("Storage_Error will be raised at run-time?",
957 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
958 gnu_type, 0, 0, gnat_entity);
967 /* If this object would go into the stack and has an alignment
968 larger than the default largest alignment, make a variable
969 to hold the "aligning type" with a modified initial value,
970 if any, then point to it and make that the value of this
971 variable, which is now indirect. */
973 if (! global_bindings_p () && ! static_p && definition
974 && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
977 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
978 TYPE_SIZE_UNIT (gnu_type));
981 set_lineno (gnat_entity, 1);
983 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
984 NULL_TREE, gnu_new_type, gnu_expr,
990 (MODIFY_EXPR, NULL_TREE,
991 build_component_ref (gnu_new_var, NULL_TREE,
992 TYPE_FIELDS (gnu_new_type), 0),
995 gnu_type = build_reference_type (gnu_type);
998 (ADDR_EXPR, gnu_type,
999 build_component_ref (gnu_new_var, NULL_TREE,
1000 TYPE_FIELDS (gnu_new_type), 0));
1007 /* Convert the expression to the type of the object except in the
1008 case where the object's type is unconstrained or the object's type
1009 is a padded record whose field is of self-referential size. In
1010 the former case, converting will generate unnecessary evaluations
1011 of the CONSTRUCTOR to compute the size and in the latter case, we
1012 want to only copy the actual data. */
1014 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1015 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1016 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
1017 && TYPE_IS_PADDING_P (gnu_type)
1018 && (CONTAINS_PLACEHOLDER_P
1019 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1020 gnu_expr = convert (gnu_type, gnu_expr);
1022 /* This name is external or there was a name specified, use it.
1023 Don't use the Interface_Name if there is an address clause.
1025 if ((Present (Interface_Name (gnat_entity))
1026 && No (Address_Clause (gnat_entity)))
1027 || (Is_Public (gnat_entity)
1028 && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity))))
1029 gnu_ext_name = create_concat_name (gnat_entity, 0);
1032 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1033 | TYPE_QUAL_CONST));
1035 /* If this is constant initialized to a static constant and the
1036 object has an aggregrate type, force it to be statically
1038 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1039 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1040 && (AGGREGATE_TYPE_P (gnu_type)
1041 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
1042 && TYPE_IS_PADDING_P (gnu_type))))
1045 set_lineno (gnat_entity, ! global_bindings_p ());
1046 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1047 gnu_expr, const_flag,
1048 Is_Public (gnat_entity),
1049 imported_p || !definition,
1050 static_p, attr_list);
1052 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1053 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1055 /* If we have an address clause and we've made this indirect, it's
1056 not enough to merely mark the type as volatile since volatile
1057 references only conflict with other volatile references while this
1058 reference must conflict with all other references. So ensure that
1059 the dereferenced value has alias set 0. */
1060 if (Present (Address_Clause (gnat_entity)) && used_by_ref)
1061 DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
1063 if (definition && DECL_SIZE (gnu_decl) != 0
1064 && gnu_block_stack != 0
1065 && TREE_VALUE (gnu_block_stack) != 0
1066 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1067 || (flag_stack_check && ! STACK_CHECK_BUILTIN
1068 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1069 STACK_CHECK_MAX_VAR_SIZE))))
1070 update_setjmp_buf (TREE_VALUE (gnu_block_stack));
1072 /* If this is a public constant or we're not optimizing and we're not
1073 making a VAR_DECL for it, make one just for export or debugger
1074 use. Likewise if the address is taken or if the object or type is
1076 if (definition && TREE_CODE (gnu_decl) == CONST_DECL
1077 && (Is_Public (gnat_entity)
1079 || Address_Taken (gnat_entity)
1080 || Is_Aliased (gnat_entity)
1081 || Is_Aliased (Etype (gnat_entity))))
1082 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl,
1083 create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1084 gnu_expr, 0, Is_Public (gnat_entity), 0,
1087 /* If this is declared in a block that contains an block with an
1088 exception handler, we must force this variable in memory to
1089 suppress an invalid optimization. */
1090 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1091 && Exception_Mechanism != GCC_ZCX)
1093 gnat_mark_addressable (gnu_decl);
1094 flush_addressof (gnu_decl);
1097 /* Back-annotate the Alignment of the object if not already in the
1098 tree. Likewise for Esize if the object is of a constant size.
1099 But if the "object" is actually a pointer to an object, the
1100 alignment and size are the same as teh type, so don't back-annotate
1101 the values for the pointer. */
1102 if (! used_by_ref && Unknown_Alignment (gnat_entity))
1103 Set_Alignment (gnat_entity,
1104 UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT));
1106 if (! used_by_ref && Unknown_Esize (gnat_entity)
1107 && DECL_SIZE (gnu_decl) != 0)
1109 tree gnu_back_size = DECL_SIZE (gnu_decl);
1111 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
1112 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl)))
1114 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN
1115 (TYPE_FIELDS (TREE_TYPE (gnu_decl)))));
1117 Set_Esize (gnat_entity, annotate_value (gnu_back_size));
1123 /* Return a TYPE_DECL for "void" that we previously made. */
1124 gnu_decl = void_type_decl_node;
1127 case E_Enumeration_Type:
1128 /* A special case, for the types Character and Wide_Character in
1129 Standard, we do not list all the literals. So if the literals
1130 are not specified, make this an unsigned type. */
1131 if (No (First_Literal (gnat_entity)))
1133 gnu_type = make_unsigned_type (esize);
1137 /* Normal case of non-character type, or non-Standard character type */
1139 /* Here we have a list of enumeral constants in First_Literal.
1140 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1141 the list to be places into TYPE_FIELDS. Each node in the list
1142 is a TREE_LIST node whose TREE_VALUE is the literal name
1143 and whose TREE_PURPOSE is the value of the literal.
1145 Esize contains the number of bits needed to represent the enumeral
1146 type, Type_Low_Bound also points to the first literal and
1147 Type_High_Bound points to the last literal. */
1149 Entity_Id gnat_literal;
1150 tree gnu_literal_list = NULL_TREE;
1152 if (Is_Unsigned_Type (gnat_entity))
1153 gnu_type = make_unsigned_type (esize);
1155 gnu_type = make_signed_type (esize);
1157 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1159 for (gnat_literal = First_Literal (gnat_entity);
1160 Present (gnat_literal);
1161 gnat_literal = Next_Literal (gnat_literal))
1163 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1166 = create_var_decl (get_entity_name (gnat_literal),
1167 0, gnu_type, gnu_value, 1, 0, 0, 0, 0);
1169 save_gnu_tree (gnat_literal, gnu_literal, 0);
1170 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1171 gnu_value, gnu_literal_list);
1174 TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list);
1176 /* Note that the bounds are updated at the end of this function
1177 because to avoid an infinite recursion when we get the bounds of
1178 this type, since those bounds are objects of this type. */
1182 case E_Signed_Integer_Type:
1183 case E_Ordinary_Fixed_Point_Type:
1184 case E_Decimal_Fixed_Point_Type:
1185 /* For integer types, just make a signed type the appropriate number
1187 gnu_type = make_signed_type (esize);
1190 case E_Modular_Integer_Type:
1191 /* For modular types, make the unsigned type of the proper number of
1192 bits and then set up the modulus, if required. */
1194 enum machine_mode mode;
1198 if (Is_Packed_Array_Type (gnat_entity))
1199 esize = UI_To_Int (RM_Size (gnat_entity));
1201 /* Find the smallest mode at least ESIZE bits wide and make a class
1204 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1205 GET_MODE_BITSIZE (mode) < esize;
1206 mode = GET_MODE_WIDER_MODE (mode))
1209 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1210 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1211 = Is_Packed_Array_Type (gnat_entity);
1213 /* Get the modulus in this type. If it overflows, assume it is because
1214 it is equal to 2**Esize. Note that there is no overflow checking
1215 done on unsigned type, so we detect the overflow by looking for
1216 a modulus of zero, which is otherwise invalid. */
1217 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1219 if (! integer_zerop (gnu_modulus))
1221 TYPE_MODULAR_P (gnu_type) = 1;
1222 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1223 gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
1224 convert (gnu_type, integer_one_node)));
1227 /* If we have to set TYPE_PRECISION different from its natural value,
1228 make a subtype to do do. Likewise if there is a modulus and
1229 it is not one greater than TYPE_MAX_VALUE. */
1230 if (TYPE_PRECISION (gnu_type) != esize
1231 || (TYPE_MODULAR_P (gnu_type)
1232 && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1234 tree gnu_subtype = make_node (INTEGER_TYPE);
1236 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1237 TREE_TYPE (gnu_subtype) = gnu_type;
1238 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1239 TYPE_MAX_VALUE (gnu_subtype)
1240 = TYPE_MODULAR_P (gnu_type)
1241 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1242 TYPE_PRECISION (gnu_subtype) = esize;
1243 TREE_UNSIGNED (gnu_subtype) = 1;
1244 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1245 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1246 = Is_Packed_Array_Type (gnat_entity);
1247 layout_type (gnu_subtype);
1249 gnu_type = gnu_subtype;
1254 case E_Signed_Integer_Subtype:
1255 case E_Enumeration_Subtype:
1256 case E_Modular_Integer_Subtype:
1257 case E_Ordinary_Fixed_Point_Subtype:
1258 case E_Decimal_Fixed_Point_Subtype:
1260 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1261 that we do not want to call build_range_type since we would
1262 like each subtype node to be distinct. This will be important
1263 when memory aliasing is implemented.
1265 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1266 parent type; this fact is used by the arithmetic conversion
1269 We elaborate the Ancestor_Subtype if it is not in the current
1270 unit and one of our bounds is non-static. We do this to ensure
1271 consistent naming in the case where several subtypes share the same
1272 bounds by always elaborating the first such subtype first, thus
1276 && Present (Ancestor_Subtype (gnat_entity))
1277 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1278 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1279 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1280 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1281 gnu_expr, definition);
1283 gnu_type = make_node (INTEGER_TYPE);
1284 if (Is_Packed_Array_Type (gnat_entity))
1286 esize = UI_To_Int (RM_Size (gnat_entity));
1287 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1290 TYPE_PRECISION (gnu_type) = esize;
1291 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1293 TYPE_MIN_VALUE (gnu_type)
1294 = convert (TREE_TYPE (gnu_type),
1295 elaborate_expression (Type_Low_Bound (gnat_entity),
1297 get_identifier ("L"), definition, 1,
1298 Needs_Debug_Info (gnat_entity)));
1300 TYPE_MAX_VALUE (gnu_type)
1301 = convert (TREE_TYPE (gnu_type),
1302 elaborate_expression (Type_High_Bound (gnat_entity),
1304 get_identifier ("U"), definition, 1,
1305 Needs_Debug_Info (gnat_entity)));
1307 /* One of the above calls might have caused us to be elaborated,
1308 so don't blow up if so. */
1309 if (present_gnu_tree (gnat_entity))
1315 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1316 = Has_Biased_Representation (gnat_entity);
1318 /* This should be an unsigned type if the lower bound is constant
1319 and non-negative or if the base type is unsigned; a signed type
1321 TREE_UNSIGNED (gnu_type)
1322 = (TREE_UNSIGNED (TREE_TYPE (gnu_type))
1323 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1324 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1325 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1326 || Is_Unsigned_Type (gnat_entity));
1328 layout_type (gnu_type);
1330 /* If the type we are dealing with is to represent a packed array,
1331 we need to have the bits left justified on big-endian targets
1332 (see exp_packd.ads). We build a record with a bitfield of the
1333 appropriate size to achieve this. */
1334 if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN)
1336 tree gnu_field_type = gnu_type;
1339 TYPE_RM_SIZE_INT (gnu_field_type)
1340 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1341 gnu_type = make_node (RECORD_TYPE);
1342 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM");
1343 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1344 TYPE_PACKED (gnu_type) = 1;
1346 /* Don't notify the field as "addressable", since we won't be taking
1347 it's address and it would prevent create_field_decl from making a
1349 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1350 gnu_field_type, gnu_type, 1, 0, 0, 0);
1352 finish_record_type (gnu_type, gnu_field, 0, 0);
1353 TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1354 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1359 case E_Floating_Point_Type:
1360 /* If this is a VAX floating-point type, use an integer of the proper
1361 size. All the operations will be handled with ASM statements. */
1362 if (Vax_Float (gnat_entity))
1364 gnu_type = make_signed_type (esize);
1365 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1366 SET_TYPE_DIGITS_VALUE (gnu_type,
1367 UI_To_gnu (Digits_Value (gnat_entity),
1372 /* The type of the Low and High bounds can be our type if this is
1373 a type from Standard, so set them at the end of the function. */
1374 gnu_type = make_node (REAL_TYPE);
1375 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1376 layout_type (gnu_type);
1379 case E_Floating_Point_Subtype:
1380 if (Vax_Float (gnat_entity))
1382 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1388 && Present (Ancestor_Subtype (gnat_entity))
1389 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1390 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1391 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1392 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1393 gnu_expr, definition);
1395 gnu_type = make_node (REAL_TYPE);
1396 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1397 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1399 TYPE_MIN_VALUE (gnu_type)
1400 = convert (TREE_TYPE (gnu_type),
1401 elaborate_expression (Type_Low_Bound (gnat_entity),
1402 gnat_entity, get_identifier ("L"),
1404 Needs_Debug_Info (gnat_entity)));
1406 TYPE_MAX_VALUE (gnu_type)
1407 = convert (TREE_TYPE (gnu_type),
1408 elaborate_expression (Type_High_Bound (gnat_entity),
1409 gnat_entity, get_identifier ("U"),
1411 Needs_Debug_Info (gnat_entity)));
1413 /* One of the above calls might have caused us to be elaborated,
1414 so don't blow up if so. */
1415 if (present_gnu_tree (gnat_entity))
1421 layout_type (gnu_type);
1425 /* Array and String Types and Subtypes
1427 Unconstrained array types are represented by E_Array_Type and
1428 constrained array types are represented by E_Array_Subtype. There
1429 are no actual objects of an unconstrained array type; all we have
1430 are pointers to that type.
1432 The following fields are defined on array types and subtypes:
1434 Component_Type Component type of the array.
1435 Number_Dimensions Number of dimensions (an int).
1436 First_Index Type of first index. */
1441 tree gnu_template_fields = NULL_TREE;
1442 tree gnu_template_type = make_node (RECORD_TYPE);
1443 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1444 tree gnu_fat_type = make_node (RECORD_TYPE);
1445 int ndim = Number_Dimensions (gnat_entity);
1447 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1449 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1450 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1451 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1452 tree gnu_comp_size = 0;
1453 tree gnu_max_size = size_one_node;
1454 tree gnu_max_size_unit;
1456 Entity_Id gnat_ind_subtype;
1457 Entity_Id gnat_ind_base_subtype;
1458 tree gnu_template_reference;
1461 TYPE_NAME (gnu_template_type)
1462 = create_concat_name (gnat_entity, "XUB");
1463 TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP");
1464 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1465 TREE_READONLY (gnu_template_type) = 1;
1467 /* Make a node for the array. If we are not defining the array
1468 suppress expanding incomplete types and save the node as the type
1470 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1473 defer_incomplete_level++;
1474 this_deferred = this_made_decl = 1;
1475 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
1476 ! Comes_From_Source (gnat_entity),
1478 save_gnu_tree (gnat_entity, gnu_decl, 0);
1482 /* Build the fat pointer type. Use a "void *" object instead of
1483 a pointer to the array type since we don't have the array type
1484 yet (it will reference the fat pointer via the bounds). */
1485 tem = chainon (chainon (NULL_TREE,
1486 create_field_decl (get_identifier ("P_ARRAY"),
1488 gnu_fat_type, 0, 0, 0, 0)),
1489 create_field_decl (get_identifier ("P_BOUNDS"),
1491 gnu_fat_type, 0, 0, 0, 0));
1493 /* Make sure we can put this into a register. */
1494 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1495 finish_record_type (gnu_fat_type, tem, 0, 1);
1497 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1498 is the fat pointer. This will be used to access the individual
1499 fields once we build them. */
1500 tem = build (COMPONENT_REF, gnu_ptr_template,
1501 build (PLACEHOLDER_EXPR, gnu_fat_type),
1502 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
1503 gnu_template_reference
1504 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1505 TREE_READONLY (gnu_template_reference) = 1;
1507 /* Now create the GCC type for each index and add the fields for
1508 that index to the template. */
1509 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1510 gnat_ind_base_subtype
1511 = First_Index (Implementation_Base_Type (gnat_entity));
1512 index < ndim && index >= 0;
1514 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1515 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1517 char field_name[10];
1518 tree gnu_ind_subtype
1519 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1520 tree gnu_base_subtype
1521 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1523 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1525 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1526 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1528 /* Make the FIELD_DECLs for the minimum and maximum of this
1529 type and then make extractions of that field from the
1531 set_lineno (gnat_entity, 0);
1532 sprintf (field_name, "LB%d", index);
1533 gnu_min_field = create_field_decl (get_identifier (field_name),
1535 gnu_template_type, 0, 0, 0, 0);
1536 field_name[0] = 'U';
1537 gnu_max_field = create_field_decl (get_identifier (field_name),
1539 gnu_template_type, 0, 0, 0, 0);
1541 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1543 /* We can't use build_component_ref here since the template
1544 type isn't complete yet. */
1545 gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
1546 gnu_template_reference, gnu_min_field);
1547 gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
1548 gnu_template_reference, gnu_max_field);
1549 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1551 /* Make a range type with the new ranges, but using
1552 the Ada subtype. Then we convert to sizetype. */
1553 gnu_index_types[index]
1554 = create_index_type (convert (sizetype, gnu_min),
1555 convert (sizetype, gnu_max),
1556 build_range_type (gnu_ind_subtype,
1558 /* Update the maximum size of the array, in elements. */
1560 = size_binop (MULT_EXPR, gnu_max_size,
1561 size_binop (PLUS_EXPR, size_one_node,
1562 size_binop (MINUS_EXPR, gnu_base_max,
1565 TYPE_NAME (gnu_index_types[index])
1566 = create_concat_name (gnat_entity, field_name);
1569 for (index = 0; index < ndim; index++)
1571 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1573 /* Install all the fields into the template. */
1574 finish_record_type (gnu_template_type, gnu_template_fields, 0, 0);
1575 TREE_READONLY (gnu_template_type) = 1;
1577 /* Now make the array of arrays and update the pointer to the array
1578 in the fat pointer. Note that it is the first field. */
1580 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1582 /* Get and validate any specified Component_Size, but if Packed,
1583 ignore it since the front end will have taken care of it. */
1585 = validate_size (Component_Size (gnat_entity), tem,
1587 (Is_Bit_Packed_Array (gnat_entity)
1588 ? TYPE_DECL : VAR_DECL), 1,
1589 Has_Component_Size_Clause (gnat_entity));
1591 if (Has_Atomic_Components (gnat_entity))
1592 check_ok_for_atomic (tem, gnat_entity, 1);
1594 /* If the component type is a RECORD_TYPE that has a self-referential
1595 size, use the maxium size. */
1596 if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE
1597 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1598 gnu_comp_size = max_size (TYPE_SIZE (tem), 1);
1600 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1602 tem = make_type_from_size (tem, gnu_comp_size, 0);
1603 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1604 "C_PAD", 0, definition, 1);
1607 if (Has_Volatile_Components (gnat_entity))
1608 tem = build_qualified_type (tem,
1609 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1611 /* If Component_Size is not already specified, annotate it with the
1612 size of the component. */
1613 if (Unknown_Component_Size (gnat_entity))
1614 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1616 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1617 size_binop (MULT_EXPR, gnu_max_size,
1618 TYPE_SIZE_UNIT (tem)));
1619 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1620 size_binop (MULT_EXPR,
1621 convert (bitsizetype,
1625 for (index = ndim - 1; index >= 0; index--)
1627 tem = build_array_type (tem, gnu_index_types[index]);
1628 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1630 /* If the type below this an multi-array type, then this
1631 does not not have aliased components.
1633 ??? Otherwise, for now, we say that any component of aggregate
1634 type is addressable because the front end may take 'Reference
1635 of it. But we have to make it addressable if it must be passed
1636 by reference or it that is the default. */
1637 TYPE_NONALIASED_COMPONENT (tem)
1638 = ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
1639 && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
1640 : (! Has_Aliased_Components (gnat_entity)
1641 && ! AGGREGATE_TYPE_P (TREE_TYPE (tem))));
1644 /* If an alignment is specified, use it if valid. But ignore it for
1645 types that represent the unpacked base type for packed arrays. */
1646 if (No (Packed_Array_Type (gnat_entity))
1647 && Known_Alignment (gnat_entity))
1649 if (No (Alignment (gnat_entity)))
1653 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1657 TYPE_CONVENTION_FORTRAN_P (tem)
1658 = (Convention (gnat_entity) == Convention_Fortran);
1659 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1661 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1662 corresponding fat pointer. */
1663 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1664 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1665 TYPE_MODE (gnu_type) = BLKmode;
1666 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1667 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1669 /* If the maximum size doesn't overflow, use it. */
1670 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1671 && ! TREE_OVERFLOW (gnu_max_size))
1673 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
1674 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1675 && ! TREE_OVERFLOW (gnu_max_size_unit))
1676 TYPE_SIZE_UNIT (tem)
1677 = size_binop (MIN_EXPR, gnu_max_size_unit,
1678 TYPE_SIZE_UNIT (tem));
1680 create_type_decl (create_concat_name (gnat_entity, "XUA"),
1681 tem, 0, ! Comes_From_Source (gnat_entity),
1683 rest_of_type_compilation (gnu_fat_type, global_bindings_p ());
1685 /* Create a record type for the object and its template and
1686 set the template at a negative offset. */
1687 tem = build_unc_object_type (gnu_template_type, tem,
1688 create_concat_name (gnat_entity, "XUT"));
1689 DECL_FIELD_OFFSET (TYPE_FIELDS (tem))
1690 = size_binop (MINUS_EXPR, size_zero_node,
1691 byte_position (TREE_CHAIN (TYPE_FIELDS (tem))));
1692 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node;
1693 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem)))
1694 = bitsize_zero_node;
1695 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
1696 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
1698 /* Give the thin pointer type a name. */
1699 create_type_decl (create_concat_name (gnat_entity, "XUX"),
1700 build_pointer_type (tem), 0,
1701 ! Comes_From_Source (gnat_entity), debug_info_p);
1705 case E_String_Subtype:
1706 case E_Array_Subtype:
1708 /* This is the actual data type for array variables. Multidimensional
1709 arrays are implemented in the gnu tree as arrays of arrays. Note
1710 that for the moment arrays which have sparse enumeration subtypes as
1711 index components create sparse arrays, which is obviously space
1712 inefficient but so much easier to code for now.
1714 Also note that the subtype never refers to the unconstrained
1715 array type, which is somewhat at variance with Ada semantics.
1717 First check to see if this is simply a renaming of the array
1718 type. If so, the result is the array type. */
1720 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1721 if (! Is_Constrained (gnat_entity))
1726 int array_dim = Number_Dimensions (gnat_entity);
1728 = ((Convention (gnat_entity) == Convention_Fortran)
1729 ? array_dim - 1 : 0);
1731 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
1732 Entity_Id gnat_ind_subtype;
1733 Entity_Id gnat_ind_base_subtype;
1734 tree gnu_base_type = gnu_type;
1735 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
1736 tree gnu_comp_size = 0;
1737 tree gnu_max_size = size_one_node;
1738 tree gnu_max_size_unit;
1739 int need_index_type_struct = 0;
1740 int max_overflow = 0;
1742 /* First create the gnu types for each index. Create types for
1743 debugging information to point to the index types if the
1744 are not integer types, have variable bounds, or are
1745 wider than sizetype. */
1747 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
1748 gnat_ind_base_subtype
1749 = First_Index (Implementation_Base_Type (gnat_entity));
1750 index < array_dim && index >= 0;
1752 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1753 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1755 tree gnu_index_subtype
1756 = get_unpadded_type (Etype (gnat_ind_subtype));
1758 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
1760 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
1761 tree gnu_base_subtype
1762 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1764 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1766 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1767 tree gnu_base_type = get_base_type (gnu_base_subtype);
1768 tree gnu_base_base_min
1769 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
1770 tree gnu_base_base_max
1771 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
1775 /* If the minimum and maximum values both overflow in
1776 SIZETYPE, but the difference in the original type
1777 does not overflow in SIZETYPE, ignore the overflow
1779 if ((TYPE_PRECISION (gnu_index_subtype)
1780 > TYPE_PRECISION (sizetype))
1781 && TREE_CODE (gnu_min) == INTEGER_CST
1782 && TREE_CODE (gnu_max) == INTEGER_CST
1783 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
1785 (fold (build (MINUS_EXPR, gnu_index_subtype,
1786 TYPE_MAX_VALUE (gnu_index_subtype),
1787 TYPE_MIN_VALUE (gnu_index_subtype))))))
1788 TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
1789 = TREE_CONSTANT_OVERFLOW (gnu_min)
1790 = TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
1792 /* Similarly, if the range is null, use bounds of 1..0 for
1793 the sizetype bounds. */
1794 else if ((TYPE_PRECISION (gnu_index_subtype)
1795 > TYPE_PRECISION (sizetype))
1796 && TREE_CODE (gnu_min) == INTEGER_CST
1797 && TREE_CODE (gnu_max) == INTEGER_CST
1798 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
1799 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
1800 TYPE_MIN_VALUE (gnu_index_subtype)))
1801 gnu_min = size_one_node, gnu_max = size_zero_node;
1803 /* Now compute the size of this bound. We need to provide
1804 GCC with an upper bound to use but have to deal with the
1805 "superflat" case. There are three ways to do this. If we
1806 can prove that the array can never be superflat, we can
1807 just use the high bound of the index subtype. If we can
1808 prove that the low bound minus one can't overflow, we
1809 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1810 the expression hb >= lb ? hb : lb - 1. */
1811 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
1813 /* See if the base array type is already flat. If it is, we
1814 are probably compiling an ACVC test, but it will cause the
1815 code below to malfunction if we don't handle it specially. */
1816 if (TREE_CODE (gnu_base_min) == INTEGER_CST
1817 && TREE_CODE (gnu_base_max) == INTEGER_CST
1818 && ! TREE_CONSTANT_OVERFLOW (gnu_base_min)
1819 && ! TREE_CONSTANT_OVERFLOW (gnu_base_max)
1820 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
1821 gnu_high = size_zero_node, gnu_min = size_one_node;
1823 /* If gnu_high is now an integer which overflowed, the array
1824 cannot be superflat. */
1825 else if (TREE_CODE (gnu_high) == INTEGER_CST
1826 && TREE_OVERFLOW (gnu_high))
1828 else if (TREE_UNSIGNED (gnu_base_subtype)
1829 || TREE_CODE (gnu_high) == INTEGER_CST)
1830 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
1834 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
1838 gnu_index_type[index]
1839 = create_index_type (gnu_min, gnu_high, gnu_index_subtype);
1841 /* Also compute the maximum size of the array. Here we
1842 see if any constraint on the index type of the base type
1843 can be used in the case of self-referential bound on
1844 the index type of the subtype. We look for a non-"infinite"
1845 and non-self-referential bound from any type involved and
1846 handle each bound separately. */
1848 if ((TREE_CODE (gnu_min) == INTEGER_CST
1849 && ! TREE_OVERFLOW (gnu_min)
1850 && ! operand_equal_p (gnu_min, gnu_base_base_min, 0))
1851 || ! CONTAINS_PLACEHOLDER_P (gnu_min))
1852 gnu_base_min = gnu_min;
1854 if ((TREE_CODE (gnu_max) == INTEGER_CST
1855 && ! TREE_OVERFLOW (gnu_max)
1856 && ! operand_equal_p (gnu_max, gnu_base_base_max, 0))
1857 || ! CONTAINS_PLACEHOLDER_P (gnu_max))
1858 gnu_base_max = gnu_max;
1860 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
1861 && TREE_CONSTANT_OVERFLOW (gnu_base_min))
1862 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
1863 || (TREE_CODE (gnu_base_max) == INTEGER_CST
1864 && TREE_CONSTANT_OVERFLOW (gnu_base_max))
1865 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
1868 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
1869 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
1872 = size_binop (MAX_EXPR,
1873 size_binop (PLUS_EXPR, size_one_node,
1874 size_binop (MINUS_EXPR, gnu_base_max,
1878 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1879 && TREE_CONSTANT_OVERFLOW (gnu_this_max))
1883 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1885 if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
1886 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
1888 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
1889 || (TREE_TYPE (gnu_index_subtype) != 0
1890 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
1892 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
1893 || (TYPE_PRECISION (gnu_index_subtype)
1894 > TYPE_PRECISION (sizetype)))
1895 need_index_type_struct = 1;
1898 /* Then flatten: create the array of arrays. */
1900 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
1902 /* One of the above calls might have caused us to be elaborated,
1903 so don't blow up if so. */
1904 if (present_gnu_tree (gnat_entity))
1910 /* Get and validate any specified Component_Size, but if Packed,
1911 ignore it since the front end will have taken care of it. */
1913 = validate_size (Component_Size (gnat_entity), gnu_type,
1915 (Is_Bit_Packed_Array (gnat_entity)
1916 ? TYPE_DECL : VAR_DECL),
1917 1, Has_Component_Size_Clause (gnat_entity));
1919 /* If the component type is a RECORD_TYPE that has a self-referential
1920 size, use the maxium size. */
1921 if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE
1922 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
1923 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1);
1925 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1927 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0);
1928 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
1929 gnat_entity, "C_PAD", 0,
1933 if (Has_Volatile_Components (Base_Type (gnat_entity)))
1934 gnu_type = build_qualified_type (gnu_type,
1935 (TYPE_QUALS (gnu_type)
1936 | TYPE_QUAL_VOLATILE));
1938 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1939 TYPE_SIZE_UNIT (gnu_type));
1940 gnu_max_size = size_binop (MULT_EXPR,
1941 convert (bitsizetype, gnu_max_size),
1942 TYPE_SIZE (gnu_type));
1944 /* We don't want any array types shared for two reasons: first,
1945 we want to keep differently-named types distinct; second,
1946 setting TYPE_MULTI_ARRAY_TYPE of one type can clobber
1948 debug_no_type_hash = 1;
1949 for (index = array_dim - 1; index >= 0; index --)
1951 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
1952 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
1953 /* If the type below this an multi-array type, then this
1954 does not not have aliased components.
1956 ??? Otherwise, for now, we say that any component of aggregate
1957 type is addressable because the front end may take 'Reference
1958 of it. But we have to make it addressable if it must be passed
1959 by reference or it that is the default. */
1960 TYPE_NONALIASED_COMPONENT (gnu_type)
1961 = ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1962 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
1963 : (! Has_Aliased_Components (gnat_entity)
1964 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
1967 /* If we are at file level and this is a multi-dimensional array, we
1968 need to make a variable corresponding to the stride of the
1969 inner dimensions. */
1970 if (global_bindings_p () && array_dim > 1)
1972 tree gnu_str_name = get_identifier ("ST");
1975 for (gnu_arr_type = TREE_TYPE (gnu_type);
1976 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
1977 gnu_arr_type = TREE_TYPE (gnu_arr_type),
1978 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
1980 TYPE_SIZE (gnu_arr_type)
1981 = elaborate_expression_1 (gnat_entity, gnat_entity,
1982 TYPE_SIZE (gnu_arr_type),
1983 gnu_str_name, definition, 0);
1984 TYPE_SIZE_UNIT (gnu_arr_type)
1985 = elaborate_expression_1
1986 (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type),
1987 concat_id_with_name (gnu_str_name, "U"), definition, 0);
1991 /* If we need to write out a record type giving the names of
1992 the bounds, do it now. */
1993 if (need_index_type_struct && debug_info_p)
1995 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
1996 tree gnu_field_list = 0;
1999 TYPE_NAME (gnu_bound_rec_type)
2000 = create_concat_name (gnat_entity, "XA");
2002 for (index = array_dim - 1; index >= 0; index--)
2005 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2007 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2008 gnu_type_name = DECL_NAME (gnu_type_name);
2010 gnu_field = create_field_decl (gnu_type_name,
2013 0, NULL_TREE, NULL_TREE, 0);
2014 TREE_CHAIN (gnu_field) = gnu_field_list;
2015 gnu_field_list = gnu_field;
2018 finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0);
2021 debug_no_type_hash = 0;
2022 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2023 = (Convention (gnat_entity) == Convention_Fortran);
2024 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2025 = Is_Packed_Array_Type (gnat_entity);
2027 /* If our size depends on a placeholder and the maximum size doesn't
2028 overflow, use it. */
2029 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2030 && ! (TREE_CODE (gnu_max_size) == INTEGER_CST
2031 && TREE_OVERFLOW (gnu_max_size))
2032 && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2033 && TREE_OVERFLOW (gnu_max_size_unit))
2036 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2037 TYPE_SIZE (gnu_type));
2038 TYPE_SIZE_UNIT (gnu_type)
2039 = size_binop (MIN_EXPR, gnu_max_size_unit,
2040 TYPE_SIZE_UNIT (gnu_type));
2043 /* Set our alias set to that of our base type. This gives all
2044 array subtypes the same alias set. */
2045 copy_alias_set (gnu_type, gnu_base_type);
2048 /* If this is a packed type, make this type the same as the packed
2049 array type, but do some adjusting in the type first. */
2051 if (Present (Packed_Array_Type (gnat_entity)))
2053 Entity_Id gnat_index;
2054 tree gnu_inner_type;
2056 /* First finish the type we had been making so that we output
2057 debugging information for it */
2058 gnu_type = build_qualified_type (gnu_type,
2059 (TYPE_QUALS (gnu_type)
2060 | (TYPE_QUAL_VOLATILE
2061 * Treat_As_Volatile (gnat_entity))));
2062 set_lineno (gnat_entity, 0);
2063 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2064 ! Comes_From_Source (gnat_entity),
2066 if (! Comes_From_Source (gnat_entity))
2067 DECL_ARTIFICIAL (gnu_decl) = 1;
2069 /* Save it as our equivalent in case the call below elaborates
2071 save_gnu_tree (gnat_entity, gnu_decl, 0);
2073 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2076 gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
2077 save_gnu_tree (gnat_entity, NULL_TREE, 0);
2079 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2080 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type)
2081 || TYPE_IS_PADDING_P (gnu_inner_type)))
2082 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2084 /* We need to point the type we just made to our index type so
2085 the actual bounds can be put into a template. */
2087 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2088 && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0)
2089 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2090 && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2092 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2094 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2095 If it is, we need to make another type. */
2096 if (TYPE_MODULAR_P (gnu_inner_type))
2100 gnu_subtype = make_node (INTEGER_TYPE);
2102 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2103 TYPE_MIN_VALUE (gnu_subtype)
2104 = TYPE_MIN_VALUE (gnu_inner_type);
2105 TYPE_MAX_VALUE (gnu_subtype)
2106 = TYPE_MAX_VALUE (gnu_inner_type);
2107 TYPE_PRECISION (gnu_subtype)
2108 = TYPE_PRECISION (gnu_inner_type);
2109 TREE_UNSIGNED (gnu_subtype)
2110 = TREE_UNSIGNED (gnu_inner_type);
2111 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2112 layout_type (gnu_subtype);
2114 gnu_inner_type = gnu_subtype;
2117 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2120 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2122 for (gnat_index = First_Index (gnat_entity);
2123 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2124 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type,
2125 tree_cons (NULL_TREE,
2126 get_unpadded_type (Etype (gnat_index)),
2127 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2129 if (Convention (gnat_entity) != Convention_Fortran)
2130 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type,
2131 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2133 if (TREE_CODE (gnu_type) == RECORD_TYPE
2134 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
2135 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2139 /* Abort if packed array with no packed array type field set. */
2140 else if (Is_Packed (gnat_entity))
2145 case E_String_Literal_Subtype:
2146 /* Create the type for a string literal. */
2148 Entity_Id gnat_full_type
2149 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2150 && Present (Full_View (Etype (gnat_entity)))
2151 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2152 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2153 tree gnu_string_array_type
2154 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2155 tree gnu_string_index_type
2156 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2157 (TYPE_DOMAIN (gnu_string_array_type))));
2158 tree gnu_lower_bound
2159 = convert (gnu_string_index_type,
2160 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2161 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2162 tree gnu_length = ssize_int (length - 1);
2163 tree gnu_upper_bound
2164 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2166 convert (gnu_string_index_type, gnu_length));
2168 = build_range_type (gnu_string_index_type,
2169 gnu_lower_bound, gnu_upper_bound);
2171 = create_index_type (convert (sizetype,
2172 TYPE_MIN_VALUE (gnu_range_type)),
2174 TYPE_MAX_VALUE (gnu_range_type)),
2178 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2183 /* Record Types and Subtypes
2185 The following fields are defined on record types:
2187 Has_Discriminants True if the record has discriminants
2188 First_Discriminant Points to head of list of discriminants
2189 First_Entity Points to head of list of fields
2190 Is_Tagged_Type True if the record is tagged
2192 Implementation of Ada records and discriminated records:
2194 A record type definition is transformed into the equivalent of a C
2195 struct definition. The fields that are the discriminants which are
2196 found in the Full_Type_Declaration node and the elements of the
2197 Component_List found in the Record_Type_Definition node. The
2198 Component_List can be a recursive structure since each Variant of
2199 the Variant_Part of the Component_List has a Component_List.
2201 Processing of a record type definition comprises starting the list of
2202 field declarations here from the discriminants and the calling the
2203 function components_to_record to add the rest of the fields from the
2204 component list and return the gnu type node. The function
2205 components_to_record will call itself recursively as it traverses
2209 if (Has_Complex_Representation (gnat_entity))
2212 = build_complex_type
2214 (Etype (Defining_Entity
2215 (First (Component_Items
2218 (Declaration_Node (gnat_entity)))))))));
2224 Node_Id full_definition = Declaration_Node (gnat_entity);
2225 Node_Id record_definition = Type_Definition (full_definition);
2226 Entity_Id gnat_field;
2228 tree gnu_field_list = NULL_TREE;
2229 tree gnu_get_parent;
2230 int packed = (Is_Packed (gnat_entity) ? 1
2231 : (Component_Alignment (gnat_entity)
2232 == Calign_Storage_Unit) ? -1
2234 int has_rep = Has_Specified_Layout (gnat_entity);
2235 int all_rep = has_rep;
2237 = (Is_Tagged_Type (gnat_entity)
2238 && Nkind (record_definition) == N_Derived_Type_Definition);
2240 /* See if all fields have a rep clause. Stop when we find one
2242 for (gnat_field = First_Entity (gnat_entity);
2243 Present (gnat_field) && all_rep;
2244 gnat_field = Next_Entity (gnat_field))
2245 if ((Ekind (gnat_field) == E_Component
2246 || Ekind (gnat_field) == E_Discriminant)
2247 && No (Component_Clause (gnat_field)))
2250 /* If this is a record extension, go a level further to find the
2251 record definition. Also, verify we have a Parent_Subtype. */
2254 if (! type_annotate_only
2255 || Present (Record_Extension_Part (record_definition)))
2256 record_definition = Record_Extension_Part (record_definition);
2258 if (! type_annotate_only && No (Parent_Subtype (gnat_entity)))
2262 /* Make a node for the record. If we are not defining the record,
2263 suppress expanding incomplete types and save the node as the type
2264 for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
2265 and reset TYPE_DUMMY_P to show it's no longer a dummy.
2267 It is very tempting to delay resetting this bit until we are done
2268 with completing the type, e.g. to let possible intermediate
2269 elaboration of access types designating the record know it is not
2270 complete and arrange for update_pointer_to to fix things up later.
2272 It would be wrong, however, because dummy types are expected only
2273 to be created for Ada incomplete or private types, which is not
2274 what we have here. Doing so would make other parts of gigi think
2275 we are dealing with a really incomplete or private type, and have
2276 nasty side effects, typically on the generation of the associated
2277 debugging information. */
2278 gnu_type = make_dummy_type (gnat_entity);
2279 TYPE_DUMMY_P (gnu_type) = 0;
2281 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
2282 DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
2284 TYPE_ALIGN (gnu_type) = 0;
2285 TYPE_PACKED (gnu_type) = packed != 0 || has_rep;
2289 defer_incomplete_level++;
2291 set_lineno (gnat_entity, 0);
2292 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2293 ! Comes_From_Source (gnat_entity),
2295 save_gnu_tree (gnat_entity, gnu_decl, 0);
2296 this_made_decl = saved = 1;
2299 /* If both a size and rep clause was specified, put the size in
2300 the record type now so that it can get the proper mode. */
2301 if (has_rep && Known_Esize (gnat_entity))
2302 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2304 /* Always set the alignment here so that it can be used to
2305 set the mode, if it is making the alignment stricter. If
2306 it is invalid, it will be checked again below. If this is to
2307 be Atomic, choose a default alignment of a word unless we know
2308 the size and it's smaller. */
2309 if (Known_Alignment (gnat_entity))
2310 TYPE_ALIGN (gnu_type)
2311 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2312 else if (Is_Atomic (gnat_entity))
2313 TYPE_ALIGN (gnu_type)
2314 = (esize >= BITS_PER_WORD ? BITS_PER_WORD
2315 : 1 << ((floor_log2 (esize) - 1) + 1));
2317 /* If we have a Parent_Subtype, make a field for the parent. If
2318 this record has rep clauses, force the position to zero. */
2319 if (Present (Parent_Subtype (gnat_entity)))
2323 /* A major complexity here is that the parent subtype will
2324 reference our discriminants. But those must reference
2325 the parent component of this record. So here we will
2326 initialize each of those components to a COMPONENT_REF.
2327 The first operand of that COMPONENT_REF is another
2328 COMPONENT_REF which will be filled in below, once
2329 the parent type can be safely built. */
2331 gnu_get_parent = build (COMPONENT_REF, void_type_node,
2332 build (PLACEHOLDER_EXPR, gnu_type),
2333 build_decl (FIELD_DECL, NULL_TREE,
2336 if (Has_Discriminants (gnat_entity))
2337 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2338 Present (gnat_field);
2339 gnat_field = Next_Stored_Discriminant (gnat_field))
2340 if (Present (Corresponding_Discriminant (gnat_field)))
2343 build (COMPONENT_REF,
2344 get_unpadded_type (Etype (gnat_field)),
2346 gnat_to_gnu_entity (Corresponding_Discriminant
2351 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
2354 = create_field_decl (get_identifier
2355 (Get_Name_String (Name_uParent)),
2356 gnu_parent, gnu_type, 0,
2357 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2358 has_rep ? bitsize_zero_node : 0, 1);
2359 DECL_INTERNAL_P (gnu_field_list) = 1;
2361 TREE_TYPE (gnu_get_parent) = gnu_parent;
2362 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2365 /* Add the fields for the discriminants into the record. */
2366 if (! Is_Unchecked_Union (gnat_entity)
2367 && Has_Discriminants (gnat_entity))
2368 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2369 Present (gnat_field);
2370 gnat_field = Next_Stored_Discriminant (gnat_field))
2372 /* If this is a record extension and this discriminant
2373 is the renaming of another discriminant, we've already
2374 handled the discriminant above. */
2375 if (Present (Parent_Subtype (gnat_entity))
2376 && Present (Corresponding_Discriminant (gnat_field)))
2380 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2382 /* Make an expression using a PLACEHOLDER_EXPR from the
2383 FIELD_DECL node just created and link that with the
2384 corresponding GNAT defining identifier. Then add to the
2386 save_gnu_tree (gnat_field,
2387 build (COMPONENT_REF, TREE_TYPE (gnu_field),
2388 build (PLACEHOLDER_EXPR,
2389 DECL_CONTEXT (gnu_field)),
2393 TREE_CHAIN (gnu_field) = gnu_field_list;
2394 gnu_field_list = gnu_field;
2397 /* Put the discriminants into the record (backwards), so we can
2398 know the appropriate discriminant to use for the names of the
2400 TYPE_FIELDS (gnu_type) = gnu_field_list;
2402 /* Add the listed fields into the record and finish up. */
2403 components_to_record (gnu_type, Component_List (record_definition),
2404 gnu_field_list, packed, definition, 0,
2407 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2408 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2410 /* If this is an extension type, reset the tree for any
2411 inherited discriminants. Also remove the PLACEHOLDER_EXPR
2412 for non-inherited discriminants. */
2413 if (! Is_Unchecked_Union (gnat_entity)
2414 && Has_Discriminants (gnat_entity))
2415 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2416 Present (gnat_field);
2417 gnat_field = Next_Stored_Discriminant (gnat_field))
2419 if (Present (Parent_Subtype (gnat_entity))
2420 && Present (Corresponding_Discriminant (gnat_field)))
2421 save_gnu_tree (gnat_field, NULL_TREE, 0);
2424 gnu_field = get_gnu_tree (gnat_field);
2425 save_gnu_tree (gnat_field, NULL_TREE, 0);
2426 save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0);
2430 /* If it is a tagged record force the type to BLKmode to insure
2431 that these objects will always be placed in memory. Do the
2432 same thing for limited record types. */
2433 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2434 TYPE_MODE (gnu_type) = BLKmode;
2436 /* If this is a derived type, we must make the alias set of this type
2437 the same as that of the type we are derived from. We assume here
2438 that the other type is already frozen. */
2439 if (Etype (gnat_entity) != gnat_entity
2440 && ! (Is_Private_Type (Etype (gnat_entity))
2441 && Full_View (Etype (gnat_entity)) == gnat_entity))
2442 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2444 /* Fill in locations of fields. */
2445 annotate_rep (gnat_entity, gnu_type);
2447 /* If there are any entities in the chain corresponding to
2448 components that we did not elaborate, ensure we elaborate their
2449 types if they are Itypes. */
2450 for (gnat_temp = First_Entity (gnat_entity);
2451 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2452 if ((Ekind (gnat_temp) == E_Component
2453 || Ekind (gnat_temp) == E_Discriminant)
2454 && Is_Itype (Etype (gnat_temp))
2455 && ! present_gnu_tree (gnat_temp))
2456 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2460 case E_Class_Wide_Subtype:
2461 /* If an equivalent type is present, that is what we should use.
2462 Otherwise, fall through to handle this like a record subtype
2463 since it may have constraints. */
2465 if (Present (Equivalent_Type (gnat_entity)))
2467 gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
2473 /* ... fall through ... */
2475 case E_Record_Subtype:
2477 /* If Cloned_Subtype is Present it means this record subtype has
2478 identical layout to that type or subtype and we should use
2479 that GCC type for this one. The front end guarantees that
2480 the component list is shared. */
2481 if (Present (Cloned_Subtype (gnat_entity)))
2483 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2488 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2489 changing the type, make a new type with each field having the
2490 type of the field in the new subtype but having the position
2491 computed by transforming every discriminant reference according
2492 to the constraints. We don't see any difference between
2493 private and nonprivate type here since derivations from types should
2494 have been deferred until the completion of the private type. */
2497 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2502 defer_incomplete_level++, this_deferred = 1;
2504 /* Get the base type initially for its alignment and sizes. But
2505 if it is a padded type, we do all the other work with the
2507 gnu_type = gnu_orig_type = gnu_base_type
2508 = gnat_to_gnu_type (gnat_base_type);
2510 if (TREE_CODE (gnu_type) == RECORD_TYPE
2511 && TYPE_IS_PADDING_P (gnu_type))
2512 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2514 if (present_gnu_tree (gnat_entity))
2520 /* When the type has discriminants, and these discriminants
2521 affect the shape of what it built, factor them in.
2523 If we are making a subtype of an Unchecked_Union (must be an
2524 Itype), just return the type.
2526 We can't just use Is_Constrained because private subtypes without
2527 discriminants of full types with discriminants with default
2528 expressions are Is_Constrained but aren't constrained! */
2530 if (IN (Ekind (gnat_base_type), Record_Kind)
2531 && ! Is_For_Access_Subtype (gnat_entity)
2532 && ! Is_Unchecked_Union (gnat_base_type)
2533 && Is_Constrained (gnat_entity)
2534 && Stored_Constraint (gnat_entity) != No_Elist
2535 && Present (Discriminant_Constraint (gnat_entity)))
2537 Entity_Id gnat_field;
2538 Entity_Id gnat_root_type;
2539 tree gnu_field_list = 0;
2541 = compute_field_positions (gnu_orig_type, NULL_TREE,
2542 size_zero_node, bitsize_zero_node,
2545 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2549 /* If this is a derived type, we may be seeing fields from any
2550 original records, so add those positions and discriminant
2551 substitutions to our lists. */
2552 for (gnat_root_type = gnat_base_type;
2553 Underlying_Type (Etype (gnat_root_type)) != gnat_root_type;
2554 gnat_root_type = Underlying_Type (Etype (gnat_root_type)))
2557 = compute_field_positions
2558 (gnat_to_gnu_type (Etype (gnat_root_type)),
2559 gnu_pos_list, size_zero_node, bitsize_zero_node,
2562 if (Present (Parent_Subtype (gnat_root_type)))
2564 = substitution_list (Parent_Subtype (gnat_root_type),
2565 Empty, gnu_subst_list, definition);
2568 gnu_type = make_node (RECORD_TYPE);
2569 TYPE_NAME (gnu_type) = gnu_entity_id;
2570 TYPE_STUB_DECL (gnu_type)
2571 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
2572 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2574 for (gnat_field = First_Entity (gnat_entity);
2575 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2576 if (Ekind (gnat_field) == E_Component
2577 || Ekind (gnat_field) == E_Discriminant)
2580 = gnat_to_gnu_entity
2581 (Original_Record_Component (gnat_field), NULL_TREE, 0);
2583 = TREE_VALUE (purpose_member (gnu_old_field,
2585 tree gnu_pos = TREE_PURPOSE (gnu_offset);
2586 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
2588 = gnat_to_gnu_type (Etype (gnat_field));
2589 tree gnu_size = TYPE_SIZE (gnu_field_type);
2590 tree gnu_new_pos = 0;
2591 unsigned int offset_align
2592 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
2596 /* If there was a component clause, the field types must be
2597 the same for the type and subtype, so copy the data from
2598 the old field to avoid recomputation here. */
2599 if (Present (Component_Clause
2600 (Original_Record_Component (gnat_field))))
2602 gnu_size = DECL_SIZE (gnu_old_field);
2603 gnu_field_type = TREE_TYPE (gnu_old_field);
2606 /* If this was a bitfield, get the size from the old field.
2607 Also ensure the type can be placed into a bitfield. */
2608 else if (DECL_BIT_FIELD (gnu_old_field))
2610 gnu_size = DECL_SIZE (gnu_old_field);
2611 if (TYPE_MODE (gnu_field_type) == BLKmode
2612 && TREE_CODE (gnu_field_type) == RECORD_TYPE
2613 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
2614 gnu_field_type = make_packable_type (gnu_field_type);
2617 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
2618 for (gnu_temp = gnu_subst_list;
2619 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2620 gnu_pos = substitute_in_expr (gnu_pos,
2621 TREE_PURPOSE (gnu_temp),
2622 TREE_VALUE (gnu_temp));
2624 /* If the size is now a constant, we can set it as the
2625 size of the field when we make it. Otherwise, we need
2626 to deal with it specially. */
2627 if (TREE_CONSTANT (gnu_pos))
2628 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
2632 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
2633 0, gnu_size, gnu_new_pos,
2634 ! DECL_NONADDRESSABLE_P (gnu_old_field));
2636 if (! TREE_CONSTANT (gnu_pos))
2638 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
2639 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
2640 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
2641 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
2642 DECL_SIZE (gnu_field) = gnu_size;
2643 DECL_SIZE_UNIT (gnu_field)
2644 = convert (sizetype,
2645 size_binop (CEIL_DIV_EXPR, gnu_size,
2646 bitsize_unit_node));
2647 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
2650 DECL_INTERNAL_P (gnu_field)
2651 = DECL_INTERNAL_P (gnu_old_field);
2652 SET_DECL_ORIGINAL_FIELD (gnu_field,
2653 (DECL_ORIGINAL_FIELD (gnu_old_field) != 0
2654 ? DECL_ORIGINAL_FIELD (gnu_old_field)
2656 DECL_DISCRIMINANT_NUMBER (gnu_field)
2657 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
2658 TREE_THIS_VOLATILE (gnu_field)
2659 = TREE_THIS_VOLATILE (gnu_old_field);
2660 TREE_CHAIN (gnu_field) = gnu_field_list;
2661 gnu_field_list = gnu_field;
2662 save_gnu_tree (gnat_field, gnu_field, 0);
2665 finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0);
2667 /* Now set the size, alignment and alias set of the new type to
2668 match that of the old one, doing any substitutions, as
2670 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2671 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2672 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2673 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2674 copy_alias_set (gnu_type, gnu_base_type);
2676 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2677 for (gnu_temp = gnu_subst_list;
2678 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2679 TYPE_SIZE (gnu_type)
2680 = substitute_in_expr (TYPE_SIZE (gnu_type),
2681 TREE_PURPOSE (gnu_temp),
2682 TREE_VALUE (gnu_temp));
2684 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2685 for (gnu_temp = gnu_subst_list;
2686 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2687 TYPE_SIZE_UNIT (gnu_type)
2688 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2689 TREE_PURPOSE (gnu_temp),
2690 TREE_VALUE (gnu_temp));
2692 if (TYPE_ADA_SIZE (gnu_type) != 0
2693 && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2694 for (gnu_temp = gnu_subst_list;
2695 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2696 SET_TYPE_ADA_SIZE (gnu_type,
2697 substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2698 TREE_PURPOSE (gnu_temp),
2699 TREE_VALUE (gnu_temp)));
2701 /* Recompute the mode of this record type now that we know its
2703 compute_record_mode (gnu_type);
2705 /* Fill in locations of fields. */
2706 annotate_rep (gnat_entity, gnu_type);
2709 /* If we've made a new type, record it and make an XVS type to show
2710 what this is a subtype of. Some debuggers require the XVS
2711 type to be output first, so do it in that order. */
2712 if (gnu_type != gnu_orig_type)
2716 tree gnu_subtype_marker = make_node (RECORD_TYPE);
2717 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
2719 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
2720 gnu_orig_name = DECL_NAME (gnu_orig_name);
2722 TYPE_NAME (gnu_subtype_marker)
2723 = create_concat_name (gnat_entity, "XVS");
2724 finish_record_type (gnu_subtype_marker,
2725 create_field_decl (gnu_orig_name,
2733 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2734 TYPE_NAME (gnu_type) = gnu_entity_id;
2735 TYPE_STUB_DECL (gnu_type)
2736 = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type),
2738 DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1;
2739 DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p;
2740 rest_of_type_compilation (gnu_type, global_bindings_p ());
2743 /* Otherwise, go down all the components in the new type and
2744 make them equivalent to those in the base type. */
2746 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
2747 gnat_temp = Next_Entity (gnat_temp))
2748 if ((Ekind (gnat_temp) == E_Discriminant
2749 && ! Is_Unchecked_Union (gnat_base_type))
2750 || Ekind (gnat_temp) == E_Component)
2751 save_gnu_tree (gnat_temp,
2753 (Original_Record_Component (gnat_temp)), 0);
2757 case E_Access_Subprogram_Type:
2758 /* If we are not defining this entity, and we have incomplete
2759 entities being processed above us, make a dummy type and
2760 fill it in later. */
2761 if (! definition && defer_incomplete_level != 0)
2763 struct incomplete *p
2764 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
2767 = build_pointer_type
2768 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
2769 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2770 ! Comes_From_Source (gnat_entity),
2772 save_gnu_tree (gnat_entity, gnu_decl, 0);
2773 this_made_decl = saved = 1;
2775 p->old_type = TREE_TYPE (gnu_type);
2776 p->full_type = Directly_Designated_Type (gnat_entity);
2777 p->next = defer_incomplete_list;
2778 defer_incomplete_list = p;
2782 /* ... fall through ... */
2784 case E_Allocator_Type:
2786 case E_Access_Attribute_Type:
2787 case E_Anonymous_Access_Type:
2788 case E_General_Access_Type:
2790 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
2791 Entity_Id gnat_desig_full
2792 = ((IN (Ekind (Etype (gnat_desig_type)),
2793 Incomplete_Or_Private_Kind))
2794 ? Full_View (gnat_desig_type) : 0);
2795 /* We want to know if we'll be seeing the freeze node for any
2796 incomplete type we may be pointing to. */
2798 = (Present (gnat_desig_full)
2799 ? In_Extended_Main_Code_Unit (gnat_desig_full)
2800 : In_Extended_Main_Code_Unit (gnat_desig_type));
2803 tree gnu_desig_type = 0;
2805 if (No (gnat_desig_full)
2806 && (Ekind (gnat_desig_type) == E_Class_Wide_Type
2807 || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype
2808 && Present (Equivalent_Type (gnat_desig_type)))))
2810 if (Present (Equivalent_Type (gnat_desig_type)))
2812 gnat_desig_full = Equivalent_Type (gnat_desig_type);
2813 if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind))
2814 gnat_desig_full = Full_View (gnat_desig_full);
2816 else if (IN (Ekind (Root_Type (gnat_desig_type)),
2817 Incomplete_Or_Private_Kind))
2818 gnat_desig_full = Full_View (Root_Type (gnat_desig_type));
2821 if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full))
2822 gnat_desig_full = Corresponding_Record_Type (gnat_desig_full);
2824 /* If either the designated type or its full view is an
2825 unconstrained array subtype, replace it with the type it's a
2826 subtype of. This avoids problems with multiple copies of
2827 unconstrained array types. */
2828 if (Ekind (gnat_desig_type) == E_Array_Subtype
2829 && ! Is_Constrained (gnat_desig_type))
2830 gnat_desig_type = Etype (gnat_desig_type);
2831 if (Present (gnat_desig_full)
2832 && Ekind (gnat_desig_full) == E_Array_Subtype
2833 && ! Is_Constrained (gnat_desig_full))
2834 gnat_desig_full = Etype (gnat_desig_full);
2836 /* If the designated type is a subtype of an incomplete record type,
2837 use the parent type to avoid order of elaboration issues. This
2838 can lose some code efficiency, but there is no alternative. */
2839 if (Present (gnat_desig_full)
2840 && Ekind (gnat_desig_full) == E_Record_Subtype
2841 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)
2842 gnat_desig_full = Etype (gnat_desig_full);
2844 /* If we are pointing to an incomplete type whose completion is an
2845 unconstrained array, make a fat pointer type instead of a pointer
2846 to VOID. The two types in our fields will be pointers to VOID and
2847 will be replaced in update_pointer_to. Similiarly, if the type
2848 itself is a dummy type or an unconstrained array. Also make
2849 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
2852 if ((Present (gnat_desig_full)
2853 && Is_Array_Type (gnat_desig_full)
2854 && ! Is_Constrained (gnat_desig_full))
2855 || (present_gnu_tree (gnat_desig_type)
2856 && TYPE_IS_DUMMY_P (TREE_TYPE
2857 (get_gnu_tree (gnat_desig_type)))
2858 && Is_Array_Type (gnat_desig_type)
2859 && ! Is_Constrained (gnat_desig_type))
2860 || (present_gnu_tree (gnat_desig_type)
2861 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type)))
2862 == UNCONSTRAINED_ARRAY_TYPE)
2863 && (TYPE_POINTER_TO (TREE_TYPE
2864 (get_gnu_tree (gnat_desig_type)))
2866 || (No (gnat_desig_full) && ! in_main_unit
2867 && defer_incomplete_level != 0
2868 && ! present_gnu_tree (gnat_desig_type)
2869 && Is_Array_Type (gnat_desig_type)
2870 && ! Is_Constrained (gnat_desig_type)))
2873 = (present_gnu_tree (gnat_desig_type)
2874 ? gnat_to_gnu_type (gnat_desig_type)
2875 : make_dummy_type (gnat_desig_type));
2878 /* Show the dummy we get will be a fat pointer. */
2879 got_fat_p = made_dummy = 1;
2881 /* If the call above got something that has a pointer, that
2882 pointer is our type. This could have happened either
2883 because the type was elaborated or because somebody
2884 else executed the code below. */
2885 gnu_type = TYPE_POINTER_TO (gnu_old);
2888 gnu_type = make_node (RECORD_TYPE);
2889 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
2890 TYPE_POINTER_TO (gnu_old) = gnu_type;
2892 set_lineno (gnat_entity, 0);
2894 = chainon (chainon (NULL_TREE,
2896 (get_identifier ("P_ARRAY"),
2897 ptr_void_type_node, gnu_type,
2899 create_field_decl (get_identifier ("P_BOUNDS"),
2901 gnu_type, 0, 0, 0, 0));
2903 /* Make sure we can place this into a register. */
2904 TYPE_ALIGN (gnu_type)
2905 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
2906 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
2907 finish_record_type (gnu_type, fields, 0, 1);
2909 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
2910 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
2911 = concat_id_with_name (get_entity_name (gnat_desig_type),
2913 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
2917 /* If we already know what the full type is, use it. */
2918 else if (Present (gnat_desig_full)
2919 && present_gnu_tree (gnat_desig_full))
2920 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
2922 /* Get the type of the thing we are to point to and build a pointer
2923 to it. If it is a reference to an incomplete or private type with a
2924 full view that is a record, make a dummy type node and get the
2925 actual type later when we have verified it is safe. */
2926 else if (! in_main_unit
2927 && ! present_gnu_tree (gnat_desig_type)
2928 && Present (gnat_desig_full)
2929 && ! present_gnu_tree (gnat_desig_full)
2930 && Is_Record_Type (gnat_desig_full))
2932 gnu_desig_type = make_dummy_type (gnat_desig_type);
2936 /* Likewise if we are pointing to a record or array and we are to defer
2937 elaborating incomplete types. We do this since this access type
2938 may be the full view of some private type. Note that the
2939 unconstrained array case is handled above. */
2940 else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0
2941 && ! present_gnu_tree (gnat_desig_type)
2942 && ((Is_Record_Type (gnat_desig_type)
2943 || Is_Array_Type (gnat_desig_type))
2944 || (Present (gnat_desig_full)
2945 && (Is_Record_Type (gnat_desig_full)
2946 || Is_Array_Type (gnat_desig_full)))))
2948 gnu_desig_type = make_dummy_type (gnat_desig_type);
2951 else if (gnat_desig_type == gnat_entity)
2953 gnu_type = build_pointer_type (make_node (VOID_TYPE));
2954 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
2957 gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
2959 /* It is possible that the above call to gnat_to_gnu_type resolved our
2960 type. If so, just return it. */
2961 if (present_gnu_tree (gnat_entity))
2967 /* If we have a GCC type for the designated type, possibly modify it
2968 if we are pointing only to constant objects and then make a pointer
2969 to it. Don't do this for unconstrained arrays. */
2970 if (gnu_type == 0 && gnu_desig_type != 0)
2972 if (Is_Access_Constant (gnat_entity)
2973 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
2976 = build_qualified_type
2978 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
2980 /* Some extra processing is required if we are building a
2981 pointer to an incomplete type (in the GCC sense). We might
2982 have such a type if we just made a dummy, or directly out
2983 of the call to gnat_to_gnu_type above if we are processing
2984 an access type for a record component designating the
2985 record type itself. */
2986 if (! COMPLETE_TYPE_P (gnu_desig_type))
2988 /* We must ensure that the pointer to variant we make will
2989 be processed by update_pointer_to when the initial type
2990 is completed. Pretend we made a dummy and let further
2991 processing act as usual. */
2994 /* We must ensure that update_pointer_to will not retrieve
2995 the dummy variant when building a properly qualified
2996 version of the complete type. We take advantage of the
2997 fact that get_qualified_type is requiring TYPE_NAMEs to
2998 match to influence build_qualified_type and then also
2999 update_pointer_to here. */
3000 TYPE_NAME (gnu_desig_type)
3001 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3005 gnu_type = build_pointer_type (gnu_desig_type);
3008 /* If we are not defining this object and we made a dummy pointer,
3009 save our current definition, evaluate the actual type, and replace
3010 the tentative type we made with the actual one. If we are to defer
3011 actually looking up the actual type, make an entry in the
3014 if (! in_main_unit && made_dummy)
3017 = TYPE_FAT_POINTER_P (gnu_type)
3018 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3020 if (esize == POINTER_SIZE
3021 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3023 = build_pointer_type
3024 (TYPE_OBJECT_RECORD_TYPE
3025 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3027 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3028 ! Comes_From_Source (gnat_entity),
3030 save_gnu_tree (gnat_entity, gnu_decl, 0);
3031 this_made_decl = saved = 1;
3033 if (defer_incomplete_level == 0)
3035 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3036 gnat_to_gnu_type (gnat_desig_type));
3037 /* Note that the call to gnat_to_gnu_type here might have
3038 updated gnu_old_type directly, in which case it is not a
3039 dummy type any more when we get into update_pointer_to.
3041 This may happen for instance when the designated type is a
3042 record type, because their elaboration starts with an
3043 initial node from make_dummy_type, which may yield the same
3044 node as the one we got.
3046 Besides, variants of this non-dummy type might have been
3047 created along the way. update_pointer_to is expected to
3048 properly take care of those situations. */
3052 struct incomplete *p
3053 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3055 p->old_type = gnu_old_type;
3056 p->full_type = gnat_desig_type;
3057 p->next = defer_incomplete_list;
3058 defer_incomplete_list = p;
3064 case E_Access_Protected_Subprogram_Type:
3065 if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
3066 gnu_type = build_pointer_type (void_type_node);
3068 /* The runtime representation is the equivalent type. */
3069 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3071 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3072 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3073 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3074 && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3075 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3080 case E_Access_Subtype:
3082 /* We treat this as identical to its base type; any constraint is
3083 meaningful only to the front end.
3085 The designated type must be elaborated as well, if it does
3086 not have its own freeze node. Designated (sub)types created
3087 for constrained components of records with discriminants are
3088 not frozen by the front end and thus not elaborated by gigi,
3089 because their use may appear before the base type is frozen,
3090 and because it is not clear that they are needed anywhere in
3091 Gigi. With the current model, there is no correct place where
3092 they could be elaborated. */
3094 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3095 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3096 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3097 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3098 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3100 /* If we are not defining this entity, and we have incomplete
3101 entities being processed above us, make a dummy type and
3102 elaborate it later. */
3103 if (! definition && defer_incomplete_level != 0)
3105 struct incomplete *p
3106 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3108 = build_pointer_type
3109 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3111 p->old_type = TREE_TYPE (gnu_ptr_type);
3112 p->full_type = Directly_Designated_Type (gnat_entity);
3113 p->next = defer_incomplete_list;
3114 defer_incomplete_list = p;
3117 (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))),
3118 Incomplete_Or_Private_Kind))
3121 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3128 /* Subprogram Entities
3130 The following access functions are defined for subprograms (functions
3133 First_Formal The first formal parameter.
3134 Is_Imported Indicates that the subprogram has appeared in
3135 an INTERFACE or IMPORT pragma. For now we
3136 assume that the external language is C.
3137 Is_Inlined True if the subprogram is to be inlined.
3139 In addition for function subprograms we have:
3141 Etype Return type of the function.
3143 Each parameter is first checked by calling must_pass_by_ref on its
3144 type to determine if it is passed by reference. For parameters which
3145 are copied in, if they are Ada IN OUT or OUT parameters, their return
3146 value becomes part of a record which becomes the return type of the
3147 function (C function - note that this applies only to Ada procedures
3148 so there is no Ada return type). Additional code to store back the
3149 parameters will be generated on the caller side. This transformation
3150 is done here, not in the front-end.
3152 The intended result of the transformation can be seen from the
3153 equivalent source rewritings that follow:
3155 struct temp {int a,b};
3156 procedure P (A,B: IN OUT ...) is temp P (int A,B) {
3158 end P; return {A,B};
3168 For subprogram types we need to perform mainly the same conversions to
3169 GCC form that are needed for procedures and function declarations. The
3170 only difference is that at the end, we make a type declaration instead
3171 of a function declaration. */
3173 case E_Subprogram_Type:
3177 /* The first GCC parameter declaration (a PARM_DECL node). The
3178 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3179 actually is the head of this parameter list. */
3180 tree gnu_param_list = NULL_TREE;
3181 /* The type returned by a function. If the subprogram is a procedure
3182 this type should be void_type_node. */
3183 tree gnu_return_type = void_type_node;
3184 /* List of fields in return type of procedure with copy in copy out
3186 tree gnu_field_list = NULL_TREE;
3187 /* Non-null for subprograms containing parameters passed by copy in
3188 copy out (Ada IN OUT or OUT parameters not passed by reference),
3189 in which case it is the list of nodes used to specify the values of
3190 the in out/out parameters that are returned as a record upon
3191 procedure return. The TREE_PURPOSE of an element of this list is
3192 a field of the record and the TREE_VALUE is the PARM_DECL
3193 corresponding to that field. This list will be saved in the
3194 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3195 tree gnu_return_list = NULL_TREE;
3196 Entity_Id gnat_param;
3197 int inline_flag = Is_Inlined (gnat_entity);
3198 int public_flag = Is_Public (gnat_entity);
3200 = (Is_Public (gnat_entity) && !definition) || imported_p;
3201 int pure_flag = Is_Pure (gnat_entity);
3202 int volatile_flag = No_Return (gnat_entity);
3203 int returns_by_ref = 0;
3204 int returns_unconstrained = 0;
3205 tree gnu_ext_name = create_concat_name (gnat_entity, 0);
3206 int has_copy_in_out = 0;
3209 if (kind == E_Subprogram_Type && ! definition)
3210 /* A parameter may refer to this type, so defer completion
3211 of any incomplete types. */
3212 defer_incomplete_level++, this_deferred = 1;
3214 /* If the subprogram has an alias, it is probably inherited, so
3215 we can use the original one. If the original "subprogram"
3216 is actually an enumeration literal, it may be the first use
3217 of its type, so we must elaborate that type now. */
3218 if (Present (Alias (gnat_entity)))
3220 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3221 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3223 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3226 /* Elaborate any Itypes in the parameters of this entity. */
3227 for (gnat_temp = First_Formal (gnat_entity);
3228 Present (gnat_temp);
3229 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3230 if (Is_Itype (Etype (gnat_temp)))
3231 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3236 if (kind == E_Function || kind == E_Subprogram_Type)
3237 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3239 /* If this function returns by reference, make the actual
3240 return type of this function the pointer and mark the decl. */
3241 if (Returns_By_Ref (gnat_entity))
3244 gnu_return_type = build_pointer_type (gnu_return_type);
3247 /* If the Mechanism is By_Reference, ensure the return type uses
3248 the machine's by-reference mechanism, which may not the same
3249 as above (e.g., it might be by passing a fake parameter). */
3250 else if (kind == E_Function
3251 && Mechanism (gnat_entity) == By_Reference)
3253 gnu_return_type = copy_type (gnu_return_type);
3254 TREE_ADDRESSABLE (gnu_return_type) = 1;
3257 /* If we are supposed to return an unconstrained array,
3258 actually return a fat pointer and make a note of that. Return
3259 a pointer to an unconstrained record of variable size. */
3260 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3262 gnu_return_type = TREE_TYPE (gnu_return_type);
3263 returns_unconstrained = 1;
3266 /* If the type requires a transient scope, the result is allocated
3267 on the secondary stack, so the result type of the function is
3269 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3271 gnu_return_type = build_pointer_type (gnu_return_type);
3272 returns_unconstrained = 1;
3275 /* If the type is a padded type and the underlying type would not
3276 be passed by reference or this function has a foreign convention,
3277 return the underlying type. */
3278 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3279 && TYPE_IS_PADDING_P (gnu_return_type)
3280 && (! default_pass_by_ref (TREE_TYPE
3281 (TYPE_FIELDS (gnu_return_type)))
3282 || Has_Foreign_Convention (gnat_entity)))
3283 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3285 /* Look at all our parameters and get the type of
3286 each. While doing this, build a copy-out structure if
3289 /* If the return type has a size that overflows, we cannot have
3290 a function that returns that type. This usage doesn't make
3291 sense anyway, so give an error here. */
3292 if (TYPE_SIZE_UNIT (gnu_return_type)
3293 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3295 post_error ("cannot return type whose size overflows",
3297 gnu_return_type = copy_node (gnu_return_type);
3298 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3299 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3300 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3301 TYPE_NEXT_VARIANT (gnu_return_type) = 0;
3304 for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
3305 Present (gnat_param);
3306 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3308 tree gnu_param_name = get_entity_name (gnat_param);
3309 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3310 tree gnu_param, gnu_field;
3313 int by_component_ptr_p = 0;
3314 int copy_in_copy_out_flag = 0;
3315 int req_by_copy = 0, req_by_ref = 0;
3317 /* See if a Mechanism was supplied that forced this
3318 parameter to be passed one way or another. */
3319 if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3321 else if (Mechanism (gnat_param) == Default)
3323 else if (Mechanism (gnat_param) == By_Copy)
3325 else if (Mechanism (gnat_param) == By_Reference)
3327 else if (Mechanism (gnat_param) <= By_Descriptor)
3329 else if (Mechanism (gnat_param) > 0)
3331 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3332 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3333 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3334 Mechanism (gnat_param)))
3340 post_error ("unsupported mechanism for&", gnat_param);
3342 /* If this is either a foreign function or if the
3343 underlying type won't be passed by refererence, strip off
3344 possible padding type. */
3345 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
3346 && TYPE_IS_PADDING_P (gnu_param_type)
3347 && (req_by_ref || Has_Foreign_Convention (gnat_entity)
3348 || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
3349 (gnu_param_type)))))
3350 gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
3352 /* If this is an IN parameter it is read-only, so make a variant
3353 of the type that is read-only.
3355 ??? However, if this is an unconstrained array, that type can
3356 be very complex. So skip it for now. Likewise for any other
3357 self-referential type. */
3358 if (Ekind (gnat_param) == E_In_Parameter
3359 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
3360 && ! (TYPE_SIZE (gnu_param_type) != 0
3361 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))))
3363 = build_qualified_type (gnu_param_type,
3364 (TYPE_QUALS (gnu_param_type)
3365 | TYPE_QUAL_CONST));
3367 /* For foreign conventions, pass arrays as a pointer to the
3368 underlying type. First check for unconstrained array and get
3369 the underlying array. Then get the component type and build
3371 if (Has_Foreign_Convention (gnat_entity)
3372 && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
3374 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3375 (TREE_TYPE (gnu_param_type))));
3379 = build_pointer_type
3380 (build_vms_descriptor (gnu_param_type,
3381 Mechanism (gnat_param),
3384 else if (Has_Foreign_Convention (gnat_entity)
3386 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
3388 /* Strip off any multi-dimensional entries, then strip
3389 off the last array to get the component type. */
3390 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
3391 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
3392 gnu_param_type = TREE_TYPE (gnu_param_type);
3394 by_component_ptr_p = 1;
3395 gnu_param_type = TREE_TYPE (gnu_param_type);
3397 if (Ekind (gnat_param) == E_In_Parameter)
3399 = build_qualified_type (gnu_param_type,
3400 (TYPE_QUALS (gnu_param_type)
3401 | TYPE_QUAL_CONST));
3403 gnu_param_type = build_pointer_type (gnu_param_type);
3406 /* Fat pointers are passed as thin pointers for foreign
3408 else if (Has_Foreign_Convention (gnat_entity)
3409 && TYPE_FAT_POINTER_P (gnu_param_type))
3411 = make_type_from_size (gnu_param_type,
3412 size_int (POINTER_SIZE), 0);
3414 /* If we must pass or were requested to pass by reference, do so.
3415 If we were requested to pass by copy, do so.
3416 Otherwise, for foreign conventions, pass all in out parameters
3417 or aggregates by reference. For COBOL and Fortran, pass
3418 all integer and FP types that way too. For Convention Ada,
3419 use the standard Ada default. */
3420 else if (must_pass_by_ref (gnu_param_type) || req_by_ref
3422 && ((Has_Foreign_Convention (gnat_entity)
3423 && (Ekind (gnat_param) != E_In_Parameter
3424 || AGGREGATE_TYPE_P (gnu_param_type)))
3425 || (((Convention (gnat_entity)
3426 == Convention_Fortran)
3427 || (Convention (gnat_entity)
3428 == Convention_COBOL))
3429 && (INTEGRAL_TYPE_P (gnu_param_type)
3430 || FLOAT_TYPE_P (gnu_param_type)))
3431 /* For convention Ada, see if we pass by reference
3433 || (! Has_Foreign_Convention (gnat_entity)
3434 && default_pass_by_ref (gnu_param_type)))))
3436 gnu_param_type = build_reference_type (gnu_param_type);
3440 else if (Ekind (gnat_param) != E_In_Parameter)
3441 copy_in_copy_out_flag = 1;
3443 if (req_by_copy && (by_ref_p || by_component_ptr_p))
3444 post_error ("?cannot pass & by copy", gnat_param);
3446 /* If this is an OUT parameter that isn't passed by reference
3447 and isn't a pointer or aggregate, we don't make a PARM_DECL
3448 for it. Instead, it will be a VAR_DECL created when we process
3449 the procedure. For the special parameter of Valued_Procedure,
3452 An exception is made to cover the RM-6.4.1 rule requiring "by
3453 copy" out parameters with discriminants or implicit initial
3454 values to be handled like in out parameters. These type are
3455 normally built as aggregates, and hence passed by reference,
3456 except for some packed arrays which end up encoded in special
3459 The exception we need to make is then for packed arrays of
3460 records with discriminants or implicit initial values. We have
3461 no light/easy way to check for the latter case, so we merely
3462 check for packed arrays of records. This may lead to useless
3463 copy-in operations, but in very rare cases only, as these would
3464 be exceptions in a set of already exceptional situations. */
3465 if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p
3466 && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3468 && ! POINTER_TYPE_P (gnu_param_type)
3469 && ! AGGREGATE_TYPE_P (gnu_param_type)))
3470 && ! (Is_Array_Type (Etype (gnat_param))
3471 && Is_Packed (Etype (gnat_param))
3472 && Is_Composite_Type (Component_Type
3473 (Etype (gnat_param)))))
3477 set_lineno (gnat_param, 0);
3480 (gnu_param_name, gnu_param_type,
3481 by_ref_p || by_component_ptr_p
3482 || Ekind (gnat_param) == E_In_Parameter);
3484 DECL_BY_REF_P (gnu_param) = by_ref_p;
3485 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p;
3486 DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p;
3487 DECL_POINTS_TO_READONLY_P (gnu_param)
3488 = (Ekind (gnat_param) == E_In_Parameter
3489 && (by_ref_p || by_component_ptr_p));
3490 save_gnu_tree (gnat_param, gnu_param, 0);
3491 gnu_param_list = chainon (gnu_param, gnu_param_list);
3493 /* If a parameter is a pointer, this function may modify
3494 memory through it and thus shouldn't be considered
3495 a pure function. Also, the memory may be modified
3496 between two calls, so they can't be CSE'ed. The latter
3497 case also handles by-ref parameters. */
3498 if (POINTER_TYPE_P (gnu_param_type)
3499 || TYPE_FAT_POINTER_P (gnu_param_type))
3503 if (copy_in_copy_out_flag)
3505 if (! has_copy_in_out)
3507 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
3510 gnu_return_type = make_node (RECORD_TYPE);
3511 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3512 has_copy_in_out = 1;
3515 set_lineno (gnat_param, 0);
3516 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3517 gnu_return_type, 0, 0, 0, 0);
3518 TREE_CHAIN (gnu_field) = gnu_field_list;
3519 gnu_field_list = gnu_field;
3520 gnu_return_list = tree_cons (gnu_field, gnu_param,
3525 /* Do not compute record for out parameters if subprogram is
3526 stubbed since structures are incomplete for the back-end. */
3527 if (gnu_field_list != 0
3528 && Convention (gnat_entity) != Convention_Stubbed)
3529 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3532 /* If we have a CICO list but it has only one entry, we convert
3533 this function into a function that simply returns that one
3535 if (list_length (gnu_return_list) == 1)
3536 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3539 if (Convention (gnat_entity) == Convention_Stdcall)
3542 = (struct attrib *) xmalloc (sizeof (struct attrib));
3544 attr->next = attr_list;
3545 attr->type = ATTR_MACHINE_ATTRIBUTE;
3546 attr->name = get_identifier ("stdcall");
3547 attr->arg = NULL_TREE;
3548 attr->error_point = gnat_entity;
3553 /* Both lists ware built in reverse. */
3554 gnu_param_list = nreverse (gnu_param_list);
3555 gnu_return_list = nreverse (gnu_return_list);
3558 = create_subprog_type (gnu_return_type, gnu_param_list,
3559 gnu_return_list, returns_unconstrained,
3561 Function_Returns_With_DSP (gnat_entity));
3563 /* ??? For now, don't consider nested functions pure. */
3564 if (! global_bindings_p ())
3567 /* A subprogram (something that doesn't return anything) shouldn't
3568 be considered Pure since there would be no reason for such a
3569 subprogram. Note that procedures with Out (or In Out) parameters
3570 have already been converted into a function with a return type. */
3571 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
3575 = build_qualified_type (gnu_type,
3576 (TYPE_QUALS (gnu_type)
3577 | (TYPE_QUAL_CONST * pure_flag)
3578 | (TYPE_QUAL_VOLATILE * volatile_flag)));
3580 set_lineno (gnat_entity, 0);
3582 /* If there was no specified Interface_Name and the external and
3583 internal names of the subprogram are the same, only use the
3584 internal name to allow disambiguation of nested subprograms. */
3585 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
3588 /* If we are defining the subprogram and it has an Address clause
3589 we must get the address expression from the saved GCC tree for the
3590 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3591 the address expression here since the front-end has guaranteed
3592 in that case that the elaboration has no effects. If there is
3593 an Address clause and we are not defining the object, just
3594 make it a constant. */
3595 if (Present (Address_Clause (gnat_entity)))
3597 tree gnu_address = 0;
3601 = (present_gnu_tree (gnat_entity)
3602 ? get_gnu_tree (gnat_entity)
3603 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
3605 save_gnu_tree (gnat_entity, NULL_TREE, 0);
3607 gnu_type = build_reference_type (gnu_type);
3608 if (gnu_address != 0)
3609 gnu_address = convert (gnu_type, gnu_address);
3612 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
3613 gnu_address, 0, Is_Public (gnat_entity),
3615 DECL_BY_REF_P (gnu_decl) = 1;
3618 else if (kind == E_Subprogram_Type)
3619 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3620 ! Comes_From_Source (gnat_entity),
3624 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
3625 gnu_type, gnu_param_list,
3626 inline_flag, public_flag,
3627 extern_flag, attr_list);
3628 DECL_STUBBED_P (gnu_decl)
3629 = Convention (gnat_entity) == Convention_Stubbed;
3634 case E_Incomplete_Type:
3635 case E_Private_Type:
3636 case E_Limited_Private_Type:
3637 case E_Record_Type_With_Private:
3638 case E_Private_Subtype:
3639 case E_Limited_Private_Subtype:
3640 case E_Record_Subtype_With_Private:
3642 /* If this type does not have a full view in the unit we are
3643 compiling, then just get the type from its Etype. */
3644 if (No (Full_View (gnat_entity)))
3646 /* If this is an incomplete type with no full view, it must
3647 be a Taft Amendement type, so just return a dummy type. */
3648 if (kind == E_Incomplete_Type)
3649 gnu_type = make_dummy_type (gnat_entity);
3651 else if (Present (Underlying_Full_View (gnat_entity)))
3652 gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
3656 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
3664 /* Otherwise, if we are not defining the type now, get the
3665 type from the full view. But always get the type from the full
3666 view for define on use types, since otherwise we won't see them! */
3668 else if (! definition
3669 || (Is_Itype (Full_View (gnat_entity))
3670 && No (Freeze_Node (gnat_entity)))
3671 || (Is_Itype (gnat_entity)
3672 && No (Freeze_Node (Full_View (gnat_entity)))))
3674 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
3680 /* For incomplete types, make a dummy type entry which will be
3682 gnu_type = make_dummy_type (gnat_entity);
3684 /* Save this type as the full declaration's type so we can do any needed
3685 updates when we see it. */
3686 set_lineno (gnat_entity, 0);
3687 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3688 ! Comes_From_Source (gnat_entity),
3690 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
3693 /* Simple class_wide types are always viewed as their root_type
3694 by Gigi unless an Equivalent_Type is specified. */
3695 case E_Class_Wide_Type:
3696 if (Present (Equivalent_Type (gnat_entity)))
3697 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3699 gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity));
3705 case E_Task_Subtype:
3706 case E_Protected_Type:
3707 case E_Protected_Subtype:
3708 if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity)))
3709 gnu_type = void_type_node;
3711 gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity));
3717 gnu_decl = create_label_decl (gnu_entity_id);
3722 /* Nothing at all to do here, so just return an ERROR_MARK and claim
3723 we've already saved it, so we don't try to. */
3724 gnu_decl = error_mark_node;
3732 /* If we had a case where we evaluated another type and it might have
3733 defined this one, handle it here. */
3734 if (maybe_present && present_gnu_tree (gnat_entity))
3736 gnu_decl = get_gnu_tree (gnat_entity);
3740 /* If we are processing a type and there is either no decl for it or
3741 we just made one, do some common processing for the type, such as
3742 handling alignment and possible padding. */
3744 if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind))
3746 if (Is_Tagged_Type (gnat_entity)
3747 || Is_Class_Wide_Equivalent_Type (gnat_entity))
3748 TYPE_ALIGN_OK (gnu_type) = 1;
3750 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
3751 TYPE_BY_REFERENCE_P (gnu_type) = 1;
3753 /* ??? Don't set the size for a String_Literal since it is either
3754 confirming or we don't handle it properly (if the low bound is
3756 if (gnu_size == 0 && kind != E_String_Literal_Subtype)
3757 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
3758 TYPE_DECL, 0, Has_Size_Clause (gnat_entity));
3760 /* If a size was specified, see if we can make a new type of that size
3761 by rearranging the type, for example from a fat to a thin pointer. */
3765 = make_type_from_size (gnu_type, gnu_size,
3766 Has_Biased_Representation (gnat_entity));
3768 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
3769 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
3773 /* If the alignment hasn't already been processed and this is
3774 not an unconstrained array, see if an alignment is specified.
3775 If not, we pick a default alignment for atomic objects. */
3776 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3778 else if (Known_Alignment (gnat_entity))
3779 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
3780 TYPE_ALIGN (gnu_type));
3781 else if (Is_Atomic (gnat_entity) && gnu_size == 0
3782 && host_integerp (TYPE_SIZE (gnu_type), 1)
3783 && integer_pow2p (TYPE_SIZE (gnu_type)))
3784 align = MIN (BIGGEST_ALIGNMENT,
3785 tree_low_cst (TYPE_SIZE (gnu_type), 1));
3786 else if (Is_Atomic (gnat_entity) && gnu_size != 0
3787 && host_integerp (gnu_size, 1)
3788 && integer_pow2p (gnu_size))
3789 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
3791 /* See if we need to pad the type. If we did, and made a record,
3792 the name of the new type may be changed. So get it back for
3793 us when we make the new TYPE_DECL below. */
3794 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
3795 gnat_entity, "PAD", 1, definition, 0);
3796 if (TREE_CODE (gnu_type) == RECORD_TYPE
3797 && TYPE_IS_PADDING_P (gnu_type))
3799 gnu_entity_id = TYPE_NAME (gnu_type);
3800 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
3801 gnu_entity_id = DECL_NAME (gnu_entity_id);
3804 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
3806 /* If we are at global level, GCC will have applied variable_size to
3807 the type, but that won't have done anything. So, if it's not
3808 a constant or self-referential, call elaborate_expression_1 to
3809 make a variable for the size rather than calculating it each time.
3810 Handle both the RM size and the actual size. */
3811 if (global_bindings_p ()
3812 && TYPE_SIZE (gnu_type) != 0
3813 && ! TREE_CONSTANT (TYPE_SIZE (gnu_type))
3814 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
3816 if (TREE_CODE (gnu_type) == RECORD_TYPE
3817 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
3818 TYPE_SIZE (gnu_type), 0))
3820 TYPE_SIZE (gnu_type)
3821 = elaborate_expression_1 (gnat_entity, gnat_entity,
3822 TYPE_SIZE (gnu_type),
3823 get_identifier ("SIZE"),
3825 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
3829 TYPE_SIZE (gnu_type)
3830 = elaborate_expression_1 (gnat_entity, gnat_entity,
3831 TYPE_SIZE (gnu_type),
3832 get_identifier ("SIZE"),
3835 /* ??? For now, store the size as a multiple of the alignment
3836 in bytes so that we can see the alignment from the tree. */
3837 TYPE_SIZE_UNIT (gnu_type)
3839 (MULT_EXPR, sizetype,
3840 elaborate_expression_1
3841 (gnat_entity, gnat_entity,
3842 build_binary_op (EXACT_DIV_EXPR, sizetype,
3843 TYPE_SIZE_UNIT (gnu_type),
3844 size_int (TYPE_ALIGN (gnu_type)
3846 get_identifier ("SIZE_A_UNIT"),
3848 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3850 if (TREE_CODE (gnu_type) == RECORD_TYPE)
3851 SET_TYPE_ADA_SIZE (gnu_type,
3852 elaborate_expression_1 (gnat_entity, gnat_entity,
3853 TYPE_ADA_SIZE (gnu_type),
3854 get_identifier ("RM_SIZE"),
3859 /* If this is a record type or subtype, call elaborate_expression_1 on
3860 any field position. Do this for both global and local types.
3861 Skip any fields that we haven't made trees for to avoid problems with
3862 class wide types. */
3863 if (IN (kind, Record_Kind))
3864 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3865 gnat_temp = Next_Entity (gnat_temp))
3866 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
3868 tree gnu_field = get_gnu_tree (gnat_temp);
3870 /* ??? Unfortunately, GCC needs to be able to prove the
3871 alignment of this offset and if it's a variable, it can't.
3872 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
3873 right now, we have to put in an explicit multiply and
3874 divide by that value. */
3875 if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
3876 DECL_FIELD_OFFSET (gnu_field)
3878 (MULT_EXPR, sizetype,
3879 elaborate_expression_1
3880 (gnat_temp, gnat_temp,
3881 build_binary_op (EXACT_DIV_EXPR, sizetype,
3882 DECL_FIELD_OFFSET (gnu_field),
3883 size_int (DECL_OFFSET_ALIGN (gnu_field)
3885 get_identifier ("OFFSET"),
3887 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
3890 gnu_type = build_qualified_type (gnu_type,
3891 (TYPE_QUALS (gnu_type)
3892 | (TYPE_QUAL_VOLATILE
3893 * Treat_As_Volatile (gnat_entity))));
3895 if (Is_Atomic (gnat_entity))
3896 check_ok_for_atomic (gnu_type, gnat_entity, 0);
3898 if (Known_Alignment (gnat_entity))
3899 TYPE_USER_ALIGN (gnu_type) = 1;
3903 set_lineno (gnat_entity, 0);
3904 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3905 ! Comes_From_Source (gnat_entity),
3909 TREE_TYPE (gnu_decl) = gnu_type;
3912 if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
3914 gnu_type = TREE_TYPE (gnu_decl);
3916 /* Back-annotate the Alignment of the type if not already in the
3917 tree. Likewise for sizes. */
3918 if (Unknown_Alignment (gnat_entity))
3919 Set_Alignment (gnat_entity,
3920 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3922 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0)
3924 /* If the size is self-referential, we annotate the maximum
3925 value of that size. */
3926 tree gnu_size = TYPE_SIZE (gnu_type);
3928 if (CONTAINS_PLACEHOLDER_P (gnu_size))
3929 gnu_size = max_size (gnu_size, 1);
3931 Set_Esize (gnat_entity, annotate_value (gnu_size));
3933 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
3935 /* In this mode the tag and the parent components are not
3936 generated by the front-end, so the sizes must be adjusted
3942 if (Is_Derived_Type (gnat_entity))
3945 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
3946 Set_Alignment (gnat_entity,
3947 Alignment (Etype (Base_Type (gnat_entity))));
3950 size_offset = POINTER_SIZE;
3952 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
3953 Set_Esize (gnat_entity,
3954 UI_From_Int (((new_size + (POINTER_SIZE - 1))
3955 / POINTER_SIZE) * POINTER_SIZE));
3956 Set_RM_Size (gnat_entity, Esize (gnat_entity));
3960 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0)
3961 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
3964 if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
3965 DECL_ARTIFICIAL (gnu_decl) = 1;
3967 if (! debug_info_p && DECL_P (gnu_decl)
3968 && TREE_CODE (gnu_decl) != FUNCTION_DECL)
3969 DECL_IGNORED_P (gnu_decl) = 1;
3971 /* If this decl is really indirect, adjust it. */
3972 if (TREE_CODE (gnu_decl) == VAR_DECL)
3973 adjust_decl_rtl (gnu_decl);
3975 /* If we haven't already, associate the ..._DECL node that we just made with
3976 the input GNAT entity node. */
3978 save_gnu_tree (gnat_entity, gnu_decl, 0);
3980 /* If this is an enumeral or floating-point type, we were not able to set
3981 the bounds since they refer to the type. These bounds are always static.
3983 For enumeration types, also write debugging information and declare the
3984 enumeration literal table, if needed. */
3986 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
3987 || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity)))
3989 tree gnu_scalar_type = gnu_type;
3991 /* If this is a padded type, we need to use the underlying type. */
3992 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
3993 && TYPE_IS_PADDING_P (gnu_scalar_type))
3994 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
3996 /* If this is a floating point type and we haven't set a floating
3997 point type yet, use this in the evaluation of the bounds. */
3998 if (longest_float_type_node == 0 && kind == E_Floating_Point_Type)
3999 longest_float_type_node = gnu_type;
4001 TYPE_MIN_VALUE (gnu_scalar_type)
4002 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4003 TYPE_MAX_VALUE (gnu_scalar_type)
4004 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4006 if (kind == E_Enumeration_Type)
4008 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
4010 /* Since this has both a typedef and a tag, avoid outputting
4012 DECL_ARTIFICIAL (gnu_decl) = 1;
4013 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
4017 /* If we deferred processing of incomplete types, re-enable it. If there
4018 were no other disables and we have some to process, do so. */
4019 if (this_deferred && --defer_incomplete_level == 0
4020 && defer_incomplete_list != 0)
4022 struct incomplete *incp = defer_incomplete_list;
4023 struct incomplete *next;
4025 defer_incomplete_list = 0;
4026 for (; incp; incp = next)
4030 if (incp->old_type != 0)
4031 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4032 gnat_to_gnu_type (incp->full_type));
4037 /* If we are not defining this type, see if it's in the incomplete list.
4038 If so, handle that list entry now. */
4039 else if (! definition)
4041 struct incomplete *incp;
4043 for (incp = defer_incomplete_list; incp; incp = incp->next)
4044 if (incp->old_type != 0 && incp->full_type == gnat_entity)
4046 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4047 TREE_TYPE (gnu_decl));
4055 if (Is_Packed_Array_Type (gnat_entity)
4056 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4057 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4058 && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4059 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4064 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4065 be elaborated at the point of its definition, but do nothing else. */
4068 elaborate_entity (Entity_Id gnat_entity)
4070 switch (Ekind (gnat_entity))
4072 case E_Signed_Integer_Subtype:
4073 case E_Modular_Integer_Subtype:
4074 case E_Enumeration_Subtype:
4075 case E_Ordinary_Fixed_Point_Subtype:
4076 case E_Decimal_Fixed_Point_Subtype:
4077 case E_Floating_Point_Subtype:
4079 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4080 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4082 /* ??? Tests for avoiding static constaint error expression
4083 is needed until the front stops generating bogus conversions
4084 on bounds of real types. */
4086 if (! Raises_Constraint_Error (gnat_lb))
4087 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4088 1, 0, Needs_Debug_Info (gnat_entity));
4089 if (! Raises_Constraint_Error (gnat_hb))
4090 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4091 1, 0, Needs_Debug_Info (gnat_entity));
4097 Node_Id full_definition = Declaration_Node (gnat_entity);
4098 Node_Id record_definition = Type_Definition (full_definition);
4100 /* If this is a record extension, go a level further to find the
4101 record definition. */
4102 if (Nkind (record_definition) == N_Derived_Type_Definition)
4103 record_definition = Record_Extension_Part (record_definition);
4107 case E_Record_Subtype:
4108 case E_Private_Subtype:
4109 case E_Limited_Private_Subtype:
4110 case E_Record_Subtype_With_Private:
4111 if (Is_Constrained (gnat_entity)
4112 && Has_Discriminants (Base_Type (gnat_entity))
4113 && Present (Discriminant_Constraint (gnat_entity)))
4115 Node_Id gnat_discriminant_expr;
4116 Entity_Id gnat_field;
4118 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
4119 gnat_discriminant_expr
4120 = First_Elmt (Discriminant_Constraint (gnat_entity));
4121 Present (gnat_field);
4122 gnat_field = Next_Discriminant (gnat_field),
4123 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
4124 /* ??? For now, ignore access discriminants. */
4125 if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
4126 elaborate_expression (Node (gnat_discriminant_expr),
4128 get_entity_name (gnat_field), 1, 0, 0);
4135 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4136 any entities on its entity chain similarly. */
4139 mark_out_of_scope (Entity_Id gnat_entity)
4141 Entity_Id gnat_sub_entity;
4142 unsigned int kind = Ekind (gnat_entity);
4144 /* If this has an entity list, process all in the list. */
4145 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
4146 || IN (kind, Private_Kind)
4147 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
4148 || kind == E_Function || kind == E_Generic_Function
4149 || kind == E_Generic_Package || kind == E_Generic_Procedure
4150 || kind == E_Loop || kind == E_Operator || kind == E_Package
4151 || kind == E_Package_Body || kind == E_Procedure
4152 || kind == E_Record_Type || kind == E_Record_Subtype
4153 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
4154 for (gnat_sub_entity = First_Entity (gnat_entity);
4155 Present (gnat_sub_entity);
4156 gnat_sub_entity = Next_Entity (gnat_sub_entity))
4157 if (Scope (gnat_sub_entity) == gnat_entity
4158 && gnat_sub_entity != gnat_entity)
4159 mark_out_of_scope (gnat_sub_entity);
4161 /* Now clear this if it has been defined, but only do so if it isn't
4162 a subprogram or parameter. We could refine this, but it isn't
4163 worth it. If this is statically allocated, it is supposed to
4164 hang around out of cope. */
4165 if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity)
4166 && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind))
4168 save_gnu_tree (gnat_entity, NULL_TREE, 1);
4169 save_gnu_tree (gnat_entity, error_mark_node, 1);
4173 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4174 is a multi-dimensional array type, do this recursively. */
4177 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
4179 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
4180 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
4181 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
4183 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4184 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4185 so we need to go down to what does. */
4186 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
4188 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
4190 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
4193 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
4194 record_component_aliases (gnu_new_type);
4197 /* Return a TREE_LIST describing the substitutions needed to reflect
4198 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4199 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4200 of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE
4201 gives the tree for the discriminant and TREE_VALUES is the replacement
4202 value. They are in the form of operands to substitute_in_expr.
4203 DEFINITION is as in gnat_to_gnu_entity. */
4206 substitution_list (Entity_Id gnat_subtype,
4207 Entity_Id gnat_type,
4211 Entity_Id gnat_discrim;
4215 gnat_type = Implementation_Base_Type (gnat_subtype);
4217 if (Has_Discriminants (gnat_type))
4218 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
4219 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
4220 Present (gnat_discrim);
4221 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
4222 gnat_value = Next_Elmt (gnat_value))
4223 /* Ignore access discriminants. */
4224 if (! Is_Access_Type (Etype (Node (gnat_value))))
4225 gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0),
4226 elaborate_expression
4227 (Node (gnat_value), gnat_subtype,
4228 get_entity_name (gnat_discrim), definition,
4235 /* For the following two functions: for each GNAT entity, the GCC
4236 tree node used as a dummy for that entity, if any. */
4238 static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
4240 /* Initialize the above table. */
4243 init_dummy_type (void)
4247 dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
4249 for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
4250 dummy_node_table[gnat_node] = NULL_TREE;
4252 dummy_node_table -= First_Node_Id;
4255 /* Make a dummy type corresponding to GNAT_TYPE. */
4258 make_dummy_type (Entity_Id gnat_type)
4260 Entity_Id gnat_underlying;
4263 /* Find a full type for GNAT_TYPE, taking into account any class wide
4265 if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
4266 gnat_type = Equivalent_Type (gnat_type);
4267 else if (Ekind (gnat_type) == E_Class_Wide_Type)
4268 gnat_type = Root_Type (gnat_type);
4270 for (gnat_underlying = gnat_type;
4271 (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
4272 && Present (Full_View (gnat_underlying)));
4273 gnat_underlying = Full_View (gnat_underlying))
4276 /* If it there already a dummy type, use that one. Else make one. */
4277 if (dummy_node_table[gnat_underlying])
4278 return dummy_node_table[gnat_underlying];
4280 /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
4282 if (Is_Record_Type (gnat_underlying))
4283 gnu_type = make_node (Is_Unchecked_Union (gnat_underlying)
4284 ? UNION_TYPE : RECORD_TYPE);
4286 gnu_type = make_node (ENUMERAL_TYPE);
4288 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
4289 if (AGGREGATE_TYPE_P (gnu_type))
4290 TYPE_STUB_DECL (gnu_type)
4291 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
4293 TYPE_DUMMY_P (gnu_type) = 1;
4294 dummy_node_table[gnat_underlying] = gnu_type;
4299 /* Return 1 if the size represented by GNU_SIZE can be handled by an
4300 allocation. If STATIC_P is non-zero, consider only what can be
4301 done with a static allocation. */
4304 allocatable_size_p (tree gnu_size, int static_p)
4306 HOST_WIDE_INT our_size;
4308 /* If this is not a static allocation, the only case we want to forbid
4309 is an overflowing size. That will be converted into a raise a
4312 return ! (TREE_CODE (gnu_size) == INTEGER_CST
4313 && TREE_CONSTANT_OVERFLOW (gnu_size));
4315 /* Otherwise, we need to deal with both variable sizes and constant
4316 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4317 since assemblers may not like very large sizes. */
4318 if (!host_integerp (gnu_size, 1))
4321 our_size = tree_low_cst (gnu_size, 1);
4322 return (int) our_size == our_size;
4325 /* Return a list of attributes for GNAT_ENTITY, if any. */
4327 static struct attrib *
4328 build_attr_list (Entity_Id gnat_entity)
4330 struct attrib *attr_list = 0;
4333 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
4334 gnat_temp = Next_Rep_Item (gnat_temp))
4335 if (Nkind (gnat_temp) == N_Pragma)
4337 struct attrib *attr;
4338 tree gnu_arg0 = 0, gnu_arg1 = 0;
4339 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
4340 enum attr_type etype;
4342 if (Present (gnat_assoc) && Present (First (gnat_assoc))
4343 && Present (Next (First (gnat_assoc)))
4344 && (Nkind (Expression (Next (First (gnat_assoc))))
4345 == N_String_Literal))
4347 gnu_arg0 = get_identifier (TREE_STRING_POINTER
4350 (First (gnat_assoc))))));
4351 if (Present (Next (Next (First (gnat_assoc))))
4352 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
4353 == N_String_Literal))
4354 gnu_arg1 = get_identifier (TREE_STRING_POINTER
4358 (First (gnat_assoc)))))));
4361 switch (Get_Pragma_Id (Chars (gnat_temp)))
4363 case Pragma_Machine_Attribute:
4364 etype = ATTR_MACHINE_ATTRIBUTE;
4367 case Pragma_Linker_Alias:
4368 etype = ATTR_LINK_ALIAS;
4371 case Pragma_Linker_Section:
4372 etype = ATTR_LINK_SECTION;
4375 case Pragma_Weak_External:
4376 etype = ATTR_WEAK_EXTERNAL;
4383 attr = (struct attrib *) xmalloc (sizeof (struct attrib));
4384 attr->next = attr_list;
4386 attr->name = gnu_arg0;
4387 attr->arg = gnu_arg1;
4389 = Present (Next (First (gnat_assoc)))
4390 ? Expression (Next (First (gnat_assoc))) : gnat_temp;
4397 /* Get the unpadded version of a GNAT type. */
4400 get_unpadded_type (Entity_Id gnat_entity)
4402 tree type = gnat_to_gnu_type (gnat_entity);
4404 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4405 type = TREE_TYPE (TYPE_FIELDS (type));
4410 /* Called when we need to protect a variable object using a save_expr. */
4413 maybe_variable (tree gnu_operand, Node_Id gnat_node)
4415 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
4416 || TREE_CODE (gnu_operand) == SAVE_EXPR
4417 || TREE_CODE (gnu_operand) == NULL_EXPR)
4420 /* If we will be generating code, make sure we are at the proper
4422 if (! global_bindings_p () && ! CONTAINS_PLACEHOLDER_P (gnu_operand))
4423 set_lineno (gnat_node, 1);
4425 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
4426 return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
4427 variable_size (TREE_OPERAND (gnu_operand, 0)));
4429 return variable_size (gnu_operand);
4432 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4433 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4434 return the GCC tree to use for that expression. GNU_NAME is the
4435 qualification to use if an external name is appropriate and DEFINITION is
4436 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4437 we need a result. Otherwise, we are just elaborating this for
4438 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4439 purposes even if it isn't needed for code generation. */
4442 elaborate_expression (Node_Id gnat_expr,
4443 Entity_Id gnat_entity,
4451 /* If we already elaborated this expression (e.g., it was involved
4452 in the definition of a private type), use the old value. */
4453 if (present_gnu_tree (gnat_expr))
4454 return get_gnu_tree (gnat_expr);
4456 /* If we don't need a value and this is static or a discriment, we
4457 don't need to do anything. */
4458 else if (! need_value
4459 && (Is_OK_Static_Expression (gnat_expr)
4460 || (Nkind (gnat_expr) == N_Identifier
4461 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
4464 /* Otherwise, convert this tree to its GCC equivalant. */
4466 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
4467 gnu_name, definition, need_debug);
4469 /* Save the expression in case we try to elaborate this entity again.
4470 Since this is not a DECL, don't check it. If this is a constant,
4471 don't save it since GNAT_EXPR might be used more than once. Also,
4472 don't save if it's a discriminant. */
4473 if (! CONTAINS_PLACEHOLDER_P (gnu_expr))
4474 save_gnu_tree (gnat_expr, gnu_expr, 1);
4476 return need_value ? gnu_expr : error_mark_node;
4479 /* Similar, but take a GNU expression. */
4482 elaborate_expression_1 (Node_Id gnat_expr,
4483 Entity_Id gnat_entity,
4490 /* Strip any conversions to see if the expression is a readonly variable.
4491 ??? This really should remain readonly, but we have to think about
4492 the typing of the tree here. */
4493 tree gnu_inner_expr = remove_conversions (gnu_expr, 1);
4494 int expr_global = Is_Public (gnat_entity) || global_bindings_p ();
4497 /* In most cases, we won't see a naked FIELD_DECL here because a
4498 discriminant reference will have been replaced with a COMPONENT_REF
4499 when the type is being elaborated. However, there are some cases
4500 involving child types where we will. So convert it to a COMPONENT_REF
4501 here. We have to hope it will be at the highest level of the
4502 expression in these cases. */
4503 if (TREE_CODE (gnu_expr) == FIELD_DECL)
4504 gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
4505 build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
4508 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
4509 that is a constant, make a variable that is initialized to contain the
4510 bound when the package containing the definition is elaborated. If
4511 this entity is defined at top level and a bound or discriminant value
4512 isn't a constant or a reference to a discriminant, replace the bound
4513 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
4514 rely here on the fact that an expression cannot contain both the
4515 discriminant and some other variable. */
4517 expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c'
4518 && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL
4519 && TREE_READONLY (gnu_inner_expr))
4520 && ! CONTAINS_PLACEHOLDER_P (gnu_expr));
4522 /* If this is a static expression or contains a discriminant, we don't
4523 need the variable for debugging (and can't elaborate anyway if a
4526 && (Is_OK_Static_Expression (gnat_expr)
4527 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
4530 /* Now create the variable if we need it. */
4531 if (need_debug || (expr_variable && expr_global))
4533 set_lineno (gnat_entity, ! global_bindings_p ());
4535 = create_var_decl (create_concat_name (gnat_entity,
4536 IDENTIFIER_POINTER (gnu_name)),
4537 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
4538 Is_Public (gnat_entity), ! definition, 0, 0);
4541 /* We only need to use this variable if we are in global context since GCC
4542 can do the right thing in the local case. */
4543 if (expr_global && expr_variable)
4545 else if (! expr_variable)
4548 return maybe_variable (gnu_expr, gnat_expr);
4551 /* Create a record type that contains a field of TYPE with a starting bit
4552 position so that it is aligned to ALIGN bits and is SIZE bytes long. */
4555 make_aligning_type (tree type, int align, tree size)
4557 tree record_type = make_node (RECORD_TYPE);
4558 tree place = build (PLACEHOLDER_EXPR, record_type);
4559 tree size_addr_place = convert (sizetype,
4560 build_unary_op (ADDR_EXPR, NULL_TREE,
4562 tree name = TYPE_NAME (type);
4565 if (TREE_CODE (name) == TYPE_DECL)
4566 name = DECL_NAME (name);
4568 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
4570 /* The bit position is obtained by "and"ing the alignment minus 1
4571 with the two's complement of the address and multiplying
4572 by the number of bits per unit. Do all this in sizetype. */
4574 pos = size_binop (MULT_EXPR,
4575 convert (bitsizetype,
4576 size_binop (BIT_AND_EXPR,
4577 size_diffop (size_zero_node,
4579 ssize_int ((align / BITS_PER_UNIT)
4583 field = create_field_decl (get_identifier ("F"), type, record_type,
4585 DECL_BIT_FIELD (field) = 0;
4587 finish_record_type (record_type, field, 1, 0);
4588 TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
4589 TYPE_SIZE (record_type)
4590 = size_binop (PLUS_EXPR,
4591 size_binop (MULT_EXPR, convert (bitsizetype, size),
4593 bitsize_int (align));
4594 TYPE_SIZE_UNIT (record_type)
4595 = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
4596 copy_alias_set (record_type, type);
4600 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
4601 being used as the field type of a packed record. See if we can rewrite it
4602 as a record that has a non-BLKmode type, which we can pack tighter. If so,
4603 return the new type. If not, return the original type. */
4606 make_packable_type (tree type)
4608 tree new_type = make_node (TREE_CODE (type));
4609 tree field_list = NULL_TREE;
4612 /* Copy the name and flags from the old type to that of the new and set
4613 the alignment to try for an integral type. For QUAL_UNION_TYPE,
4614 also copy the size. */
4615 TYPE_NAME (new_type) = TYPE_NAME (type);
4616 TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
4617 = TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
4618 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
4619 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
4620 if (TREE_CODE (type) == QUAL_UNION_TYPE)
4622 TYPE_SIZE (new_type) = TYPE_SIZE (type);
4623 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
4626 TYPE_ALIGN (new_type)
4627 = ((HOST_WIDE_INT) 1
4628 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
4630 /* Now copy the fields, keeping the position and size. */
4631 for (old_field = TYPE_FIELDS (type); old_field != 0;
4632 old_field = TREE_CHAIN (old_field))
4634 tree new_field_type = TREE_TYPE (old_field);
4637 if (TYPE_MODE (new_field_type) == BLKmode
4638 && (TREE_CODE (new_field_type) == RECORD_TYPE
4639 || TREE_CODE (new_field_type) == UNION_TYPE
4640 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
4641 && host_integerp (TYPE_SIZE (new_field_type), 1))
4642 new_field_type = make_packable_type (new_field_type);
4644 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
4645 new_type, TYPE_PACKED (type),
4646 DECL_SIZE (old_field),
4647 bit_position (old_field),
4648 ! DECL_NONADDRESSABLE_P (old_field));
4650 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
4651 SET_DECL_ORIGINAL_FIELD (new_field,
4652 (DECL_ORIGINAL_FIELD (old_field) != 0
4653 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
4655 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
4656 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
4658 TREE_CHAIN (new_field) = field_list;
4659 field_list = new_field;
4662 finish_record_type (new_type, nreverse (field_list), 1, 1);
4663 copy_alias_set (new_type, type);
4664 return TYPE_MODE (new_type) == BLKmode ? type : new_type;
4667 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
4668 if needed. We have already verified that SIZE and TYPE are large enough.
4670 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
4673 IS_USER_TYPE is nonzero if we must be sure we complete the original type.
4675 DEFINITION is nonzero if this type is being defined.
4677 SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be
4678 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
4682 maybe_pad_type (tree type,
4685 Entity_Id gnat_entity,
4686 const char *name_trailer,
4691 tree orig_size = TYPE_SIZE (type);
4695 /* If TYPE is a padded type, see if it agrees with any size and alignment
4696 we were given. If so, return the original type. Otherwise, strip
4697 off the padding, since we will either be returning the inner type
4698 or repadding it. If no size or alignment is specified, use that of
4699 the original padded type. */
4701 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4704 || operand_equal_p (round_up (size,
4705 MAX (align, TYPE_ALIGN (type))),
4706 round_up (TYPE_SIZE (type),
4707 MAX (align, TYPE_ALIGN (type))),
4709 && (align == 0 || align == TYPE_ALIGN (type)))
4713 size = TYPE_SIZE (type);
4715 align = TYPE_ALIGN (type);
4717 type = TREE_TYPE (TYPE_FIELDS (type));
4718 orig_size = TYPE_SIZE (type);
4721 /* If the size is either not being changed or is being made smaller (which
4722 is not done here (and is only valid for bitfields anyway), show the size
4723 isn't changing. Likewise, clear the alignment if it isn't being
4724 changed. Then return if we aren't doing anything. */
4727 && (operand_equal_p (size, orig_size, 0)
4728 || (TREE_CODE (orig_size) == INTEGER_CST
4729 && tree_int_cst_lt (size, orig_size))))
4732 if (align == TYPE_ALIGN (type))
4735 if (align == 0 && size == 0)
4738 /* We used to modify the record in place in some cases, but that could
4739 generate incorrect debugging information. So make a new record
4741 record = make_node (RECORD_TYPE);
4743 if (Present (gnat_entity))
4744 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
4746 /* If we were making a type, complete the original type and give it a
4749 create_type_decl (get_entity_name (gnat_entity), type,
4750 0, ! Comes_From_Source (gnat_entity),
4751 ! (TYPE_NAME (type) != 0
4752 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
4753 && DECL_IGNORED_P (TYPE_NAME (type))));
4755 /* If we are changing the alignment and the input type is a record with
4756 BLKmode and a small constant size, try to make a form that has an
4757 integral mode. That might allow this record to have an integral mode,
4758 which will be much more efficient. There is no point in doing this if a
4759 size is specified unless it is also smaller than the biggest alignment
4760 and it is incorrect to do this if the size of the original type is not a
4761 multiple of the alignment. */
4763 && TREE_CODE (type) == RECORD_TYPE
4764 && TYPE_MODE (type) == BLKmode
4765 && host_integerp (orig_size, 1)
4766 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
4768 || (TREE_CODE (size) == INTEGER_CST
4769 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
4770 && tree_low_cst (orig_size, 1) % align == 0)
4771 type = make_packable_type (type);
4773 field = create_field_decl (get_identifier ("F"), type, record, 0,
4774 NULL_TREE, bitsize_zero_node, 1);
4776 DECL_INTERNAL_P (field) = 1;
4777 TYPE_SIZE (record) = size != 0 ? size : orig_size;
4778 TYPE_SIZE_UNIT (record)
4779 = convert (sizetype,
4780 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
4781 bitsize_unit_node));
4782 TYPE_ALIGN (record) = align;
4783 TYPE_IS_PADDING_P (record) = 1;
4784 TYPE_VOLATILE (record)
4785 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
4786 finish_record_type (record, field, 1, 0);
4788 /* Keep the RM_Size of the padded record as that of the old record
4790 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
4792 /* Unless debugging information isn't being written for the input type,
4793 write a record that shows what we are a subtype of and also make a
4794 variable that indicates our size, if variable. */
4795 if (TYPE_NAME (record) != 0
4796 && AGGREGATE_TYPE_P (type)
4797 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
4798 || ! DECL_IGNORED_P (TYPE_NAME (type))))
4800 tree marker = make_node (RECORD_TYPE);
4801 tree name = DECL_NAME (TYPE_NAME (record));
4802 tree orig_name = TYPE_NAME (type);
4804 if (TREE_CODE (orig_name) == TYPE_DECL)
4805 orig_name = DECL_NAME (orig_name);
4807 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
4808 finish_record_type (marker,
4809 create_field_decl (orig_name, integer_type_node,
4810 marker, 0, NULL_TREE, NULL_TREE,
4814 if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
4815 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
4816 sizetype, TYPE_SIZE (record), 0, 0, 0, 0,
4822 if (CONTAINS_PLACEHOLDER_P (orig_size))
4823 orig_size = max_size (orig_size, 1);
4825 /* If the size was widened explicitly, maybe give a warning. */
4826 if (size != 0 && Present (gnat_entity)
4827 && ! operand_equal_p (size, orig_size, 0)
4828 && ! (TREE_CODE (size) == INTEGER_CST
4829 && TREE_CODE (orig_size) == INTEGER_CST
4830 && tree_int_cst_lt (size, orig_size)))
4832 Node_Id gnat_error_node = Empty;
4834 if (Is_Packed_Array_Type (gnat_entity))
4835 gnat_entity = Associated_Node_For_Itype (gnat_entity);
4837 if ((Ekind (gnat_entity) == E_Component
4838 || Ekind (gnat_entity) == E_Discriminant)
4839 && Present (Component_Clause (gnat_entity)))
4840 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
4841 else if (Present (Size_Clause (gnat_entity)))
4842 gnat_error_node = Expression (Size_Clause (gnat_entity));
4844 /* Generate message only for entities that come from source, since
4845 if we have an entity created by expansion, the message will be
4846 generated for some other corresponding source entity. */
4847 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
4848 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
4850 size_diffop (size, orig_size));
4852 else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity))
4853 post_error_ne_tree ("component of& padded{ by ^ bits}?",
4854 gnat_entity, gnat_entity,
4855 size_diffop (size, orig_size));
4861 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
4862 the value passed against the list of choices. */
4865 choices_to_gnu (tree operand, Node_Id choices)
4869 tree result = integer_zero_node;
4870 tree this_test, low = 0, high = 0, single = 0;
4872 for (choice = First (choices); Present (choice); choice = Next (choice))
4874 switch (Nkind (choice))
4877 low = gnat_to_gnu (Low_Bound (choice));
4878 high = gnat_to_gnu (High_Bound (choice));
4880 /* There's no good type to use here, so we might as well use
4881 integer_type_node. */
4883 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4884 build_binary_op (GE_EXPR, integer_type_node,
4886 build_binary_op (LE_EXPR, integer_type_node,
4891 case N_Subtype_Indication:
4892 gnat_temp = Range_Expression (Constraint (choice));
4893 low = gnat_to_gnu (Low_Bound (gnat_temp));
4894 high = gnat_to_gnu (High_Bound (gnat_temp));
4897 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4898 build_binary_op (GE_EXPR, integer_type_node,
4900 build_binary_op (LE_EXPR, integer_type_node,
4905 case N_Expanded_Name:
4906 /* This represents either a subtype range, an enumeration
4907 literal, or a constant Ekind says which. If an enumeration
4908 literal or constant, fall through to the next case. */
4909 if (Ekind (Entity (choice)) != E_Enumeration_Literal
4910 && Ekind (Entity (choice)) != E_Constant)
4912 tree type = gnat_to_gnu_type (Entity (choice));
4914 low = TYPE_MIN_VALUE (type);
4915 high = TYPE_MAX_VALUE (type);
4918 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4919 build_binary_op (GE_EXPR, integer_type_node,
4921 build_binary_op (LE_EXPR, integer_type_node,
4925 /* ... fall through ... */
4926 case N_Character_Literal:
4927 case N_Integer_Literal:
4928 single = gnat_to_gnu (choice);
4929 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
4933 case N_Others_Choice:
4934 this_test = integer_one_node;
4941 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4948 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
4949 placed in GNU_RECORD_TYPE.
4951 PACKED is 1 if the enclosing record is packed and -1 if the enclosing
4952 record has a Component_Alignment of Storage_Unit.
4954 DEFINITION is nonzero if this field is for a record being defined. */
4957 gnat_to_gnu_field (Entity_Id gnat_field,
4958 tree gnu_record_type,
4962 tree gnu_field_id = get_entity_name (gnat_field);
4963 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
4964 tree gnu_orig_field_type = gnu_field_type;
4968 int needs_strict_alignment
4969 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
4970 || Treat_As_Volatile (gnat_field));
4972 /* If this field requires strict alignment or contains an item of
4973 variable sized, pretend it isn't packed. */
4974 if (needs_strict_alignment || is_variable_size (gnu_field_type))
4977 /* For packed records, this is one of the few occasions on which we use
4978 the official RM size for discrete or fixed-point components, instead
4979 of the normal GNAT size stored in Esize. See description in Einfo:
4980 "Handling of Type'Size Values" for further details. */
4983 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
4984 gnat_field, FIELD_DECL, 0, 1);
4986 if (Known_Static_Esize (gnat_field))
4987 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
4988 gnat_field, FIELD_DECL, 0, 1);
4990 /* If the field's type is left-justified modular, the wrapper can prevent
4991 packing so we make the field the type of the inner object unless the
4992 situation forbids it. We may not do that when the field is addressable_p,
4993 typically because in that case this field may later be passed by-ref for
4994 a formal argument expecting the left justification. The condition below
4995 is then matching the addressable_p code for COMPONENT_REF. */
4996 if (! Is_Aliased (gnat_field) && flag_strict_aliasing
4997 && TREE_CODE (gnu_field_type) == RECORD_TYPE
4998 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
4999 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5001 /* If we are packing this record or we have a specified size that's
5002 smaller than that of the field type and the field type is also a record
5003 that's BLKmode and with a small constant size, see if we can get a
5004 better form of the type that allows more packing. If we can, show
5005 a size was specified for it if there wasn't one so we know to
5006 make this a bitfield and avoid making things wider. */
5007 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5008 && TYPE_MODE (gnu_field_type) == BLKmode
5009 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
5010 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
5012 || (gnu_size != 0 && tree_int_cst_lt (gnu_size,
5013 TYPE_SIZE (gnu_field_type)))))
5015 gnu_field_type = make_packable_type (gnu_field_type);
5017 if (gnu_field_type != gnu_orig_field_type && gnu_size == 0)
5018 gnu_size = rm_size (gnu_field_type);
5021 /* If we are packing the record and the field is BLKmode, round the
5022 size up to a byte boundary. */
5023 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0)
5024 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
5026 if (Present (Component_Clause (gnat_field)))
5028 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
5029 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5030 gnat_field, FIELD_DECL, 0, 1);
5032 /* Ensure the position does not overlap with the parent subtype,
5034 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
5037 = gnat_to_gnu_type (Parent_Subtype
5038 (Underlying_Type (Scope (gnat_field))));
5040 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
5041 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
5044 ("offset of& must be beyond parent{, minimum allowed is ^}",
5045 First_Bit (Component_Clause (gnat_field)), gnat_field,
5046 TYPE_SIZE_UNIT (gnu_parent));
5050 /* If this field needs strict alignment, ensure the record is
5051 sufficiently aligned and that that position and size are
5052 consistent with the alignment. */
5053 if (needs_strict_alignment)
5055 tree gnu_min_size = round_up (rm_size (gnu_field_type),
5056 TYPE_ALIGN (gnu_field_type));
5058 TYPE_ALIGN (gnu_record_type)
5059 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
5061 /* If Atomic, the size must match exactly and if aliased, the size
5062 must not be less than the rounded size. */
5063 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
5064 && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
5067 ("atomic field& must be natural size of type{ (^)}",
5068 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5069 TYPE_SIZE (gnu_field_type));
5074 else if (Is_Aliased (gnat_field)
5076 && tree_int_cst_lt (gnu_size, gnu_min_size))
5079 ("size of aliased field& too small{, minimum required is ^}",
5080 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5085 if (! integer_zerop (size_binop
5086 (TRUNC_MOD_EXPR, gnu_pos,
5087 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
5089 if (Is_Aliased (gnat_field))
5091 ("position of aliased field& must be multiple of ^ bits",
5092 First_Bit (Component_Clause (gnat_field)), gnat_field,
5093 TYPE_ALIGN (gnu_field_type));
5095 else if (Treat_As_Volatile (gnat_field))
5097 ("position of volatile field& must be multiple of ^ bits",
5098 First_Bit (Component_Clause (gnat_field)), gnat_field,
5099 TYPE_ALIGN (gnu_field_type));
5101 else if (Strict_Alignment (Etype (gnat_field)))
5103 ("position of & with aliased or tagged components not multiple of ^ bits",
5104 First_Bit (Component_Clause (gnat_field)), gnat_field,
5105 TYPE_ALIGN (gnu_field_type));
5112 /* If an error set the size to zero, show we have no position
5118 if (Is_Atomic (gnat_field))
5119 check_ok_for_atomic (gnu_field_type, gnat_field, 0);
5122 /* If the record has rep clauses and this is the tag field, make a rep
5123 clause for it as well. */
5124 else if (Has_Specified_Layout (Scope (gnat_field))
5125 && Chars (gnat_field) == Name_uTag)
5127 gnu_pos = bitsize_zero_node;
5128 gnu_size = TYPE_SIZE (gnu_field_type);
5131 /* We need to make the size the maximum for the type if it is
5132 self-referential and an unconstrained type. In that case, we can't
5133 pack the field since we can't make a copy to align it. */
5134 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5136 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
5137 && ! Is_Constrained (Underlying_Type (Etype (gnat_field))))
5139 gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1);
5143 /* If no size is specified (or if there was an error), don't specify a
5149 /* Unless this field is aliased, we can remove any left-justified
5150 modular type since it's only needed in the unchecked conversion
5151 case, which doesn't apply here. */
5152 if (! needs_strict_alignment
5153 && TREE_CODE (gnu_field_type) == RECORD_TYPE
5154 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
5155 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5158 = make_type_from_size (gnu_field_type, gnu_size,
5159 Has_Biased_Representation (gnat_field));
5160 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0,
5161 gnat_field, "PAD", 0, definition, 1);
5164 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5165 && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
5168 /* Now create the decl for the field. */
5169 set_lineno (gnat_field, 0);
5170 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
5171 packed, gnu_size, gnu_pos,
5172 Is_Aliased (gnat_field));
5174 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
5176 if (Ekind (gnat_field) == E_Discriminant)
5177 DECL_DISCRIMINANT_NUMBER (gnu_field)
5178 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
5183 /* Return 1 if TYPE is a type with variable size, a padding type with a field
5184 of variable size or is a record that has a field such a field. */
5187 is_variable_size (tree type)
5191 /* We need not be concerned about this at all if we don't have
5192 strict alignment. */
5193 if (! STRICT_ALIGNMENT)
5195 else if (! TREE_CONSTANT (TYPE_SIZE (type)))
5197 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
5198 && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
5200 else if (TREE_CODE (type) != RECORD_TYPE
5201 && TREE_CODE (type) != UNION_TYPE
5202 && TREE_CODE (type) != QUAL_UNION_TYPE)
5205 for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field))
5206 if (is_variable_size (TREE_TYPE (field)))
5212 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5213 of GCC trees for fields that are in the record and have already been
5214 processed. When called from gnat_to_gnu_entity during the processing of a
5215 record type definition, the GCC nodes for the discriminants will be on
5216 the chain. The other calls to this function are recursive calls from
5217 itself for the Component_List of a variant and the chain is empty.
5219 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is
5220 for a record type with "pragma component_alignment (storage_unit)".
5222 FINISH_RECORD is nonzero if this call will supply all of the remaining
5223 fields of the record.
5225 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5226 with a rep clause is to be added. If it is nonzero, that is all that
5227 should be done with such fields.
5229 CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed
5230 before laying out the record. This means the alignment only serves
5231 to force fields to be bitfields, but not require the record to be
5232 that aligned. This is used for variants.
5234 ALL_REP, if nonzero, means that a rep clause was found for all the
5235 fields. This simplifies the logic since we know we're not in the mixed
5238 The processing of the component list fills in the chain with all of the
5239 fields of the record and then the record type is finished. */
5242 components_to_record (tree gnu_record_type,
5243 Node_Id component_list,
5244 tree gnu_field_list,
5247 tree *p_gnu_rep_list,
5248 int cancel_alignment,
5251 Node_Id component_decl;
5252 Entity_Id gnat_field;
5253 Node_Id variant_part;
5255 tree gnu_our_rep_list = NULL_TREE;
5256 tree gnu_field, gnu_last;
5257 int layout_with_rep = 0;
5258 int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0;
5260 /* For each variable within each component declaration create a GCC field
5261 and add it to the list, skipping any pragmas in the list. */
5263 if (Present (Component_Items (component_list)))
5264 for (component_decl = First_Non_Pragma (Component_Items (component_list));
5265 Present (component_decl);
5266 component_decl = Next_Non_Pragma (component_decl))
5268 gnat_field = Defining_Entity (component_decl);
5270 if (Chars (gnat_field) == Name_uParent)
5271 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
5274 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
5275 packed, definition);
5277 /* If this is the _Tag field, put it before any discriminants,
5278 instead of after them as is the case for all other fields.
5279 Ignore field of void type if only annotating. */
5280 if (Chars (gnat_field) == Name_uTag)
5281 gnu_field_list = chainon (gnu_field_list, gnu_field);
5284 TREE_CHAIN (gnu_field) = gnu_field_list;
5285 gnu_field_list = gnu_field;
5289 save_gnu_tree (gnat_field, gnu_field, 0);
5292 /* At the end of the component list there may be a variant part. */
5293 variant_part = Variant_Part (component_list);
5295 /* If this is an unchecked union, each variant must have exactly one
5296 component, each of which becomes one component of this union. */
5297 if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part))
5298 for (variant = First_Non_Pragma (Variants (variant_part));
5300 variant = Next_Non_Pragma (variant))
5303 = First_Non_Pragma (Component_Items (Component_List (variant)));
5304 gnat_field = Defining_Entity (component_decl);
5305 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
5307 TREE_CHAIN (gnu_field) = gnu_field_list;
5308 gnu_field_list = gnu_field;
5309 save_gnu_tree (gnat_field, gnu_field, 0);
5312 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5313 mutually exclusive and should go in the same memory. To do this we need
5314 to treat each variant as a record whose elements are created from the
5315 component list for the variant. So here we create the records from the
5316 lists for the variants and put them all into the QUAL_UNION_TYPE. */
5317 else if (Present (variant_part))
5319 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
5321 tree gnu_union_type = make_node (QUAL_UNION_TYPE);
5322 tree gnu_union_field;
5323 tree gnu_variant_list = NULL_TREE;
5324 tree gnu_name = TYPE_NAME (gnu_record_type);
5326 = concat_id_with_name
5327 (get_identifier (Get_Name_String (Chars (Name (variant_part)))),
5330 if (TREE_CODE (gnu_name) == TYPE_DECL)
5331 gnu_name = DECL_NAME (gnu_name);
5333 TYPE_NAME (gnu_union_type)
5334 = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
5335 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
5337 for (variant = First_Non_Pragma (Variants (variant_part));
5339 variant = Next_Non_Pragma (variant))
5341 tree gnu_variant_type = make_node (RECORD_TYPE);
5342 tree gnu_inner_name;
5345 Get_Variant_Encoding (variant);
5346 gnu_inner_name = get_identifier (Name_Buffer);
5347 TYPE_NAME (gnu_variant_type)
5348 = concat_id_with_name (TYPE_NAME (gnu_union_type),
5349 IDENTIFIER_POINTER (gnu_inner_name));
5351 /* Set the alignment of the inner type in case we need to make
5352 inner objects into bitfields, but then clear it out
5353 so the record actually gets only the alignment required. */
5354 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
5355 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
5357 /* Similarly, if the outer record has a size specified and all fields
5358 have record rep clauses, we can propagate the size into the
5360 if (all_rep_and_size)
5362 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
5363 TYPE_SIZE_UNIT (gnu_variant_type)
5364 = TYPE_SIZE_UNIT (gnu_record_type);
5367 components_to_record (gnu_variant_type, Component_List (variant),
5368 NULL_TREE, packed, definition,
5369 &gnu_our_rep_list, !all_rep_and_size, all_rep);
5371 gnu_qual = choices_to_gnu (gnu_discriminant,
5372 Discrete_Choices (variant));
5374 Set_Present_Expr (variant, annotate_value (gnu_qual));
5375 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
5378 ? TYPE_SIZE (gnu_record_type) : 0),
5380 ? bitsize_zero_node : 0),
5383 DECL_INTERNAL_P (gnu_field) = 1;
5384 DECL_QUALIFIER (gnu_field) = gnu_qual;
5385 TREE_CHAIN (gnu_field) = gnu_variant_list;
5386 gnu_variant_list = gnu_field;
5389 /* We use to delete the empty variants from the end. However,
5390 we no longer do that because we need them to generate complete
5391 debugging information for the variant record. Otherwise,
5392 the union type definition will be missing the fields associated
5393 to these empty variants. */
5395 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
5396 if (gnu_variant_list != 0)
5398 if (all_rep_and_size)
5400 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
5401 TYPE_SIZE_UNIT (gnu_union_type)
5402 = TYPE_SIZE_UNIT (gnu_record_type);
5405 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
5406 all_rep_and_size, 0);
5409 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
5411 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
5412 all_rep ? bitsize_zero_node : 0, 0);
5414 DECL_INTERNAL_P (gnu_union_field) = 1;
5415 TREE_CHAIN (gnu_union_field) = gnu_field_list;
5416 gnu_field_list = gnu_union_field;
5420 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
5421 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
5422 in a separate pass since we want to handle the discriminants but can't
5423 play with them until we've used them in debugging data above.
5425 ??? Note: if we then reorder them, debugging information will be wrong,
5426 but there's nothing that can be done about this at the moment. */
5428 for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; )
5430 if (DECL_FIELD_OFFSET (gnu_field) != 0)
5432 tree gnu_next = TREE_CHAIN (gnu_field);
5435 gnu_field_list = gnu_next;
5437 TREE_CHAIN (gnu_last) = gnu_next;
5439 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
5440 gnu_our_rep_list = gnu_field;
5441 gnu_field = gnu_next;
5445 gnu_last = gnu_field;
5446 gnu_field = TREE_CHAIN (gnu_field);
5450 /* If we have any items in our rep'ed field list, it is not the case that all
5451 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
5452 set it and ignore the items. Otherwise, sort the fields by bit position
5453 and put them into their own record if we have any fields without
5455 if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep)
5456 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
5457 else if (gnu_our_rep_list != 0)
5460 = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE);
5461 int len = list_length (gnu_our_rep_list);
5462 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
5465 /* Set DECL_SECTION_NAME to increasing integers so we have a
5467 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
5468 gnu_field = TREE_CHAIN (gnu_field), i++)
5470 gnu_arr[i] = gnu_field;
5471 DECL_SECTION_NAME (gnu_field) = size_int (i);
5474 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
5476 /* Put the fields in the list in order of increasing position, which
5477 means we start from the end. */
5478 gnu_our_rep_list = NULL_TREE;
5479 for (i = len - 1; i >= 0; i--)
5481 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
5482 gnu_our_rep_list = gnu_arr[i];
5483 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
5484 DECL_SECTION_NAME (gnu_arr[i]) = 0;
5487 if (gnu_field_list != 0)
5489 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0);
5490 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
5491 gnu_record_type, 0, 0, 0, 1);
5492 DECL_INTERNAL_P (gnu_field) = 1;
5493 gnu_field_list = chainon (gnu_field_list, gnu_field);
5497 layout_with_rep = 1;
5498 gnu_field_list = nreverse (gnu_our_rep_list);
5502 if (cancel_alignment)
5503 TYPE_ALIGN (gnu_record_type) = 0;
5505 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
5506 layout_with_rep, 0);
5509 /* Called via qsort from the above. Returns -1, 1, depending on the
5510 bit positions and ordinals of the two fields. */
5513 compare_field_bitpos (const PTR rt1, const PTR rt2)
5515 tree *t1 = (tree *) rt1;
5516 tree *t2 = (tree *) rt2;
5518 if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
5520 (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2))
5522 else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
5528 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
5529 placed into an Esize, Component_Bit_Offset, or Component_Size value
5530 in the GNAT tree. */
5533 annotate_value (tree gnu_size)
5535 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
5537 Node_Ref_Or_Val ops[3], ret;
5541 /* If back annotation is suppressed by the front end, return No_Uint */
5542 if (!Back_Annotate_Rep_Info)
5545 /* See if we've already saved the value for this node. */
5546 if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size)))
5547 && TREE_COMPLEXITY (gnu_size) != 0)
5548 return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
5550 /* If we do not return inside this switch, TCODE will be set to the
5551 code to use for a Create_Node operand and LEN (set above) will be
5552 the number of recursive calls for us to make. */
5554 switch (TREE_CODE (gnu_size))
5557 if (TREE_OVERFLOW (gnu_size))
5560 /* This may have come from a conversion from some smaller type,
5561 so ensure this is in bitsizetype. */
5562 gnu_size = convert (bitsizetype, gnu_size);
5564 /* For negative values, use NEGATE_EXPR of the supplied value. */
5565 if (tree_int_cst_sgn (gnu_size) < 0)
5567 /* The rediculous code below is to handle the case of the largest
5568 negative integer. */
5569 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
5573 if (TREE_CONSTANT_OVERFLOW (negative_size))
5576 = size_binop (MINUS_EXPR, bitsize_zero_node,
5577 size_binop (PLUS_EXPR, gnu_size,
5582 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
5584 temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
5586 return annotate_value (temp);
5589 if (! host_integerp (gnu_size, 1))
5592 size = tree_low_cst (gnu_size, 1);
5594 /* This peculiar test is to make sure that the size fits in an int
5595 on machines where HOST_WIDE_INT is not "int". */
5596 if (tree_low_cst (gnu_size, 1) == size)
5597 return UI_From_Int (size);
5602 /* The only case we handle here is a simple discriminant reference. */
5603 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
5604 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
5605 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0)
5606 return Create_Node (Discrim_Val,
5607 annotate_value (DECL_DISCRIMINANT_NUMBER
5608 (TREE_OPERAND (gnu_size, 1))),
5613 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
5614 return annotate_value (TREE_OPERAND (gnu_size, 0));
5616 /* Now just list the operations we handle. */
5617 case COND_EXPR: tcode = Cond_Expr; break;
5618 case PLUS_EXPR: tcode = Plus_Expr; break;
5619 case MINUS_EXPR: tcode = Minus_Expr; break;
5620 case MULT_EXPR: tcode = Mult_Expr; break;
5621 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
5622 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
5623 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
5624 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
5625 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
5626 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
5627 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
5628 case NEGATE_EXPR: tcode = Negate_Expr; break;
5629 case MIN_EXPR: tcode = Min_Expr; break;
5630 case MAX_EXPR: tcode = Max_Expr; break;
5631 case ABS_EXPR: tcode = Abs_Expr; break;
5632 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
5633 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
5634 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
5635 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
5636 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
5637 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
5638 case LT_EXPR: tcode = Lt_Expr; break;
5639 case LE_EXPR: tcode = Le_Expr; break;
5640 case GT_EXPR: tcode = Gt_Expr; break;
5641 case GE_EXPR: tcode = Ge_Expr; break;
5642 case EQ_EXPR: tcode = Eq_Expr; break;
5643 case NE_EXPR: tcode = Ne_Expr; break;
5649 /* Now get each of the operands that's relevant for this code. If any
5650 cannot be expressed as a repinfo node, say we can't. */
5651 for (i = 0; i < 3; i++)
5654 for (i = 0; i < len; i++)
5656 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
5657 if (ops[i] == No_Uint)
5661 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
5662 TREE_COMPLEXITY (gnu_size) = ret;
5666 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
5667 GCC type, set Component_Bit_Offset and Esize to the position and size
5671 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
5675 Entity_Id gnat_field;
5677 /* We operate by first making a list of all field and their positions
5678 (we can get the sizes easily at any time) by a recursive call
5679 and then update all the sizes into the tree. */
5680 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
5681 size_zero_node, bitsize_zero_node,
5684 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
5685 gnat_field = Next_Entity (gnat_field))
5686 if ((Ekind (gnat_field) == E_Component
5687 || (Ekind (gnat_field) == E_Discriminant
5688 && ! Is_Unchecked_Union (Scope (gnat_field)))))
5690 tree parent_offset = bitsize_zero_node;
5693 = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0),
5698 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
5700 /* In this mode the tag and parent components have not been
5701 generated, so we add the appropriate offset to each
5702 component. For a component appearing in the current
5703 extension, the offset is the size of the parent. */
5704 if (Is_Derived_Type (gnat_entity)
5705 && Original_Record_Component (gnat_field) == gnat_field)
5707 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
5710 parent_offset = bitsize_int (POINTER_SIZE);
5713 Set_Component_Bit_Offset
5716 (size_binop (PLUS_EXPR,
5717 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
5718 TREE_VALUE (TREE_VALUE
5719 (TREE_VALUE (gnu_entry)))),
5722 Set_Esize (gnat_field,
5723 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
5725 else if (type_annotate_only
5726 && Is_Tagged_Type (gnat_entity)
5727 && Is_Derived_Type (gnat_entity))
5729 /* If there is no gnu_entry, this is an inherited component whose
5730 position is the same as in the parent type. */
5731 Set_Component_Bit_Offset
5733 Component_Bit_Offset (Original_Record_Component (gnat_field)));
5734 Set_Esize (gnat_field,
5735 Esize (Original_Record_Component (gnat_field)));
5740 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
5741 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
5742 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
5743 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
5744 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
5745 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
5749 compute_field_positions (tree gnu_type,
5753 unsigned int offset_align)
5756 tree gnu_result = gnu_list;
5758 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
5759 gnu_field = TREE_CHAIN (gnu_field))
5761 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
5762 DECL_FIELD_BIT_OFFSET (gnu_field));
5763 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
5764 DECL_FIELD_OFFSET (gnu_field));
5765 unsigned int our_offset_align
5766 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
5769 = tree_cons (gnu_field,
5770 tree_cons (gnu_our_offset,
5771 tree_cons (size_int (our_offset_align),
5772 gnu_our_bitpos, NULL_TREE),
5776 if (DECL_INTERNAL_P (gnu_field))
5778 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
5779 gnu_our_offset, gnu_our_bitpos,
5786 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
5787 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
5788 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
5789 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
5790 for the size of a field. COMPONENT_P is true if we are being called
5791 to process the Component_Size of GNAT_OBJECT. This is used for error
5792 message handling and to indicate to use the object size of GNU_TYPE.
5793 ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero,
5794 it means that a size of zero should be treated as an unspecified size. */
5797 validate_size (Uint uint_size,
5799 Entity_Id gnat_object,
5800 enum tree_code kind,
5804 Node_Id gnat_error_node;
5806 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
5809 /* Find the node to use for errors. */
5810 if ((Ekind (gnat_object) == E_Component
5811 || Ekind (gnat_object) == E_Discriminant)
5812 && Present (Component_Clause (gnat_object)))
5813 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
5814 else if (Present (Size_Clause (gnat_object)))
5815 gnat_error_node = Expression (Size_Clause (gnat_object));
5817 gnat_error_node = gnat_object;
5819 /* Return 0 if no size was specified, either because Esize was not Present or
5820 the specified size was zero. */
5821 if (No (uint_size) || uint_size == No_Uint)
5824 /* Get the size as a tree. Give an error if a size was specified, but cannot
5825 be represented as in sizetype. */
5826 size = UI_To_gnu (uint_size, bitsizetype);
5827 if (TREE_OVERFLOW (size))
5829 post_error_ne (component_p ? "component size of & is too large"
5830 : "size of & is too large",
5831 gnat_error_node, gnat_object);
5834 /* Ignore a negative size since that corresponds to our back-annotation.
5835 Also ignore a zero size unless a size clause exists. */
5836 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok))
5839 /* The size of objects is always a multiple of a byte. */
5840 if (kind == VAR_DECL
5841 && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size,
5842 bitsize_unit_node)))
5845 post_error_ne ("component size for& is not a multiple of Storage_Unit",
5846 gnat_error_node, gnat_object);
5848 post_error_ne ("size for& is not a multiple of Storage_Unit",
5849 gnat_error_node, gnat_object);
5853 /* If this is an integral type or a packed array type, the front-end has
5854 verified the size, so we need not do it here (which would entail
5855 checking against the bounds). However, if this is an aliased object, it
5856 may not be smaller than the type of the object. */
5857 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
5858 && ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
5861 /* If the object is a record that contains a template, add the size of
5862 the template to the specified size. */
5863 if (TREE_CODE (gnu_type) == RECORD_TYPE
5864 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
5865 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
5867 /* Modify the size of the type to be that of the maximum size if it has a
5868 discriminant or the size of a thin pointer if this is a fat pointer. */
5869 if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size))
5870 type_size = max_size (type_size, 1);
5871 else if (TYPE_FAT_POINTER_P (gnu_type))
5872 type_size = bitsize_int (POINTER_SIZE);
5874 /* If the size of the object is a constant, the new size must not be
5876 if (TREE_CODE (type_size) != INTEGER_CST
5877 || TREE_OVERFLOW (type_size)
5878 || tree_int_cst_lt (size, type_size))
5882 ("component size for& too small{, minimum allowed is ^}",
5883 gnat_error_node, gnat_object, type_size);
5885 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
5886 gnat_error_node, gnat_object, type_size);
5888 if (kind == VAR_DECL && ! component_p
5889 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
5890 && ! tree_int_cst_lt (size, rm_size (gnu_type)))
5891 post_error_ne_tree_2
5892 ("\\size of ^ is not a multiple of alignment (^ bits)",
5893 gnat_error_node, gnat_object, rm_size (gnu_type),
5894 TYPE_ALIGN (gnu_type));
5896 else if (INTEGRAL_TYPE_P (gnu_type))
5897 post_error_ne ("\\size would be legal if & were not aliased!",
5898 gnat_error_node, gnat_object);
5906 /* Similarly, but both validate and process a value of RM_Size. This
5907 routine is only called for types. */
5910 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
5912 /* Only give an error if a Value_Size clause was explicitly given.
5913 Otherwise, we'd be duplicating an error on the Size clause. */
5914 Node_Id gnat_attr_node
5915 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
5916 tree old_size = rm_size (gnu_type);
5919 /* Get the size as a tree. Do nothing if none was specified, either
5920 because RM_Size was not Present or if the specified size was zero.
5921 Give an error if a size was specified, but cannot be represented as
5923 if (No (uint_size) || uint_size == No_Uint)
5926 size = UI_To_gnu (uint_size, bitsizetype);
5927 if (TREE_OVERFLOW (size))
5929 if (Present (gnat_attr_node))
5930 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
5936 /* Ignore a negative size since that corresponds to our back-annotation.
5937 Also ignore a zero size unless a size clause exists, a Value_Size
5938 clause exists, or this is an integer type, in which case the
5939 front end will have always set it. */
5940 else if (tree_int_cst_sgn (size) < 0
5941 || (integer_zerop (size) && No (gnat_attr_node)
5942 && ! Has_Size_Clause (gnat_entity)
5943 && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
5946 /* If the old size is self-referential, get the maximum size. */
5947 if (CONTAINS_PLACEHOLDER_P (old_size))
5948 old_size = max_size (old_size, 1);
5950 /* If the size of the object is a constant, the new size must not be
5951 smaller (the front end checks this for scalar types). */
5952 if (TREE_CODE (old_size) != INTEGER_CST
5953 || TREE_OVERFLOW (old_size)
5954 || (AGGREGATE_TYPE_P (gnu_type)
5955 && tree_int_cst_lt (size, old_size)))
5957 if (Present (gnat_attr_node))
5959 ("Value_Size for& too small{, minimum allowed is ^}",
5960 gnat_attr_node, gnat_entity, old_size);
5965 /* Otherwise, set the RM_Size. */
5966 if (TREE_CODE (gnu_type) == INTEGER_TYPE
5967 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
5968 TYPE_RM_SIZE_INT (gnu_type) = size;
5969 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
5970 SET_TYPE_RM_SIZE_ENUM (gnu_type, size);
5971 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
5972 || TREE_CODE (gnu_type) == UNION_TYPE
5973 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
5974 && ! TYPE_IS_FAT_POINTER_P (gnu_type))
5975 SET_TYPE_ADA_SIZE (gnu_type, size);
5978 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
5979 If TYPE is the best type, return it. Otherwise, make a new type. We
5980 only support new integral and pointer types. BIASED_P is nonzero if
5981 we are making a biased type. */
5984 make_type_from_size (tree type, tree size_tree, int biased_p)
5987 unsigned HOST_WIDE_INT size;
5989 /* If size indicates an error, just return TYPE to avoid propagating the
5990 error. Likewise if it's too large to represent. */
5991 if (size_tree == 0 || ! host_integerp (size_tree, 1))
5994 size = tree_low_cst (size_tree, 1);
5995 switch (TREE_CODE (type))
5999 /* Only do something if the type is not already the proper size and is
6000 not a packed array type. */
6001 if (TYPE_PACKED_ARRAY_TYPE_P (type)
6002 || (TYPE_PRECISION (type) == size
6003 && biased_p == (TREE_CODE (type) == INTEGER_CST
6004 && TYPE_BIASED_REPRESENTATION_P (type))))
6007 size = MIN (size, LONG_LONG_TYPE_SIZE);
6008 new_type = make_signed_type (size);
6009 TREE_TYPE (new_type)
6010 = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type;
6011 TYPE_MIN_VALUE (new_type)
6012 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
6013 TYPE_MAX_VALUE (new_type)
6014 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
6015 TYPE_BIASED_REPRESENTATION_P (new_type)
6016 = ((TREE_CODE (type) == INTEGER_TYPE
6017 && TYPE_BIASED_REPRESENTATION_P (type))
6019 TREE_UNSIGNED (new_type)
6020 = TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type);
6021 TYPE_RM_SIZE_INT (new_type) = bitsize_int (size);
6025 /* Do something if this is a fat pointer, in which case we
6026 may need to return the thin pointer. */
6027 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
6030 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
6034 /* Only do something if this is a thin pointer, in which case we
6035 may need to return the fat pointer. */
6036 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
6038 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
6049 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6050 a type or object whose present alignment is ALIGN. If this alignment is
6051 valid, return it. Otherwise, give an error and return ALIGN. */
6054 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
6056 Node_Id gnat_error_node = gnat_entity;
6057 unsigned int new_align;
6059 #ifndef MAX_OFILE_ALIGNMENT
6060 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
6063 if (Present (Alignment_Clause (gnat_entity)))
6064 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
6066 /* Don't worry about checking alignment if alignment was not specified
6067 by the source program and we already posted an error for this entity. */
6069 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
6072 /* Within GCC, an alignment is an integer, so we must make sure a
6073 value is specified that fits in that range. Also, alignments of
6074 more than MAX_OFILE_ALIGNMENT can't be supported. */
6076 if (! UI_Is_In_Int_Range (alignment)
6077 || ((new_align = UI_To_Int (alignment))
6078 > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT))
6079 post_error_ne_num ("largest supported alignment for& is ^",
6080 gnat_error_node, gnat_entity,
6081 MAX_OFILE_ALIGNMENT / BITS_PER_UNIT);
6082 else if (! (Present (Alignment_Clause (gnat_entity))
6083 && From_At_Mod (Alignment_Clause (gnat_entity)))
6084 && new_align * BITS_PER_UNIT < align)
6085 post_error_ne_num ("alignment for& must be at least ^",
6086 gnat_error_node, gnat_entity,
6087 align / BITS_PER_UNIT);
6089 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
6094 /* Verify that OBJECT, a type or decl, is something we can implement
6095 atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero
6096 if we require atomic components. */
6099 check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p)
6101 Node_Id gnat_error_point = gnat_entity;
6103 enum machine_mode mode;
6107 /* There are three case of what OBJECT can be. It can be a type, in which
6108 case we take the size, alignment and mode from the type. It can be a
6109 declaration that was indirect, in which case the relevant values are
6110 that of the type being pointed to, or it can be a normal declaration,
6111 in which case the values are of the decl. The code below assumes that
6112 OBJECT is either a type or a decl. */
6113 if (TYPE_P (object))
6115 mode = TYPE_MODE (object);
6116 align = TYPE_ALIGN (object);
6117 size = TYPE_SIZE (object);
6119 else if (DECL_BY_REF_P (object))
6121 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
6122 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
6123 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
6127 mode = DECL_MODE (object);
6128 align = DECL_ALIGN (object);
6129 size = DECL_SIZE (object);
6132 /* Consider all floating-point types atomic and any types that that are
6133 represented by integers no wider than a machine word. */
6134 if (GET_MODE_CLASS (mode) == MODE_FLOAT
6135 || ((GET_MODE_CLASS (mode) == MODE_INT
6136 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
6137 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
6140 /* For the moment, also allow anything that has an alignment equal
6141 to its size and which is smaller than a word. */
6142 if (size != 0 && TREE_CODE (size) == INTEGER_CST
6143 && compare_tree_int (size, align) == 0
6144 && align <= BITS_PER_WORD)
6147 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
6148 gnat_node = Next_Rep_Item (gnat_node))
6150 if (! comp_p && Nkind (gnat_node) == N_Pragma
6151 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
6152 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6153 else if (comp_p && Nkind (gnat_node) == N_Pragma
6154 && (Get_Pragma_Id (Chars (gnat_node))
6155 == Pragma_Atomic_Components))
6156 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6160 post_error_ne ("atomic access to component of & cannot be guaranteed",
6161 gnat_error_point, gnat_entity);
6163 post_error_ne ("atomic access to & cannot be guaranteed",
6164 gnat_error_point, gnat_entity);
6167 /* Given a type T, a FIELD_DECL F, and a replacement value R,
6168 return a new type with all size expressions that contain F
6169 updated by replacing F with R. This is identical to GCC's
6170 substitute_in_type except that it knows about TYPE_INDEX_TYPE.
6171 If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has
6175 gnat_substitute_in_type (tree t, tree f, tree r)
6180 switch (TREE_CODE (t))
6186 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6187 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6189 tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6190 tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6192 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6195 new = build_range_type (TREE_TYPE (t), low, high);
6196 if (TYPE_INDEX_TYPE (t))
6197 SET_TYPE_INDEX_TYPE (new,
6198 gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
6205 if ((TYPE_MIN_VALUE (t) != 0
6206 && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)))
6207 || (TYPE_MAX_VALUE (t) != 0
6208 && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))))
6210 tree low = 0, high = 0;
6212 if (TYPE_MIN_VALUE (t))
6213 low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6214 if (TYPE_MAX_VALUE (t))
6215 high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6217 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6221 TYPE_MIN_VALUE (t) = low;
6222 TYPE_MAX_VALUE (t) = high;
6227 tem = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6228 if (tem == TREE_TYPE (t))
6231 return build_complex_type (tem);
6239 /* Don't know how to do these yet. */
6244 tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6245 tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r);
6247 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
6250 new = build_array_type (component, domain);
6251 TYPE_SIZE (new) = 0;
6252 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
6253 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
6255 TYPE_ALIGN (new) = TYPE_ALIGN (t);
6261 case QUAL_UNION_TYPE:
6265 = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t)));
6266 int field_has_rep = 0;
6267 tree last_field = 0;
6269 tree new = copy_type (t);
6271 /* Start out with no fields, make new fields, and chain them
6272 in. If we haven't actually changed the type of any field,
6273 discard everything we've done and return the old type. */
6275 TYPE_FIELDS (new) = 0;
6276 TYPE_SIZE (new) = 0;
6278 for (field = TYPE_FIELDS (t); field;
6279 field = TREE_CHAIN (field))
6281 tree new_field = copy_node (field);
6283 TREE_TYPE (new_field)
6284 = gnat_substitute_in_type (TREE_TYPE (new_field), f, r);
6286 if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field))
6288 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
6291 /* If this is an internal field and the type of this field is
6292 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
6293 the type just has one element, treat that as the field.
6294 But don't do this if we are processing a QUAL_UNION_TYPE. */
6295 if (TREE_CODE (t) != QUAL_UNION_TYPE
6296 && DECL_INTERNAL_P (new_field)
6297 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
6298 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
6300 if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0)
6303 if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0)
6306 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
6308 /* Make sure omitting the union doesn't change
6310 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
6311 new_field = next_new_field;
6315 DECL_CONTEXT (new_field) = new;
6316 SET_DECL_ORIGINAL_FIELD (new_field,
6317 (DECL_ORIGINAL_FIELD (field) != 0
6318 ? DECL_ORIGINAL_FIELD (field) : field));
6320 /* If the size of the old field was set at a constant,
6321 propagate the size in case the type's size was variable.
6322 (This occurs in the case of a variant or discriminated
6323 record with a default size used as a field of another
6325 DECL_SIZE (new_field)
6326 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
6327 ? DECL_SIZE (field) : 0;
6328 DECL_SIZE_UNIT (new_field)
6329 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
6330 ? DECL_SIZE_UNIT (field) : 0;
6332 if (TREE_CODE (t) == QUAL_UNION_TYPE)
6334 tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r);
6336 if (new_q != DECL_QUALIFIER (new_field))
6339 /* Do the substitution inside the qualifier and if we find
6340 that this field will not be present, omit it. */
6341 DECL_QUALIFIER (new_field) = new_q;
6343 if (integer_zerop (DECL_QUALIFIER (new_field)))
6347 if (last_field == 0)
6348 TYPE_FIELDS (new) = new_field;
6350 TREE_CHAIN (last_field) = new_field;
6352 last_field = new_field;
6354 /* If this is a qualified type and this field will always be
6355 present, we are done. */
6356 if (TREE_CODE (t) == QUAL_UNION_TYPE
6357 && integer_onep (DECL_QUALIFIER (new_field)))
6361 /* If this used to be a qualified union type, but we now know what
6362 field will be present, make this a normal union. */
6363 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
6364 && (TYPE_FIELDS (new) == 0
6365 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
6366 TREE_SET_CODE (new, UNION_TYPE);
6367 else if (! changed_field)
6375 /* If the size was originally a constant use it. */
6376 if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
6377 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
6379 TYPE_SIZE (new) = TYPE_SIZE (t);
6380 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
6381 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
6392 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
6393 needed to represent the object. */
6396 rm_size (tree gnu_type)
6398 /* For integer types, this is the precision. For record types, we store
6399 the size explicitly. For other types, this is just the size. */
6401 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0)
6402 return TYPE_RM_SIZE (gnu_type);
6403 else if (TREE_CODE (gnu_type) == RECORD_TYPE
6404 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6405 /* Return the rm_size of the actual data plus the size of the template. */
6407 size_binop (PLUS_EXPR,
6408 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
6409 DECL_SIZE (TYPE_FIELDS (gnu_type)));
6410 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6411 || TREE_CODE (gnu_type) == UNION_TYPE
6412 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6413 && ! TYPE_IS_FAT_POINTER_P (gnu_type)
6414 && TYPE_ADA_SIZE (gnu_type) != 0)
6415 return TYPE_ADA_SIZE (gnu_type);
6417 return TYPE_SIZE (gnu_type);
6420 /* Return an identifier representing the external name to be used for
6421 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
6422 and the specified suffix. */
6425 create_concat_name (Entity_Id gnat_entity, const char *suffix)
6427 const char *str = (suffix == 0 ? "" : suffix);
6428 String_Template temp = {1, strlen (str)};
6429 Fat_Pointer fp = {str, &temp};
6431 Get_External_Name_With_Suffix (gnat_entity, fp);
6434 /* A variable using the Stdcall convention (meaning we are running
6435 on a Windows box) live in a DLL. Here we adjust its name to use
6436 the jump-table, the _imp__NAME contains the address for the NAME
6440 Entity_Kind kind = Ekind (gnat_entity);
6441 const char *prefix = "_imp__";
6442 int plen = strlen (prefix);
6444 if ((kind == E_Variable || kind == E_Constant)
6445 && Convention (gnat_entity) == Convention_Stdcall)
6448 for (k = 0; k <= Name_Len; k++)
6449 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
6450 strncpy (Name_Buffer, prefix, plen);
6455 return get_identifier (Name_Buffer);
6458 /* Return the name to be used for GNAT_ENTITY. If a type, create a
6459 fully-qualified name, possibly with type information encoding.
6460 Otherwise, return the name. */
6463 get_entity_name (Entity_Id gnat_entity)
6465 Get_Encoded_Name (gnat_entity);
6466 return get_identifier (Name_Buffer);
6469 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
6470 string, return a new IDENTIFIER_NODE that is the concatenation of
6471 the name in GNU_ID and SUFFIX. */
6474 concat_id_with_name (tree gnu_id, const char *suffix)
6476 int len = IDENTIFIER_LENGTH (gnu_id);
6478 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
6479 IDENTIFIER_LENGTH (gnu_id));
6480 strncpy (Name_Buffer + len, "___", 3);
6482 strcpy (Name_Buffer + len, suffix);
6483 return get_identifier (Name_Buffer);
6486 #include "gt-ada-decl.h"