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"
55 /* Provide default values for the macros controlling stack checking.
56 This is copied from GCC's expr.h. */
58 #ifndef STACK_CHECK_BUILTIN
59 #define STACK_CHECK_BUILTIN 0
61 #ifndef STACK_CHECK_PROBE_INTERVAL
62 #define STACK_CHECK_PROBE_INTERVAL 4096
64 #ifndef STACK_CHECK_MAX_FRAME_SIZE
65 #define STACK_CHECK_MAX_FRAME_SIZE \
66 (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
68 #ifndef STACK_CHECK_MAX_VAR_SIZE
69 #define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
72 /* These two variables are used to defer recursively expanding incomplete
73 types while we are processing a record or subprogram type. */
75 static int defer_incomplete_level = 0;
76 static struct incomplete
78 struct incomplete *next;
81 } *defer_incomplete_list = 0;
83 static void copy_alias_set (tree, tree);
84 static tree substitution_list (Entity_Id, Entity_Id, tree, int);
85 static int allocatable_size_p (tree, int);
86 static struct attrib *build_attr_list (Entity_Id);
87 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
88 static int is_variable_size (tree);
89 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
91 static tree make_packable_type (tree);
92 static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *,
94 static tree gnat_to_gnu_field (Entity_Id, tree, int, int);
95 static void components_to_record (tree, Node_Id, tree, int, int, tree *,
97 static int compare_field_bitpos (const PTR, const PTR);
98 static Uint annotate_value (tree);
99 static void annotate_rep (Entity_Id, tree);
100 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
101 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, int, int);
102 static void set_rm_size (Uint, tree, Entity_Id);
103 static tree make_type_from_size (tree, tree, int);
104 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
105 static void check_ok_for_atomic (tree, Entity_Id, int);
107 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
108 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
109 refer to an Ada type. */
112 gnat_to_gnu_type (Entity_Id gnat_entity)
116 /* The back end never attempts to annotate generic types */
117 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
118 return void_type_node;
120 /* Convert the ada entity type into a GCC TYPE_DECL node. */
121 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
122 if (TREE_CODE (gnu_decl) != TYPE_DECL)
125 return TREE_TYPE (gnu_decl);
128 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
129 entity, this routine returns the equivalent GCC tree for that entity
130 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
133 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
134 initial value (in GCC tree form). This is optional for variables.
135 For renamed entities, GNU_EXPR gives the object being renamed.
137 DEFINITION is nonzero if this call is intended for a definition. This is
138 used for separate compilation where it necessary to know whether an
139 external declaration or a definition should be created if the GCC equivalent
140 was not created previously. The value of 1 is normally used for a non-zero
141 DEFINITION, but a value of 2 is used in special circumstances, defined in
145 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
149 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
150 GNAT tree. This node will be associated with the GNAT node by calling
151 the save_gnu_tree routine at the end of the `switch' statement. */
153 /* Nonzero if we have already saved gnu_decl as a gnat association. */
155 /* Nonzero if we incremented defer_incomplete_level. */
156 int this_deferred = 0;
157 /* Nonzero if we incremented force_global. */
159 /* Nonzero if we should check to see if elaborated during processing. */
160 int maybe_present = 0;
161 /* Nonzero if we made GNU_DECL and its type here. */
162 int this_made_decl = 0;
163 struct attrib *attr_list = 0;
164 int debug_info_p = (Needs_Debug_Info (gnat_entity)
165 || debug_info_level == DINFO_LEVEL_VERBOSE);
166 Entity_Kind kind = Ekind (gnat_entity);
169 = ((Known_Esize (gnat_entity)
170 && UI_Is_In_Int_Range (Esize (gnat_entity)))
171 ? MIN (UI_To_Int (Esize (gnat_entity)),
172 IN (kind, Float_Kind)
173 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
174 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
175 : LONG_LONG_TYPE_SIZE)
176 : LONG_LONG_TYPE_SIZE);
179 = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
180 || From_With_Type (gnat_entity));
181 unsigned int align = 0;
183 /* Since a use of an Itype is a definition, process it as such if it
184 is not in a with'ed unit. */
186 if (! definition && Is_Itype (gnat_entity)
187 && ! present_gnu_tree (gnat_entity)
188 && In_Extended_Main_Code_Unit (gnat_entity))
190 /* Ensure that we are in a subprogram mentioned in the Scope
191 chain of this entity, our current scope is global,
192 or that we encountered a task or entry (where we can't currently
193 accurately check scoping). */
194 if (current_function_decl == 0
195 || DECL_ELABORATION_PROC_P (current_function_decl))
197 process_type (gnat_entity);
198 return get_gnu_tree (gnat_entity);
201 for (gnat_temp = Scope (gnat_entity);
202 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
204 if (Is_Type (gnat_temp))
205 gnat_temp = Underlying_Type (gnat_temp);
207 if (Ekind (gnat_temp) == E_Subprogram_Body)
209 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
211 if (IN (Ekind (gnat_temp), Subprogram_Kind)
212 && Present (Protected_Body_Subprogram (gnat_temp)))
213 gnat_temp = Protected_Body_Subprogram (gnat_temp);
215 if (Ekind (gnat_temp) == E_Entry
216 || Ekind (gnat_temp) == E_Entry_Family
217 || Ekind (gnat_temp) == E_Task_Type
218 || (IN (Ekind (gnat_temp), Subprogram_Kind)
219 && present_gnu_tree (gnat_temp)
220 && (current_function_decl
221 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
223 process_type (gnat_entity);
224 return get_gnu_tree (gnat_entity);
228 /* gigi abort 122 means that the entity "gnat_entity" has an incorrect
229 scope, i.e. that its scope does not correspond to the subprogram
230 in which it is declared */
234 /* If this is entity 0, something went badly wrong. */
235 if (gnat_entity == 0)
238 /* If we've already processed this entity, return what we got last time.
239 If we are defining the node, we should not have already processed it.
240 In that case, we will abort below when we try to save a new GCC tree for
241 this object. We also need to handle the case of getting a dummy type
242 when a Full_View exists. */
244 if (present_gnu_tree (gnat_entity)
246 || (Is_Type (gnat_entity) && imported_p)))
248 gnu_decl = get_gnu_tree (gnat_entity);
250 if (TREE_CODE (gnu_decl) == TYPE_DECL
251 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
252 && IN (kind, Incomplete_Or_Private_Kind)
253 && Present (Full_View (gnat_entity)))
255 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
258 save_gnu_tree (gnat_entity, NULL_TREE, 0);
259 save_gnu_tree (gnat_entity, gnu_decl, 0);
265 /* If this is a numeric or enumeral type, or an access type, a nonzero
266 Esize must be specified unless it was specified by the programmer. */
267 if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind)
268 || (IN (kind, Access_Kind)
269 && kind != E_Access_Protected_Subprogram_Type
270 && kind != E_Access_Subtype))
271 && Unknown_Esize (gnat_entity)
272 && ! Has_Size_Clause (gnat_entity))
275 /* Likewise, RM_Size must be specified for all discrete and fixed-point
277 if (IN (kind, Discrete_Or_Fixed_Point_Kind)
278 && Unknown_RM_Size (gnat_entity))
281 /* Get the name of the entity and set up the line number and filename of
282 the original definition for use in any decl we make. */
283 gnu_entity_id = get_entity_name (gnat_entity);
284 Sloc_to_locus (Sloc (gnat_entity), &input_location);
286 /* If we get here, it means we have not yet done anything with this
287 entity. If we are not defining it here, it must be external,
288 otherwise we should have defined it already. */
289 if (! definition && ! Is_Public (gnat_entity)
290 && ! type_annotate_only
291 && kind != E_Discriminant && kind != E_Component
293 && ! (kind == E_Constant && Present (Full_View (gnat_entity)))
295 && !IN (kind, Type_Kind)
300 /* For cases when we are not defining (i.e., we are referencing from
301 another compilation unit) Public entities, show we are at global level
302 for the purpose of computing scopes. Don't do this for components or
303 discriminants since the relevant test is whether or not the record is
304 being defined. But do this for Imported functions or procedures in
306 if ((! definition && Is_Public (gnat_entity)
307 && ! Is_Statically_Allocated (gnat_entity)
308 && kind != E_Discriminant && kind != E_Component)
309 || (Is_Imported (gnat_entity)
310 && (kind == E_Function || kind == E_Procedure)))
311 force_global++, this_global = 1;
313 /* Handle any attributes. */
314 if (Has_Gigi_Rep_Item (gnat_entity))
315 attr_list = build_attr_list (gnat_entity);
320 /* If this is a use of a deferred constant, get its full
322 if (! definition && Present (Full_View (gnat_entity)))
324 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
325 gnu_expr, definition);
330 /* If we have an external constant that we are not defining,
331 get the expression that is was defined to represent. We
332 may throw that expression away later if it is not a
334 Do not retrieve the expression if it is an aggregate, because
335 in complex instantiation contexts it may not be expanded */
338 && Present (Expression (Declaration_Node (gnat_entity)))
339 && ! No_Initialization (Declaration_Node (gnat_entity))
340 && Nkind (Expression (Declaration_Node (gnat_entity)))
342 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
344 /* Ignore deferred constant definitions; they are processed fully in the
345 front-end. For deferred constant references, get the full
346 definition. On the other hand, constants that are renamings are
347 handled like variable renamings. If No_Initialization is set, this is
348 not a deferred constant but a constant whose value is built
351 if (definition && gnu_expr == 0
352 && ! No_Initialization (Declaration_Node (gnat_entity))
353 && No (Renamed_Object (gnat_entity)))
355 gnu_decl = error_mark_node;
359 else if (! definition && IN (kind, Incomplete_Or_Private_Kind)
360 && Present (Full_View (gnat_entity)))
362 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
371 /* We used to special case VMS exceptions here to directly map them to
372 their associated condition code. Since this code had to be masked
373 dynamically to strip off the severity bits, this caused trouble in
374 the GCC/ZCX case because the "type" pointers we store in the tables
375 have to be static. We now don't special case here anymore, and let
376 the regular processing take place, which leaves us with a regular
377 exception data object for VMS exceptions too. The condition code
378 mapping is taken care of by the front end and the bitmasking by the
385 /* The GNAT record where the component was defined. */
386 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
388 /* If the variable is an inherited record component (in the case of
389 extended record types), just return the inherited entity, which
390 must be a FIELD_DECL. Likewise for discriminants.
391 For discriminants of untagged records which have explicit
392 stored discriminants, return the entity for the corresponding
393 stored discriminant. Also use Original_Record_Component
394 if the record has a private extension. */
396 if ((Base_Type (gnat_record) == gnat_record
397 || Ekind (Scope (gnat_entity)) == E_Private_Subtype
398 || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
399 || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
400 && Present (Original_Record_Component (gnat_entity))
401 && Original_Record_Component (gnat_entity) != gnat_entity)
404 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
405 gnu_expr, definition);
410 /* If the enclosing record has explicit stored discriminants,
411 then it is an untagged record. If the Corresponding_Discriminant
412 is not empty then this must be a renamed discriminant and its
413 Original_Record_Component must point to the corresponding explicit
414 stored discriminant (i.e., we should have taken the previous
417 else if (Present (Corresponding_Discriminant (gnat_entity))
418 && Is_Tagged_Type (gnat_record))
420 /* A tagged record has no explicit stored discriminants. */
422 if (First_Discriminant (gnat_record)
423 != First_Stored_Discriminant (gnat_record))
427 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
428 gnu_expr, definition);
433 /* If the enclosing record has explicit stored discriminants,
434 then it is an untagged record. If the Corresponding_Discriminant
435 is not empty then this must be a renamed discriminant and its
436 Original_Record_Component must point to the corresponding explicit
437 stored discriminant (i.e., we should have taken the first
440 else if (Present (Corresponding_Discriminant (gnat_entity))
441 && (First_Discriminant (gnat_record)
442 != First_Stored_Discriminant (gnat_record)))
445 /* Otherwise, if we are not defining this and we have no GCC type
446 for the containing record, make one for it. Then we should
447 have made our own equivalent. */
448 else if (! definition && ! present_gnu_tree (gnat_record))
450 /* ??? If this is in a record whose scope is a protected
451 type and we have an Original_Record_Component, use it.
452 This is a workaround for major problems in protected type
455 Entity_Id Scop = Scope (Scope (gnat_entity));
456 if ((Is_Protected_Type (Scop)
457 || (Is_Private_Type (Scop)
458 && Present (Full_View (Scop))
459 && Is_Protected_Type (Full_View (Scop))))
460 && Present (Original_Record_Component (gnat_entity)))
463 = gnat_to_gnu_entity (Original_Record_Component
465 gnu_expr, definition);
470 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
471 gnu_decl = get_gnu_tree (gnat_entity);
476 /* Here we have no GCC type and this is a reference rather than a
477 definition. This should never happen. Most likely the cause is a
478 reference before declaration in the gnat tree for gnat_entity. */
483 case E_Loop_Parameter:
484 case E_Out_Parameter:
487 /* Simple variables, loop variables, OUT parameters, and exceptions. */
492 = ((kind == E_Constant || kind == E_Variable)
493 && ! Is_Statically_Allocated (gnat_entity)
494 && Is_True_Constant (gnat_entity)
495 && (((Nkind (Declaration_Node (gnat_entity))
496 == N_Object_Declaration)
497 && Present (Expression (Declaration_Node (gnat_entity))))
498 || Present (Renamed_Object (gnat_entity))));
499 int inner_const_flag = const_flag;
500 int static_p = Is_Statically_Allocated (gnat_entity);
501 tree gnu_ext_name = NULL_TREE;
503 if (Present (Renamed_Object (gnat_entity)) && ! definition)
505 if (kind == E_Exception)
506 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
509 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
512 /* Get the type after elaborating the renamed object. */
513 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
515 /* If this is a loop variable, its type should be the base type.
516 This is because the code for processing a loop determines whether
517 a normal loop end test can be done by comparing the bounds of the
518 loop against those of the base type, which is presumed to be the
519 size used for computation. But this is not correct when the size
520 of the subtype is smaller than the type. */
521 if (kind == E_Loop_Parameter)
522 gnu_type = get_base_type (gnu_type);
524 /* Reject non-renamed objects whose types are unconstrained arrays or
525 any object whose type is a dummy type or VOID_TYPE. */
527 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
528 && No (Renamed_Object (gnat_entity)))
529 || TYPE_IS_DUMMY_P (gnu_type)
530 || TREE_CODE (gnu_type) == VOID_TYPE)
532 if (type_annotate_only)
533 return error_mark_node;
538 /* If we are defining the object, see if it has a Size value and
539 validate it if so. If we are not defining the object and a Size
540 clause applies, simply retrieve the value. We don't want to ignore
541 the clause and it is expected to have been validated already. Then
542 get the new type, if any. */
544 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
545 gnat_entity, VAR_DECL, 0,
546 Has_Size_Clause (gnat_entity));
547 else if (Has_Size_Clause (gnat_entity))
548 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
553 = make_type_from_size (gnu_type, gnu_size,
554 Has_Biased_Representation (gnat_entity));
556 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
560 /* If this object has self-referential size, it must be a record with
561 a default value. We are supposed to allocate an object of the
562 maximum size in this case unless it is a constant with an
563 initializing expression, in which case we can get the size from
564 that. Note that the resulting size may still be a variable, so
565 this may end up with an indirect allocation. */
567 if (No (Renamed_Object (gnat_entity))
568 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
570 if (gnu_expr != 0 && kind == E_Constant)
572 = SUBSTITUTE_PLACEHOLDER_IN_EXPR
573 (TYPE_SIZE (TREE_TYPE (gnu_expr)), gnu_expr);
575 /* We may have no GNU_EXPR because No_Initialization is
576 set even though there's an Expression. */
577 else if (kind == E_Constant
578 && (Nkind (Declaration_Node (gnat_entity))
579 == N_Object_Declaration)
580 && Present (Expression (Declaration_Node (gnat_entity))))
582 = TYPE_SIZE (gnat_to_gnu_type
584 (Expression (Declaration_Node (gnat_entity)))));
586 gnu_size = max_size (TYPE_SIZE (gnu_type), 1);
589 /* If the size is zero bytes, make it one byte since some linkers have
590 trouble with zero-sized objects. If the object will have a
591 template, that will make it nonzero so don't bother. Also avoid
592 doing that for an object renaming or an object with an address
593 clause, as we would lose useful information on the view size
594 (e.g. for null array slices) and we are not allocating the object
596 if (((gnu_size != 0 && integer_zerop (gnu_size))
597 || (TYPE_SIZE (gnu_type) != 0
598 && integer_zerop (TYPE_SIZE (gnu_type))))
599 && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
600 || ! Is_Array_Type (Etype (gnat_entity)))
601 && ! Present (Renamed_Object (gnat_entity))
602 && ! Present (Address_Clause (gnat_entity)))
603 gnu_size = bitsize_unit_node;
605 /* If an alignment is specified, use it if valid. Note that
606 exceptions are objects but don't have alignments. */
607 if (kind != E_Exception && Known_Alignment (gnat_entity))
609 if (No (Alignment (gnat_entity)))
613 = validate_alignment (Alignment (gnat_entity), gnat_entity,
614 TYPE_ALIGN (gnu_type));
617 /* If this is an atomic object with no specified size and alignment,
618 but where the size of the type is a constant, set the alignment to
619 the lowest power of two greater than the size, or to the
620 biggest meaningful alignment, whichever is smaller. */
622 if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0
623 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
625 if (! host_integerp (TYPE_SIZE (gnu_type), 1)
626 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
628 align = BIGGEST_ALIGNMENT;
630 align = ((unsigned int) 1
631 << (floor_log2 (tree_low_cst
632 (TYPE_SIZE (gnu_type), 1) - 1)
636 /* If the object is set to have atomic components, find the component
637 type and validate it.
639 ??? Note that we ignore Has_Volatile_Components on objects; it's
640 not at all clear what to do in that case. */
642 if (Has_Atomic_Components (gnat_entity))
645 = (TREE_CODE (gnu_type) == ARRAY_TYPE
646 ? TREE_TYPE (gnu_type) : gnu_type);
648 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
649 && TYPE_MULTI_ARRAY_P (gnu_inner))
650 gnu_inner = TREE_TYPE (gnu_inner);
652 check_ok_for_atomic (gnu_inner, gnat_entity, 1);
655 /* Now check if the type of the object allows atomic access. Note
656 that we must test the type, even if this object has size and
657 alignment to allow such access, because we will be going
658 inside the padded record to assign to the object. We could fix
659 this by always copying via an intermediate value, but it's not
660 clear it's worth the effort. */
661 if (Is_Atomic (gnat_entity))
662 check_ok_for_atomic (gnu_type, gnat_entity, 0);
664 /* If this is an aliased object with an unconstrained nominal subtype,
665 make a type that includes the template. */
666 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
667 && Is_Array_Type (Etype (gnat_entity))
668 && ! type_annotate_only)
671 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
673 = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
676 = build_unc_object_type (gnu_temp_type, gnu_type,
677 concat_id_with_name (gnu_entity_id,
681 #ifdef MINIMUM_ATOMIC_ALIGNMENT
682 /* If the size is a constant and no alignment is specified, force
683 the alignment to be the minimum valid atomic alignment. The
684 restriction on constant size avoids problems with variable-size
685 temporaries; if the size is variable, there's no issue with
686 atomic access. Also don't do this for a constant, since it isn't
687 necessary and can interfere with constant replacement. Finally,
688 do not do it for Out parameters since that creates an
689 size inconsistency with In parameters. */
690 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
691 && ! FLOAT_TYPE_P (gnu_type)
692 && ! const_flag && No (Renamed_Object (gnat_entity))
693 && ! imported_p && No (Address_Clause (gnat_entity))
694 && kind != E_Out_Parameter
695 && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
696 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
697 align = MINIMUM_ATOMIC_ALIGNMENT;
700 /* Make a new type with the desired size and alignment, if needed. */
701 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
702 gnat_entity, "PAD", 0, definition, 1);
704 /* Make a volatile version of this object's type if we are to
705 make the object volatile. Note that 13.3(19) says that we
706 should treat other types of objects as volatile as well. */
707 if ((Treat_As_Volatile (gnat_entity)
708 || Is_Exported (gnat_entity)
709 || Is_Imported (gnat_entity)
710 || Present (Address_Clause (gnat_entity)))
711 && ! TYPE_VOLATILE (gnu_type))
712 gnu_type = build_qualified_type (gnu_type,
713 (TYPE_QUALS (gnu_type)
714 | TYPE_QUAL_VOLATILE));
716 /* Convert the expression to the type of the object except in the
717 case where the object's type is unconstrained or the object's type
718 is a padded record whose field is of self-referential size. In
719 the former case, converting will generate unnecessary evaluations
720 of the CONSTRUCTOR to compute the size and in the latter case, we
721 want to only copy the actual data. */
723 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
724 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
725 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
726 && TYPE_IS_PADDING_P (gnu_type)
727 && (CONTAINS_PLACEHOLDER_P
728 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
729 gnu_expr = convert (gnu_type, gnu_expr);
731 /* See if this is a renaming. If this is a constant renaming,
732 treat it as a normal variable whose initial value is what
733 is being renamed. We cannot do this if the type is
734 unconstrained or class-wide.
736 Otherwise, if what we are renaming is a reference, we can simply
737 return a stabilized version of that reference, after forcing
738 any SAVE_EXPRs to be evaluated. But, if this is at global level,
739 we can only do this if we know no SAVE_EXPRs will be made.
740 Otherwise, make this into a constant pointer to the object we are
743 if (Present (Renamed_Object (gnat_entity)))
745 /* If the renamed object had padding, strip off the reference
746 to the inner object and reset our type. */
747 if (TREE_CODE (gnu_expr) == COMPONENT_REF
748 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
750 && (TYPE_IS_PADDING_P
751 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
753 gnu_expr = TREE_OPERAND (gnu_expr, 0);
754 gnu_type = TREE_TYPE (gnu_expr);
758 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
759 && TYPE_MODE (gnu_type) != BLKmode
760 && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
761 && !Is_Array_Type (Etype (gnat_entity)))
764 /* If this is a declaration or reference, we can just use that
765 declaration or reference as this entity. */
766 else if ((DECL_P (gnu_expr)
767 || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r')
768 && ! Materialize_Entity (gnat_entity)
769 && (! global_bindings_p ()
770 || (staticp (gnu_expr)
771 && ! TREE_SIDE_EFFECTS (gnu_expr))))
773 gnu_decl = gnat_stabilize_reference (gnu_expr, 1);
774 save_gnu_tree (gnat_entity, gnu_decl, 1);
780 inner_const_flag = TREE_READONLY (gnu_expr);
782 gnu_type = build_reference_type (gnu_type);
783 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
789 /* If this is an aliased object whose nominal subtype is unconstrained,
790 the object is a record that contains both the template and
791 the object. If there is an initializer, it will have already
792 been converted to the right type, but we need to create the
793 template if there is no initializer. */
794 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
795 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
796 /* Beware that padding might have been introduced
797 via maybe_pad_type above. */
798 || (TYPE_IS_PADDING_P (gnu_type)
799 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
801 && TYPE_CONTAINS_TEMPLATE_P
802 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
806 = TYPE_IS_PADDING_P (gnu_type)
807 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
808 : TYPE_FIELDS (gnu_type);
811 = gnat_build_constructor
815 build_template (TREE_TYPE (template_field),
816 TREE_TYPE (TREE_CHAIN (template_field)),
821 /* If this is a pointer and it does not have an initializing
822 expression, initialize it to NULL, unless the obect is
825 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
826 && !Is_Imported (gnat_entity)
828 gnu_expr = integer_zero_node;
830 /* If we are defining the object and it has an Address clause we must
831 get the address expression from the saved GCC tree for the
832 object if the object has a Freeze_Node. Otherwise, we elaborate
833 the address expression here since the front-end has guaranteed
834 in that case that the elaboration has no effects. Note that
835 only the latter mechanism is currently in use. */
836 if (definition && Present (Address_Clause (gnat_entity)))
839 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
840 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
842 save_gnu_tree (gnat_entity, NULL_TREE, 0);
844 /* Ignore the size. It's either meaningless or was handled
847 gnu_type = build_reference_type (gnu_type);
848 gnu_address = convert (gnu_type, gnu_address);
850 const_flag = ! Is_Public (gnat_entity);
852 /* If we don't have an initializing expression for the underlying
853 variable, the initializing expression for the pointer is the
854 specified address. Otherwise, we have to make a COMPOUND_EXPR
855 to assign both the address and the initial value. */
857 gnu_expr = gnu_address;
860 = build (COMPOUND_EXPR, gnu_type,
862 (MODIFY_EXPR, NULL_TREE,
863 build_unary_op (INDIRECT_REF, NULL_TREE,
869 /* If it has an address clause and we are not defining it, mark it
870 as an indirect object. Likewise for Stdcall objects that are
872 if ((! definition && Present (Address_Clause (gnat_entity)))
873 || (Is_Imported (gnat_entity)
874 && Convention (gnat_entity) == Convention_Stdcall))
876 gnu_type = build_reference_type (gnu_type);
881 /* If we are at top level and this object is of variable size,
882 make the actual type a hidden pointer to the real type and
883 make the initializer be a memory allocation and initialization.
884 Likewise for objects we aren't defining (presumed to be
885 external references from other packages), but there we do
886 not set up an initialization.
888 If the object's size overflows, make an allocator too, so that
889 Storage_Error gets raised. Note that we will never free
890 such memory, so we presume it never will get allocated. */
892 if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
893 global_bindings_p () || ! definition
896 && ! allocatable_size_p (gnu_size,
897 global_bindings_p () || ! definition
900 gnu_type = build_reference_type (gnu_type);
905 /* Get the data part of GNU_EXPR in case this was a
906 aliased object whose nominal subtype is unconstrained.
907 In that case the pointer above will be a thin pointer and
908 build_allocator will automatically make the template and
909 constructor already made above. */
913 tree gnu_alloc_type = TREE_TYPE (gnu_type);
915 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
916 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
919 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
921 = build_component_ref
922 (gnu_expr, NULL_TREE,
923 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0);
926 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
927 && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
928 && ! Is_Imported (gnat_entity))
929 post_error ("Storage_Error will be raised at run-time?",
932 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
933 gnu_type, 0, 0, gnat_entity);
942 /* If this object would go into the stack and has an alignment
943 larger than the default largest alignment, make a variable
944 to hold the "aligning type" with a modified initial value,
945 if any, then point to it and make that the value of this
946 variable, which is now indirect. */
948 if (! global_bindings_p () && ! static_p && definition
949 && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
952 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
953 TYPE_SIZE_UNIT (gnu_type));
957 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
958 NULL_TREE, gnu_new_type, gnu_expr,
959 0, 0, 0, 0, 0, gnat_entity);
963 (build_binary_op (MODIFY_EXPR, NULL_TREE,
965 (gnu_new_var, NULL_TREE,
966 TYPE_FIELDS (gnu_new_type), 0),
970 gnu_type = build_reference_type (gnu_type);
973 (ADDR_EXPR, gnu_type,
974 build_component_ref (gnu_new_var, NULL_TREE,
975 TYPE_FIELDS (gnu_new_type), 0));
982 /* Convert the expression to the type of the object except in the
983 case where the object's type is unconstrained or the object's type
984 is a padded record whose field is of self-referential size. In
985 the former case, converting will generate unnecessary evaluations
986 of the CONSTRUCTOR to compute the size and in the latter case, we
987 want to only copy the actual data. */
989 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
990 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
991 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
992 && TYPE_IS_PADDING_P (gnu_type)
993 && (CONTAINS_PLACEHOLDER_P
994 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
995 gnu_expr = convert (gnu_type, gnu_expr);
997 /* If this name is external or there was a name specified, use it,
998 unless this is a VMS exception object since this would conflict
999 with the symbol we need to export in addition. Don't use the
1000 Interface_Name if there is an address clause (see CD30005). */
1001 if (! Is_VMS_Exception (gnat_entity)
1003 ((Present (Interface_Name (gnat_entity))
1004 && No (Address_Clause (gnat_entity)))
1006 (Is_Public (gnat_entity)
1007 && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))))
1008 gnu_ext_name = create_concat_name (gnat_entity, 0);
1011 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1012 | TYPE_QUAL_CONST));
1014 /* If this is constant initialized to a static constant and the
1015 object has an aggregrate type, force it to be statically
1017 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1018 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1019 && (AGGREGATE_TYPE_P (gnu_type)
1020 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
1021 && TYPE_IS_PADDING_P (gnu_type))))
1024 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1025 gnu_expr, const_flag,
1026 Is_Public (gnat_entity),
1027 imported_p || !definition,
1028 static_p, attr_list, gnat_entity);
1029 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1030 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1032 /* If we have an address clause and we've made this indirect, it's
1033 not enough to merely mark the type as volatile since volatile
1034 references only conflict with other volatile references while this
1035 reference must conflict with all other references. So ensure that
1036 the dereferenced value has alias set 0. */
1037 if (Present (Address_Clause (gnat_entity)) && used_by_ref)
1038 DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
1040 if (definition && DECL_SIZE (gnu_decl) != 0
1041 && get_block_jmpbuf_decl ()
1042 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1043 || (flag_stack_check && ! STACK_CHECK_BUILTIN
1044 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1045 STACK_CHECK_MAX_VAR_SIZE))))
1046 add_stmt_with_node (build_call_1_expr
1047 (update_setjmp_buf_decl,
1048 build_unary_op (ADDR_EXPR, NULL_TREE,
1049 get_block_jmpbuf_decl ())),
1052 /* If this is a public constant or we're not optimizing and we're not
1053 making a VAR_DECL for it, make one just for export or debugger
1054 use. Likewise if the address is taken or if the object or type is
1056 if (definition && TREE_CODE (gnu_decl) == CONST_DECL
1057 && (Is_Public (gnat_entity)
1059 || Address_Taken (gnat_entity)
1060 || Is_Aliased (gnat_entity)
1061 || Is_Aliased (Etype (gnat_entity))))
1064 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1065 gnu_expr, 0, Is_Public (gnat_entity), 0,
1066 static_p, 0, gnat_entity);
1068 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1071 /* If this is declared in a block that contains an block with an
1072 exception handler, we must force this variable in memory to
1073 suppress an invalid optimization. */
1074 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1075 && Exception_Mechanism != GCC_ZCX)
1076 TREE_ADDRESSABLE (gnu_decl) = 1;
1078 /* Back-annotate the Alignment of the object if not already in the
1079 tree. Likewise for Esize if the object is of a constant size.
1080 But if the "object" is actually a pointer to an object, the
1081 alignment and size are the same as teh type, so don't back-annotate
1082 the values for the pointer. */
1083 if (! used_by_ref && Unknown_Alignment (gnat_entity))
1084 Set_Alignment (gnat_entity,
1085 UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT));
1087 if (! used_by_ref && Unknown_Esize (gnat_entity)
1088 && DECL_SIZE (gnu_decl) != 0)
1090 tree gnu_back_size = DECL_SIZE (gnu_decl);
1092 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
1093 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl)))
1095 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN
1096 (TYPE_FIELDS (TREE_TYPE (gnu_decl)))));
1098 Set_Esize (gnat_entity, annotate_value (gnu_back_size));
1104 /* Return a TYPE_DECL for "void" that we previously made. */
1105 gnu_decl = void_type_decl_node;
1108 case E_Enumeration_Type:
1109 /* A special case, for the types Character and Wide_Character in
1110 Standard, we do not list all the literals. So if the literals
1111 are not specified, make this an unsigned type. */
1112 if (No (First_Literal (gnat_entity)))
1114 gnu_type = make_unsigned_type (esize);
1118 /* Normal case of non-character type, or non-Standard character type */
1120 /* Here we have a list of enumeral constants in First_Literal.
1121 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1122 the list to be places into TYPE_FIELDS. Each node in the list
1123 is a TREE_LIST node whose TREE_VALUE is the literal name
1124 and whose TREE_PURPOSE is the value of the literal.
1126 Esize contains the number of bits needed to represent the enumeral
1127 type, Type_Low_Bound also points to the first literal and
1128 Type_High_Bound points to the last literal. */
1130 Entity_Id gnat_literal;
1131 tree gnu_literal_list = NULL_TREE;
1133 if (Is_Unsigned_Type (gnat_entity))
1134 gnu_type = make_unsigned_type (esize);
1136 gnu_type = make_signed_type (esize);
1138 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1140 for (gnat_literal = First_Literal (gnat_entity);
1141 Present (gnat_literal);
1142 gnat_literal = Next_Literal (gnat_literal))
1144 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1147 = create_var_decl (get_entity_name (gnat_literal),
1148 0, gnu_type, gnu_value, 1, 0, 0, 0, 0,
1151 save_gnu_tree (gnat_literal, gnu_literal, 0);
1152 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1153 gnu_value, gnu_literal_list);
1156 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1158 /* Note that the bounds are updated at the end of this function
1159 because to avoid an infinite recursion when we get the bounds of
1160 this type, since those bounds are objects of this type. */
1164 case E_Signed_Integer_Type:
1165 case E_Ordinary_Fixed_Point_Type:
1166 case E_Decimal_Fixed_Point_Type:
1167 /* For integer types, just make a signed type the appropriate number
1169 gnu_type = make_signed_type (esize);
1172 case E_Modular_Integer_Type:
1173 /* For modular types, make the unsigned type of the proper number of
1174 bits and then set up the modulus, if required. */
1176 enum machine_mode mode;
1180 if (Is_Packed_Array_Type (gnat_entity))
1181 esize = UI_To_Int (RM_Size (gnat_entity));
1183 /* Find the smallest mode at least ESIZE bits wide and make a class
1186 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1187 GET_MODE_BITSIZE (mode) < esize;
1188 mode = GET_MODE_WIDER_MODE (mode))
1191 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1192 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1193 = Is_Packed_Array_Type (gnat_entity);
1195 /* Get the modulus in this type. If it overflows, assume it is because
1196 it is equal to 2**Esize. Note that there is no overflow checking
1197 done on unsigned type, so we detect the overflow by looking for
1198 a modulus of zero, which is otherwise invalid. */
1199 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1201 if (! integer_zerop (gnu_modulus))
1203 TYPE_MODULAR_P (gnu_type) = 1;
1204 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1205 gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
1206 convert (gnu_type, integer_one_node)));
1209 /* If we have to set TYPE_PRECISION different from its natural value,
1210 make a subtype to do do. Likewise if there is a modulus and
1211 it is not one greater than TYPE_MAX_VALUE. */
1212 if (TYPE_PRECISION (gnu_type) != esize
1213 || (TYPE_MODULAR_P (gnu_type)
1214 && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1216 tree gnu_subtype = make_node (INTEGER_TYPE);
1218 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1219 TREE_TYPE (gnu_subtype) = gnu_type;
1220 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1221 TYPE_MAX_VALUE (gnu_subtype)
1222 = TYPE_MODULAR_P (gnu_type)
1223 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1224 TYPE_PRECISION (gnu_subtype) = esize;
1225 TYPE_UNSIGNED (gnu_subtype) = 1;
1226 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1227 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1228 = Is_Packed_Array_Type (gnat_entity);
1229 layout_type (gnu_subtype);
1231 gnu_type = gnu_subtype;
1236 case E_Signed_Integer_Subtype:
1237 case E_Enumeration_Subtype:
1238 case E_Modular_Integer_Subtype:
1239 case E_Ordinary_Fixed_Point_Subtype:
1240 case E_Decimal_Fixed_Point_Subtype:
1242 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1243 that we do not want to call build_range_type since we would
1244 like each subtype node to be distinct. This will be important
1245 when memory aliasing is implemented.
1247 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1248 parent type; this fact is used by the arithmetic conversion
1251 We elaborate the Ancestor_Subtype if it is not in the current
1252 unit and one of our bounds is non-static. We do this to ensure
1253 consistent naming in the case where several subtypes share the same
1254 bounds by always elaborating the first such subtype first, thus
1258 && Present (Ancestor_Subtype (gnat_entity))
1259 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1260 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1261 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1262 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1263 gnu_expr, definition);
1265 gnu_type = make_node (INTEGER_TYPE);
1266 if (Is_Packed_Array_Type (gnat_entity))
1268 esize = UI_To_Int (RM_Size (gnat_entity));
1269 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1272 TYPE_PRECISION (gnu_type) = esize;
1273 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1275 TYPE_MIN_VALUE (gnu_type)
1276 = convert (TREE_TYPE (gnu_type),
1277 elaborate_expression (Type_Low_Bound (gnat_entity),
1279 get_identifier ("L"), definition, 1,
1280 Needs_Debug_Info (gnat_entity)));
1282 TYPE_MAX_VALUE (gnu_type)
1283 = convert (TREE_TYPE (gnu_type),
1284 elaborate_expression (Type_High_Bound (gnat_entity),
1286 get_identifier ("U"), definition, 1,
1287 Needs_Debug_Info (gnat_entity)));
1289 /* One of the above calls might have caused us to be elaborated,
1290 so don't blow up if so. */
1291 if (present_gnu_tree (gnat_entity))
1297 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1298 = Has_Biased_Representation (gnat_entity);
1300 /* This should be an unsigned type if the lower bound is constant
1301 and non-negative or if the base type is unsigned; a signed type
1303 TYPE_UNSIGNED (gnu_type)
1304 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1305 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1306 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1307 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1308 || Is_Unsigned_Type (gnat_entity));
1310 layout_type (gnu_type);
1312 /* If the type we are dealing with is to represent a packed array,
1313 we need to have the bits left justified on big-endian targets
1314 (see exp_packd.ads). We build a record with a bitfield of the
1315 appropriate size to achieve this. */
1316 if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN)
1318 tree gnu_field_type = gnu_type;
1321 TYPE_RM_SIZE_INT (gnu_field_type)
1322 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1323 gnu_type = make_node (RECORD_TYPE);
1324 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM");
1325 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1326 TYPE_PACKED (gnu_type) = 1;
1328 /* Don't notify the field as "addressable", since we won't be taking
1329 it's address and it would prevent create_field_decl from making a
1331 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1332 gnu_field_type, gnu_type, 1, 0, 0, 0);
1334 finish_record_type (gnu_type, gnu_field, 0, 0);
1335 TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1336 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1341 case E_Floating_Point_Type:
1342 /* If this is a VAX floating-point type, use an integer of the proper
1343 size. All the operations will be handled with ASM statements. */
1344 if (Vax_Float (gnat_entity))
1346 gnu_type = make_signed_type (esize);
1347 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1348 SET_TYPE_DIGITS_VALUE (gnu_type,
1349 UI_To_gnu (Digits_Value (gnat_entity),
1354 /* The type of the Low and High bounds can be our type if this is
1355 a type from Standard, so set them at the end of the function. */
1356 gnu_type = make_node (REAL_TYPE);
1357 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1358 layout_type (gnu_type);
1361 case E_Floating_Point_Subtype:
1362 if (Vax_Float (gnat_entity))
1364 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1370 && Present (Ancestor_Subtype (gnat_entity))
1371 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1372 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1373 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1374 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1375 gnu_expr, definition);
1377 gnu_type = make_node (REAL_TYPE);
1378 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1379 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1381 TYPE_MIN_VALUE (gnu_type)
1382 = convert (TREE_TYPE (gnu_type),
1383 elaborate_expression (Type_Low_Bound (gnat_entity),
1384 gnat_entity, get_identifier ("L"),
1386 Needs_Debug_Info (gnat_entity)));
1388 TYPE_MAX_VALUE (gnu_type)
1389 = convert (TREE_TYPE (gnu_type),
1390 elaborate_expression (Type_High_Bound (gnat_entity),
1391 gnat_entity, get_identifier ("U"),
1393 Needs_Debug_Info (gnat_entity)));
1395 /* One of the above calls might have caused us to be elaborated,
1396 so don't blow up if so. */
1397 if (present_gnu_tree (gnat_entity))
1403 layout_type (gnu_type);
1407 /* Array and String Types and Subtypes
1409 Unconstrained array types are represented by E_Array_Type and
1410 constrained array types are represented by E_Array_Subtype. There
1411 are no actual objects of an unconstrained array type; all we have
1412 are pointers to that type.
1414 The following fields are defined on array types and subtypes:
1416 Component_Type Component type of the array.
1417 Number_Dimensions Number of dimensions (an int).
1418 First_Index Type of first index. */
1423 tree gnu_template_fields = NULL_TREE;
1424 tree gnu_template_type = make_node (RECORD_TYPE);
1425 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1426 tree gnu_fat_type = make_node (RECORD_TYPE);
1427 int ndim = Number_Dimensions (gnat_entity);
1429 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1431 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1432 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1433 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1434 tree gnu_comp_size = 0;
1435 tree gnu_max_size = size_one_node;
1436 tree gnu_max_size_unit;
1438 Entity_Id gnat_ind_subtype;
1439 Entity_Id gnat_ind_base_subtype;
1440 tree gnu_template_reference;
1443 TYPE_NAME (gnu_template_type)
1444 = create_concat_name (gnat_entity, "XUB");
1445 TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP");
1446 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1447 TYPE_READONLY (gnu_template_type) = 1;
1449 /* Make a node for the array. If we are not defining the array
1450 suppress expanding incomplete types and save the node as the type
1452 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1455 defer_incomplete_level++;
1456 this_deferred = this_made_decl = 1;
1457 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
1458 ! Comes_From_Source (gnat_entity),
1459 debug_info_p, gnat_entity);
1460 save_gnu_tree (gnat_entity, gnu_decl, 0);
1464 /* Build the fat pointer type. Use a "void *" object instead of
1465 a pointer to the array type since we don't have the array type
1466 yet (it will reference the fat pointer via the bounds). */
1467 tem = chainon (chainon (NULL_TREE,
1468 create_field_decl (get_identifier ("P_ARRAY"),
1470 gnu_fat_type, 0, 0, 0, 0)),
1471 create_field_decl (get_identifier ("P_BOUNDS"),
1473 gnu_fat_type, 0, 0, 0, 0));
1475 /* Make sure we can put this into a register. */
1476 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1477 finish_record_type (gnu_fat_type, tem, 0, 1);
1479 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1480 is the fat pointer. This will be used to access the individual
1481 fields once we build them. */
1482 tem = build (COMPONENT_REF, gnu_ptr_template,
1483 build (PLACEHOLDER_EXPR, gnu_fat_type),
1484 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1485 gnu_template_reference
1486 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1487 TREE_READONLY (gnu_template_reference) = 1;
1489 /* Now create the GCC type for each index and add the fields for
1490 that index to the template. */
1491 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1492 gnat_ind_base_subtype
1493 = First_Index (Implementation_Base_Type (gnat_entity));
1494 index < ndim && index >= 0;
1496 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1497 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1499 char field_name[10];
1500 tree gnu_ind_subtype
1501 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1502 tree gnu_base_subtype
1503 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1505 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1507 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1508 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1510 /* Make the FIELD_DECLs for the minimum and maximum of this
1511 type and then make extractions of that field from the
1513 sprintf (field_name, "LB%d", index);
1514 gnu_min_field = create_field_decl (get_identifier (field_name),
1516 gnu_template_type, 0, 0, 0, 0);
1517 field_name[0] = 'U';
1518 gnu_max_field = create_field_decl (get_identifier (field_name),
1520 gnu_template_type, 0, 0, 0, 0);
1522 Sloc_to_locus (Sloc (gnat_entity),
1523 &DECL_SOURCE_LOCATION (gnu_min_field));
1524 Sloc_to_locus (Sloc (gnat_entity),
1525 &DECL_SOURCE_LOCATION (gnu_max_field));
1526 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1528 /* We can't use build_component_ref here since the template
1529 type isn't complete yet. */
1530 gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
1531 gnu_template_reference, gnu_min_field, NULL_TREE);
1532 gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
1533 gnu_template_reference, gnu_max_field, NULL_TREE);
1534 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1536 /* Make a range type with the new ranges, but using
1537 the Ada subtype. Then we convert to sizetype. */
1538 gnu_index_types[index]
1539 = create_index_type (convert (sizetype, gnu_min),
1540 convert (sizetype, gnu_max),
1541 build_range_type (gnu_ind_subtype,
1543 /* Update the maximum size of the array, in elements. */
1545 = size_binop (MULT_EXPR, gnu_max_size,
1546 size_binop (PLUS_EXPR, size_one_node,
1547 size_binop (MINUS_EXPR, gnu_base_max,
1550 TYPE_NAME (gnu_index_types[index])
1551 = create_concat_name (gnat_entity, field_name);
1554 for (index = 0; index < ndim; index++)
1556 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1558 /* Install all the fields into the template. */
1559 finish_record_type (gnu_template_type, gnu_template_fields, 0, 0);
1560 TYPE_READONLY (gnu_template_type) = 1;
1562 /* Now make the array of arrays and update the pointer to the array
1563 in the fat pointer. Note that it is the first field. */
1565 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1567 /* Get and validate any specified Component_Size, but if Packed,
1568 ignore it since the front end will have taken care of it. */
1570 = validate_size (Component_Size (gnat_entity), tem,
1572 (Is_Bit_Packed_Array (gnat_entity)
1573 ? TYPE_DECL : VAR_DECL), 1,
1574 Has_Component_Size_Clause (gnat_entity));
1576 if (Has_Atomic_Components (gnat_entity))
1577 check_ok_for_atomic (tem, gnat_entity, 1);
1579 /* If the component type is a RECORD_TYPE that has a self-referential
1580 size, use the maxium size. */
1581 if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE
1582 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1583 gnu_comp_size = max_size (TYPE_SIZE (tem), 1);
1585 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1587 tem = make_type_from_size (tem, gnu_comp_size, 0);
1588 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1589 "C_PAD", 0, definition, 1);
1592 if (Has_Volatile_Components (gnat_entity))
1593 tem = build_qualified_type (tem,
1594 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1596 /* If Component_Size is not already specified, annotate it with the
1597 size of the component. */
1598 if (Unknown_Component_Size (gnat_entity))
1599 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1601 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1602 size_binop (MULT_EXPR, gnu_max_size,
1603 TYPE_SIZE_UNIT (tem)));
1604 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1605 size_binop (MULT_EXPR,
1606 convert (bitsizetype,
1610 for (index = ndim - 1; index >= 0; index--)
1612 tem = build_array_type (tem, gnu_index_types[index]);
1613 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1615 /* If the type below this an multi-array type, then this
1616 does not not have aliased components.
1618 ??? Otherwise, for now, we say that any component of aggregate
1619 type is addressable because the front end may take 'Reference
1620 of it. But we have to make it addressable if it must be passed
1621 by reference or it that is the default. */
1622 TYPE_NONALIASED_COMPONENT (tem)
1623 = ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
1624 && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
1625 : (! Has_Aliased_Components (gnat_entity)
1626 && ! AGGREGATE_TYPE_P (TREE_TYPE (tem))));
1629 /* If an alignment is specified, use it if valid. But ignore it for
1630 types that represent the unpacked base type for packed arrays. */
1631 if (No (Packed_Array_Type (gnat_entity))
1632 && Known_Alignment (gnat_entity))
1634 if (No (Alignment (gnat_entity)))
1638 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1642 TYPE_CONVENTION_FORTRAN_P (tem)
1643 = (Convention (gnat_entity) == Convention_Fortran);
1644 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1646 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1647 corresponding fat pointer. */
1648 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1649 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1650 TYPE_MODE (gnu_type) = BLKmode;
1651 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1652 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1654 /* If the maximum size doesn't overflow, use it. */
1655 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1656 && ! TREE_OVERFLOW (gnu_max_size))
1658 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
1659 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1660 && ! TREE_OVERFLOW (gnu_max_size_unit))
1661 TYPE_SIZE_UNIT (tem)
1662 = size_binop (MIN_EXPR, gnu_max_size_unit,
1663 TYPE_SIZE_UNIT (tem));
1665 create_type_decl (create_concat_name (gnat_entity, "XUA"),
1666 tem, 0, ! Comes_From_Source (gnat_entity),
1667 debug_info_p, gnat_entity);
1669 /* Create a record type for the object and its template and
1670 set the template at a negative offset. */
1671 tem = build_unc_object_type (gnu_template_type, tem,
1672 create_concat_name (gnat_entity, "XUT"));
1673 DECL_FIELD_OFFSET (TYPE_FIELDS (tem))
1674 = size_binop (MINUS_EXPR, size_zero_node,
1675 byte_position (TREE_CHAIN (TYPE_FIELDS (tem))));
1676 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node;
1677 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem)))
1678 = bitsize_zero_node;
1679 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
1680 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
1682 /* Give the thin pointer type a name. */
1683 create_type_decl (create_concat_name (gnat_entity, "XUX"),
1684 build_pointer_type (tem), 0,
1685 ! Comes_From_Source (gnat_entity), debug_info_p,
1690 case E_String_Subtype:
1691 case E_Array_Subtype:
1693 /* This is the actual data type for array variables. Multidimensional
1694 arrays are implemented in the gnu tree as arrays of arrays. Note
1695 that for the moment arrays which have sparse enumeration subtypes as
1696 index components create sparse arrays, which is obviously space
1697 inefficient but so much easier to code for now.
1699 Also note that the subtype never refers to the unconstrained
1700 array type, which is somewhat at variance with Ada semantics.
1702 First check to see if this is simply a renaming of the array
1703 type. If so, the result is the array type. */
1705 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1706 if (! Is_Constrained (gnat_entity))
1711 int array_dim = Number_Dimensions (gnat_entity);
1713 = ((Convention (gnat_entity) == Convention_Fortran)
1714 ? array_dim - 1 : 0);
1716 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
1717 Entity_Id gnat_ind_subtype;
1718 Entity_Id gnat_ind_base_subtype;
1719 tree gnu_base_type = gnu_type;
1720 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
1721 tree gnu_comp_size = 0;
1722 tree gnu_max_size = size_one_node;
1723 tree gnu_max_size_unit;
1724 int need_index_type_struct = 0;
1725 int max_overflow = 0;
1727 /* First create the gnu types for each index. Create types for
1728 debugging information to point to the index types if the
1729 are not integer types, have variable bounds, or are
1730 wider than sizetype. */
1732 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
1733 gnat_ind_base_subtype
1734 = First_Index (Implementation_Base_Type (gnat_entity));
1735 index < array_dim && index >= 0;
1737 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1738 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1740 tree gnu_index_subtype
1741 = get_unpadded_type (Etype (gnat_ind_subtype));
1743 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
1745 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
1746 tree gnu_base_subtype
1747 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1749 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1751 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1752 tree gnu_base_type = get_base_type (gnu_base_subtype);
1753 tree gnu_base_base_min
1754 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
1755 tree gnu_base_base_max
1756 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
1760 /* If the minimum and maximum values both overflow in
1761 SIZETYPE, but the difference in the original type
1762 does not overflow in SIZETYPE, ignore the overflow
1764 if ((TYPE_PRECISION (gnu_index_subtype)
1765 > TYPE_PRECISION (sizetype))
1766 && TREE_CODE (gnu_min) == INTEGER_CST
1767 && TREE_CODE (gnu_max) == INTEGER_CST
1768 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
1770 (fold (build (MINUS_EXPR, gnu_index_subtype,
1771 TYPE_MAX_VALUE (gnu_index_subtype),
1772 TYPE_MIN_VALUE (gnu_index_subtype))))))
1773 TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
1774 = TREE_CONSTANT_OVERFLOW (gnu_min)
1775 = TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
1777 /* Similarly, if the range is null, use bounds of 1..0 for
1778 the sizetype bounds. */
1779 else 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))
1784 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
1785 TYPE_MIN_VALUE (gnu_index_subtype)))
1786 gnu_min = size_one_node, gnu_max = size_zero_node;
1788 /* Now compute the size of this bound. We need to provide
1789 GCC with an upper bound to use but have to deal with the
1790 "superflat" case. There are three ways to do this. If we
1791 can prove that the array can never be superflat, we can
1792 just use the high bound of the index subtype. If we can
1793 prove that the low bound minus one can't overflow, we
1794 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1795 the expression hb >= lb ? hb : lb - 1. */
1796 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
1798 /* See if the base array type is already flat. If it is, we
1799 are probably compiling an ACVC test, but it will cause the
1800 code below to malfunction if we don't handle it specially. */
1801 if (TREE_CODE (gnu_base_min) == INTEGER_CST
1802 && TREE_CODE (gnu_base_max) == INTEGER_CST
1803 && ! TREE_CONSTANT_OVERFLOW (gnu_base_min)
1804 && ! TREE_CONSTANT_OVERFLOW (gnu_base_max)
1805 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
1806 gnu_high = size_zero_node, gnu_min = size_one_node;
1808 /* If gnu_high is now an integer which overflowed, the array
1809 cannot be superflat. */
1810 else if (TREE_CODE (gnu_high) == INTEGER_CST
1811 && TREE_OVERFLOW (gnu_high))
1813 else if (TYPE_UNSIGNED (gnu_base_subtype)
1814 || TREE_CODE (gnu_high) == INTEGER_CST)
1815 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
1819 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
1823 gnu_index_type[index]
1824 = create_index_type (gnu_min, gnu_high, gnu_index_subtype);
1826 /* Also compute the maximum size of the array. Here we
1827 see if any constraint on the index type of the base type
1828 can be used in the case of self-referential bound on
1829 the index type of the subtype. We look for a non-"infinite"
1830 and non-self-referential bound from any type involved and
1831 handle each bound separately. */
1833 if ((TREE_CODE (gnu_min) == INTEGER_CST
1834 && ! TREE_OVERFLOW (gnu_min)
1835 && ! operand_equal_p (gnu_min, gnu_base_base_min, 0))
1836 || ! CONTAINS_PLACEHOLDER_P (gnu_min))
1837 gnu_base_min = gnu_min;
1839 if ((TREE_CODE (gnu_max) == INTEGER_CST
1840 && ! TREE_OVERFLOW (gnu_max)
1841 && ! operand_equal_p (gnu_max, gnu_base_base_max, 0))
1842 || ! CONTAINS_PLACEHOLDER_P (gnu_max))
1843 gnu_base_max = gnu_max;
1845 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
1846 && TREE_CONSTANT_OVERFLOW (gnu_base_min))
1847 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
1848 || (TREE_CODE (gnu_base_max) == INTEGER_CST
1849 && TREE_CONSTANT_OVERFLOW (gnu_base_max))
1850 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
1853 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
1854 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
1857 = size_binop (MAX_EXPR,
1858 size_binop (PLUS_EXPR, size_one_node,
1859 size_binop (MINUS_EXPR, gnu_base_max,
1863 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1864 && TREE_CONSTANT_OVERFLOW (gnu_this_max))
1868 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1870 if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
1871 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
1873 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
1874 || (TREE_TYPE (gnu_index_subtype) != 0
1875 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
1877 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
1878 || (TYPE_PRECISION (gnu_index_subtype)
1879 > TYPE_PRECISION (sizetype)))
1880 need_index_type_struct = 1;
1883 /* Then flatten: create the array of arrays. */
1885 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
1887 /* One of the above calls might have caused us to be elaborated,
1888 so don't blow up if so. */
1889 if (present_gnu_tree (gnat_entity))
1895 /* Get and validate any specified Component_Size, but if Packed,
1896 ignore it since the front end will have taken care of it. */
1898 = validate_size (Component_Size (gnat_entity), gnu_type,
1900 (Is_Bit_Packed_Array (gnat_entity)
1901 ? TYPE_DECL : VAR_DECL),
1902 1, Has_Component_Size_Clause (gnat_entity));
1904 /* If the component type is a RECORD_TYPE that has a self-referential
1905 size, use the maxium size. */
1906 if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE
1907 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
1908 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1);
1910 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1912 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0);
1913 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
1914 gnat_entity, "C_PAD", 0,
1918 if (Has_Volatile_Components (Base_Type (gnat_entity)))
1919 gnu_type = build_qualified_type (gnu_type,
1920 (TYPE_QUALS (gnu_type)
1921 | TYPE_QUAL_VOLATILE));
1923 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1924 TYPE_SIZE_UNIT (gnu_type));
1925 gnu_max_size = size_binop (MULT_EXPR,
1926 convert (bitsizetype, gnu_max_size),
1927 TYPE_SIZE (gnu_type));
1929 for (index = array_dim - 1; index >= 0; index --)
1931 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
1932 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
1933 /* If the type below this an multi-array type, then this
1934 does not not have aliased components.
1936 ??? Otherwise, for now, we say that any component of aggregate
1937 type is addressable because the front end may take 'Reference
1938 of it. But we have to make it addressable if it must be passed
1939 by reference or it that is the default. */
1940 TYPE_NONALIASED_COMPONENT (gnu_type)
1941 = ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1942 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
1943 : (! Has_Aliased_Components (gnat_entity)
1944 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
1947 /* If we are at file level and this is a multi-dimensional array, we
1948 need to make a variable corresponding to the stride of the
1949 inner dimensions. */
1950 if (global_bindings_p () && array_dim > 1)
1952 tree gnu_str_name = get_identifier ("ST");
1955 for (gnu_arr_type = TREE_TYPE (gnu_type);
1956 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
1957 gnu_arr_type = TREE_TYPE (gnu_arr_type),
1958 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
1960 tree eltype = TREE_TYPE (gnu_arr_type);
1962 TYPE_SIZE (gnu_arr_type)
1963 = elaborate_expression_1 (gnat_entity, gnat_entity,
1964 TYPE_SIZE (gnu_arr_type),
1965 gnu_str_name, definition, 0);
1967 /* ??? For now, store the size as a multiple of the
1968 alignment of the element type in bytes so that we
1969 can see the alignment from the tree. */
1970 TYPE_SIZE_UNIT (gnu_arr_type)
1972 (MULT_EXPR, sizetype,
1973 elaborate_expression_1
1974 (gnat_entity, gnat_entity,
1975 build_binary_op (EXACT_DIV_EXPR, sizetype,
1976 TYPE_SIZE_UNIT (gnu_arr_type),
1977 size_int (TYPE_ALIGN (eltype)
1979 concat_id_with_name (gnu_str_name, "A_U"),
1981 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
1985 /* If we need to write out a record type giving the names of
1986 the bounds, do it now. */
1987 if (need_index_type_struct && debug_info_p)
1989 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
1990 tree gnu_field_list = 0;
1993 TYPE_NAME (gnu_bound_rec_type)
1994 = create_concat_name (gnat_entity, "XA");
1996 for (index = array_dim - 1; index >= 0; index--)
1999 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2001 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2002 gnu_type_name = DECL_NAME (gnu_type_name);
2004 gnu_field = create_field_decl (gnu_type_name,
2007 0, NULL_TREE, NULL_TREE, 0);
2008 TREE_CHAIN (gnu_field) = gnu_field_list;
2009 gnu_field_list = gnu_field;
2012 finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0);
2015 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2016 = (Convention (gnat_entity) == Convention_Fortran);
2017 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2018 = Is_Packed_Array_Type (gnat_entity);
2020 /* If our size depends on a placeholder and the maximum size doesn't
2021 overflow, use it. */
2022 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2023 && ! (TREE_CODE (gnu_max_size) == INTEGER_CST
2024 && TREE_OVERFLOW (gnu_max_size))
2025 && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2026 && TREE_OVERFLOW (gnu_max_size_unit))
2029 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2030 TYPE_SIZE (gnu_type));
2031 TYPE_SIZE_UNIT (gnu_type)
2032 = size_binop (MIN_EXPR, gnu_max_size_unit,
2033 TYPE_SIZE_UNIT (gnu_type));
2036 /* Set our alias set to that of our base type. This gives all
2037 array subtypes the same alias set. */
2038 copy_alias_set (gnu_type, gnu_base_type);
2041 /* If this is a packed type, make this type the same as the packed
2042 array type, but do some adjusting in the type first. */
2044 if (Present (Packed_Array_Type (gnat_entity)))
2046 Entity_Id gnat_index;
2047 tree gnu_inner_type;
2049 /* First finish the type we had been making so that we output
2050 debugging information for it */
2052 = build_qualified_type (gnu_type,
2053 (TYPE_QUALS (gnu_type)
2054 | (TYPE_QUAL_VOLATILE
2055 * Treat_As_Volatile (gnat_entity))));
2056 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2057 ! Comes_From_Source (gnat_entity),
2058 debug_info_p, gnat_entity);
2059 if (! Comes_From_Source (gnat_entity))
2060 DECL_ARTIFICIAL (gnu_decl) = 1;
2062 /* Save it as our equivalent in case the call below elaborates
2064 save_gnu_tree (gnat_entity, gnu_decl, 0);
2066 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2069 gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
2070 save_gnu_tree (gnat_entity, NULL_TREE, 0);
2072 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2073 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type)
2074 || TYPE_IS_PADDING_P (gnu_inner_type)))
2075 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2077 /* We need to point the type we just made to our index type so
2078 the actual bounds can be put into a template. */
2080 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2081 && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0)
2082 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2083 && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2085 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2087 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2088 If it is, we need to make another type. */
2089 if (TYPE_MODULAR_P (gnu_inner_type))
2093 gnu_subtype = make_node (INTEGER_TYPE);
2095 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2096 TYPE_MIN_VALUE (gnu_subtype)
2097 = TYPE_MIN_VALUE (gnu_inner_type);
2098 TYPE_MAX_VALUE (gnu_subtype)
2099 = TYPE_MAX_VALUE (gnu_inner_type);
2100 TYPE_PRECISION (gnu_subtype)
2101 = TYPE_PRECISION (gnu_inner_type);
2102 TYPE_UNSIGNED (gnu_subtype)
2103 = TYPE_UNSIGNED (gnu_inner_type);
2104 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2105 layout_type (gnu_subtype);
2107 gnu_inner_type = gnu_subtype;
2110 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2113 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2115 for (gnat_index = First_Index (gnat_entity);
2116 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2117 SET_TYPE_ACTUAL_BOUNDS
2119 tree_cons (NULL_TREE,
2120 get_unpadded_type (Etype (gnat_index)),
2121 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2123 if (Convention (gnat_entity) != Convention_Fortran)
2124 SET_TYPE_ACTUAL_BOUNDS
2126 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2128 if (TREE_CODE (gnu_type) == RECORD_TYPE
2129 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
2130 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2134 /* Abort if packed array with no packed array type field set. */
2135 else if (Is_Packed (gnat_entity))
2140 case E_String_Literal_Subtype:
2141 /* Create the type for a string literal. */
2143 Entity_Id gnat_full_type
2144 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2145 && Present (Full_View (Etype (gnat_entity)))
2146 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2147 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2148 tree gnu_string_array_type
2149 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2150 tree gnu_string_index_type
2151 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2152 (TYPE_DOMAIN (gnu_string_array_type))));
2153 tree gnu_lower_bound
2154 = convert (gnu_string_index_type,
2155 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2156 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2157 tree gnu_length = ssize_int (length - 1);
2158 tree gnu_upper_bound
2159 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2161 convert (gnu_string_index_type, gnu_length));
2163 = build_range_type (gnu_string_index_type,
2164 gnu_lower_bound, gnu_upper_bound);
2166 = create_index_type (convert (sizetype,
2167 TYPE_MIN_VALUE (gnu_range_type)),
2169 TYPE_MAX_VALUE (gnu_range_type)),
2173 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2178 /* Record Types and Subtypes
2180 The following fields are defined on record types:
2182 Has_Discriminants True if the record has discriminants
2183 First_Discriminant Points to head of list of discriminants
2184 First_Entity Points to head of list of fields
2185 Is_Tagged_Type True if the record is tagged
2187 Implementation of Ada records and discriminated records:
2189 A record type definition is transformed into the equivalent of a C
2190 struct definition. The fields that are the discriminants which are
2191 found in the Full_Type_Declaration node and the elements of the
2192 Component_List found in the Record_Type_Definition node. The
2193 Component_List can be a recursive structure since each Variant of
2194 the Variant_Part of the Component_List has a Component_List.
2196 Processing of a record type definition comprises starting the list of
2197 field declarations here from the discriminants and the calling the
2198 function components_to_record to add the rest of the fields from the
2199 component list and return the gnu type node. The function
2200 components_to_record will call itself recursively as it traverses
2204 if (Has_Complex_Representation (gnat_entity))
2207 = build_complex_type
2209 (Etype (Defining_Entity
2210 (First (Component_Items
2213 (Declaration_Node (gnat_entity)))))))));
2219 Node_Id full_definition = Declaration_Node (gnat_entity);
2220 Node_Id record_definition = Type_Definition (full_definition);
2221 Entity_Id gnat_field;
2223 tree gnu_field_list = NULL_TREE;
2224 tree gnu_get_parent;
2225 int packed = (Is_Packed (gnat_entity) ? 1
2226 : (Component_Alignment (gnat_entity)
2227 == Calign_Storage_Unit) ? -1
2229 int has_rep = Has_Specified_Layout (gnat_entity);
2230 int all_rep = has_rep;
2232 = (Is_Tagged_Type (gnat_entity)
2233 && Nkind (record_definition) == N_Derived_Type_Definition);
2235 /* See if all fields have a rep clause. Stop when we find one
2237 for (gnat_field = First_Entity (gnat_entity);
2238 Present (gnat_field) && all_rep;
2239 gnat_field = Next_Entity (gnat_field))
2240 if ((Ekind (gnat_field) == E_Component
2241 || Ekind (gnat_field) == E_Discriminant)
2242 && No (Component_Clause (gnat_field)))
2245 /* If this is a record extension, go a level further to find the
2246 record definition. Also, verify we have a Parent_Subtype. */
2249 if (! type_annotate_only
2250 || Present (Record_Extension_Part (record_definition)))
2251 record_definition = Record_Extension_Part (record_definition);
2253 if (! type_annotate_only && No (Parent_Subtype (gnat_entity)))
2257 /* Make a node for the record. If we are not defining the record,
2258 suppress expanding incomplete types and save the node as the type
2259 for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
2260 and reset TYPE_DUMMY_P to show it's no longer a dummy.
2262 It is very tempting to delay resetting this bit until we are done
2263 with completing the type, e.g. to let possible intermediate
2264 elaboration of access types designating the record know it is not
2265 complete and arrange for update_pointer_to to fix things up later.
2267 It would be wrong, however, because dummy types are expected only
2268 to be created for Ada incomplete or private types, which is not
2269 what we have here. Doing so would make other parts of gigi think
2270 we are dealing with a really incomplete or private type, and have
2271 nasty side effects, typically on the generation of the associated
2272 debugging information. */
2273 gnu_type = make_dummy_type (gnat_entity);
2274 TYPE_DUMMY_P (gnu_type) = 0;
2276 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
2277 DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
2279 TYPE_ALIGN (gnu_type) = 0;
2280 TYPE_PACKED (gnu_type) = packed != 0 || has_rep;
2284 defer_incomplete_level++;
2286 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2287 ! Comes_From_Source (gnat_entity),
2288 debug_info_p, gnat_entity);
2289 save_gnu_tree (gnat_entity, gnu_decl, 0);
2290 this_made_decl = saved = 1;
2293 /* If both a size and rep clause was specified, put the size in
2294 the record type now so that it can get the proper mode. */
2295 if (has_rep && Known_Esize (gnat_entity))
2296 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2298 /* Always set the alignment here so that it can be used to
2299 set the mode, if it is making the alignment stricter. If
2300 it is invalid, it will be checked again below. If this is to
2301 be Atomic, choose a default alignment of a word unless we know
2302 the size and it's smaller. */
2303 if (Known_Alignment (gnat_entity))
2304 TYPE_ALIGN (gnu_type)
2305 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2306 else if (Is_Atomic (gnat_entity))
2307 TYPE_ALIGN (gnu_type)
2308 = (esize >= BITS_PER_WORD ? BITS_PER_WORD
2309 : 1 << ((floor_log2 (esize) - 1) + 1));
2311 /* If we have a Parent_Subtype, make a field for the parent. If
2312 this record has rep clauses, force the position to zero. */
2313 if (Present (Parent_Subtype (gnat_entity)))
2317 /* A major complexity here is that the parent subtype will
2318 reference our discriminants. But those must reference
2319 the parent component of this record. So here we will
2320 initialize each of those components to a COMPONENT_REF.
2321 The first operand of that COMPONENT_REF is another
2322 COMPONENT_REF which will be filled in below, once
2323 the parent type can be safely built. */
2325 gnu_get_parent = build (COMPONENT_REF, void_type_node,
2326 build (PLACEHOLDER_EXPR, gnu_type),
2327 build_decl (FIELD_DECL, NULL_TREE,
2331 if (Has_Discriminants (gnat_entity))
2332 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2333 Present (gnat_field);
2334 gnat_field = Next_Stored_Discriminant (gnat_field))
2335 if (Present (Corresponding_Discriminant (gnat_field)))
2338 build (COMPONENT_REF,
2339 get_unpadded_type (Etype (gnat_field)),
2341 gnat_to_gnu_entity (Corresponding_Discriminant
2347 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
2350 = create_field_decl (get_identifier
2351 (Get_Name_String (Name_uParent)),
2352 gnu_parent, gnu_type, 0,
2353 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2354 has_rep ? bitsize_zero_node : 0, 1);
2355 DECL_INTERNAL_P (gnu_field_list) = 1;
2357 TREE_TYPE (gnu_get_parent) = gnu_parent;
2358 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2361 /* Add the fields for the discriminants into the record. */
2362 if (! Is_Unchecked_Union (gnat_entity)
2363 && Has_Discriminants (gnat_entity))
2364 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2365 Present (gnat_field);
2366 gnat_field = Next_Stored_Discriminant (gnat_field))
2368 /* If this is a record extension and this discriminant
2369 is the renaming of another discriminant, we've already
2370 handled the discriminant above. */
2371 if (Present (Parent_Subtype (gnat_entity))
2372 && Present (Corresponding_Discriminant (gnat_field)))
2376 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2378 /* Make an expression using a PLACEHOLDER_EXPR from the
2379 FIELD_DECL node just created and link that with the
2380 corresponding GNAT defining identifier. Then add to the
2382 save_gnu_tree (gnat_field,
2383 build (COMPONENT_REF, TREE_TYPE (gnu_field),
2384 build (PLACEHOLDER_EXPR,
2385 DECL_CONTEXT (gnu_field)),
2386 gnu_field, NULL_TREE),
2389 TREE_CHAIN (gnu_field) = gnu_field_list;
2390 gnu_field_list = gnu_field;
2393 /* Put the discriminants into the record (backwards), so we can
2394 know the appropriate discriminant to use for the names of the
2396 TYPE_FIELDS (gnu_type) = gnu_field_list;
2398 /* Add the listed fields into the record and finish up. */
2399 components_to_record (gnu_type, Component_List (record_definition),
2400 gnu_field_list, packed, definition, 0,
2403 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2404 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2406 /* If this is an extension type, reset the tree for any
2407 inherited discriminants. Also remove the PLACEHOLDER_EXPR
2408 for non-inherited discriminants. */
2409 if (! Is_Unchecked_Union (gnat_entity)
2410 && Has_Discriminants (gnat_entity))
2411 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2412 Present (gnat_field);
2413 gnat_field = Next_Stored_Discriminant (gnat_field))
2415 if (Present (Parent_Subtype (gnat_entity))
2416 && Present (Corresponding_Discriminant (gnat_field)))
2417 save_gnu_tree (gnat_field, NULL_TREE, 0);
2420 gnu_field = get_gnu_tree (gnat_field);
2421 save_gnu_tree (gnat_field, NULL_TREE, 0);
2422 save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0);
2426 /* If it is a tagged record force the type to BLKmode to insure
2427 that these objects will always be placed in memory. Do the
2428 same thing for limited record types. */
2429 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2430 TYPE_MODE (gnu_type) = BLKmode;
2432 /* If this is a derived type, we must make the alias set of this type
2433 the same as that of the type we are derived from. We assume here
2434 that the other type is already frozen. */
2435 if (Etype (gnat_entity) != gnat_entity
2436 && ! (Is_Private_Type (Etype (gnat_entity))
2437 && Full_View (Etype (gnat_entity)) == gnat_entity))
2438 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2440 /* Fill in locations of fields. */
2441 annotate_rep (gnat_entity, gnu_type);
2443 /* If there are any entities in the chain corresponding to
2444 components that we did not elaborate, ensure we elaborate their
2445 types if they are Itypes. */
2446 for (gnat_temp = First_Entity (gnat_entity);
2447 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2448 if ((Ekind (gnat_temp) == E_Component
2449 || Ekind (gnat_temp) == E_Discriminant)
2450 && Is_Itype (Etype (gnat_temp))
2451 && ! present_gnu_tree (gnat_temp))
2452 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2456 case E_Class_Wide_Subtype:
2457 /* If an equivalent type is present, that is what we should use.
2458 Otherwise, fall through to handle this like a record subtype
2459 since it may have constraints. */
2461 if (Present (Equivalent_Type (gnat_entity)))
2463 gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
2469 /* ... fall through ... */
2471 case E_Record_Subtype:
2473 /* If Cloned_Subtype is Present it means this record subtype has
2474 identical layout to that type or subtype and we should use
2475 that GCC type for this one. The front end guarantees that
2476 the component list is shared. */
2477 if (Present (Cloned_Subtype (gnat_entity)))
2479 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2484 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2485 changing the type, make a new type with each field having the
2486 type of the field in the new subtype but having the position
2487 computed by transforming every discriminant reference according
2488 to the constraints. We don't see any difference between
2489 private and nonprivate type here since derivations from types should
2490 have been deferred until the completion of the private type. */
2493 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2498 defer_incomplete_level++, this_deferred = 1;
2500 /* Get the base type initially for its alignment and sizes. But
2501 if it is a padded type, we do all the other work with the
2503 gnu_type = gnu_orig_type = gnu_base_type
2504 = gnat_to_gnu_type (gnat_base_type);
2506 if (TREE_CODE (gnu_type) == RECORD_TYPE
2507 && TYPE_IS_PADDING_P (gnu_type))
2508 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2510 if (present_gnu_tree (gnat_entity))
2516 /* When the type has discriminants, and these discriminants
2517 affect the shape of what it built, factor them in.
2519 If we are making a subtype of an Unchecked_Union (must be an
2520 Itype), just return the type.
2522 We can't just use Is_Constrained because private subtypes without
2523 discriminants of full types with discriminants with default
2524 expressions are Is_Constrained but aren't constrained! */
2526 if (IN (Ekind (gnat_base_type), Record_Kind)
2527 && ! Is_For_Access_Subtype (gnat_entity)
2528 && ! Is_Unchecked_Union (gnat_base_type)
2529 && Is_Constrained (gnat_entity)
2530 && Stored_Constraint (gnat_entity) != No_Elist
2531 && Present (Discriminant_Constraint (gnat_entity)))
2533 Entity_Id gnat_field;
2534 Entity_Id gnat_root_type;
2535 tree gnu_field_list = 0;
2537 = compute_field_positions (gnu_orig_type, NULL_TREE,
2538 size_zero_node, bitsize_zero_node,
2541 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2545 /* If this is a derived type, we may be seeing fields from any
2546 original records, so add those positions and discriminant
2547 substitutions to our lists. */
2548 for (gnat_root_type = gnat_base_type;
2549 Underlying_Type (Etype (gnat_root_type)) != gnat_root_type;
2550 gnat_root_type = Underlying_Type (Etype (gnat_root_type)))
2553 = compute_field_positions
2554 (gnat_to_gnu_type (Etype (gnat_root_type)),
2555 gnu_pos_list, size_zero_node, bitsize_zero_node,
2558 if (Present (Parent_Subtype (gnat_root_type)))
2560 = substitution_list (Parent_Subtype (gnat_root_type),
2561 Empty, gnu_subst_list, definition);
2564 gnu_type = make_node (RECORD_TYPE);
2565 TYPE_NAME (gnu_type) = gnu_entity_id;
2566 TYPE_STUB_DECL (gnu_type)
2567 = create_type_decl (NULL_TREE, gnu_type, NULL, 0, 0,
2569 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2571 for (gnat_field = First_Entity (gnat_entity);
2572 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2573 if (Ekind (gnat_field) == E_Component
2574 || Ekind (gnat_field) == E_Discriminant)
2577 = gnat_to_gnu_entity
2578 (Original_Record_Component (gnat_field), NULL_TREE, 0);
2580 = TREE_VALUE (purpose_member (gnu_old_field,
2582 tree gnu_pos = TREE_PURPOSE (gnu_offset);
2583 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
2585 = gnat_to_gnu_type (Etype (gnat_field));
2586 tree gnu_size = TYPE_SIZE (gnu_field_type);
2587 tree gnu_new_pos = 0;
2588 unsigned int offset_align
2589 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
2593 /* If there was a component clause, the field types must be
2594 the same for the type and subtype, so copy the data from
2595 the old field to avoid recomputation here. */
2596 if (Present (Component_Clause
2597 (Original_Record_Component (gnat_field))))
2599 gnu_size = DECL_SIZE (gnu_old_field);
2600 gnu_field_type = TREE_TYPE (gnu_old_field);
2603 /* If this was a bitfield, get the size from the old field.
2604 Also ensure the type can be placed into a bitfield. */
2605 else if (DECL_BIT_FIELD (gnu_old_field))
2607 gnu_size = DECL_SIZE (gnu_old_field);
2608 if (TYPE_MODE (gnu_field_type) == BLKmode
2609 && TREE_CODE (gnu_field_type) == RECORD_TYPE
2610 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
2611 gnu_field_type = make_packable_type (gnu_field_type);
2614 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
2615 for (gnu_temp = gnu_subst_list;
2616 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2617 gnu_pos = substitute_in_expr (gnu_pos,
2618 TREE_PURPOSE (gnu_temp),
2619 TREE_VALUE (gnu_temp));
2621 /* If the size is now a constant, we can set it as the
2622 size of the field when we make it. Otherwise, we need
2623 to deal with it specially. */
2624 if (TREE_CONSTANT (gnu_pos))
2625 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
2629 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
2630 0, gnu_size, gnu_new_pos,
2631 ! DECL_NONADDRESSABLE_P (gnu_old_field));
2633 if (! TREE_CONSTANT (gnu_pos))
2635 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
2636 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
2637 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
2638 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
2639 DECL_SIZE (gnu_field) = gnu_size;
2640 DECL_SIZE_UNIT (gnu_field)
2641 = convert (sizetype,
2642 size_binop (CEIL_DIV_EXPR, gnu_size,
2643 bitsize_unit_node));
2644 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
2647 DECL_INTERNAL_P (gnu_field)
2648 = DECL_INTERNAL_P (gnu_old_field);
2649 SET_DECL_ORIGINAL_FIELD
2650 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field) != 0
2651 ? DECL_ORIGINAL_FIELD (gnu_old_field)
2653 DECL_DISCRIMINANT_NUMBER (gnu_field)
2654 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
2655 TREE_THIS_VOLATILE (gnu_field)
2656 = TREE_THIS_VOLATILE (gnu_old_field);
2657 TREE_CHAIN (gnu_field) = gnu_field_list;
2658 gnu_field_list = gnu_field;
2659 save_gnu_tree (gnat_field, gnu_field, 0);
2662 finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0);
2664 /* Now set the size, alignment and alias set of the new type to
2665 match that of the old one, doing any substitutions, as
2667 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2668 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2669 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2670 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2671 copy_alias_set (gnu_type, gnu_base_type);
2673 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2674 for (gnu_temp = gnu_subst_list;
2675 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2676 TYPE_SIZE (gnu_type)
2677 = substitute_in_expr (TYPE_SIZE (gnu_type),
2678 TREE_PURPOSE (gnu_temp),
2679 TREE_VALUE (gnu_temp));
2681 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2682 for (gnu_temp = gnu_subst_list;
2683 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2684 TYPE_SIZE_UNIT (gnu_type)
2685 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2686 TREE_PURPOSE (gnu_temp),
2687 TREE_VALUE (gnu_temp));
2689 if (TYPE_ADA_SIZE (gnu_type) != 0
2690 && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2691 for (gnu_temp = gnu_subst_list;
2692 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2694 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2695 TREE_PURPOSE (gnu_temp),
2696 TREE_VALUE (gnu_temp)));
2698 /* Recompute the mode of this record type now that we know its
2700 compute_record_mode (gnu_type);
2702 /* Fill in locations of fields. */
2703 annotate_rep (gnat_entity, gnu_type);
2706 /* If we've made a new type, record it and make an XVS type to show
2707 what this is a subtype of. Some debuggers require the XVS
2708 type to be output first, so do it in that order. */
2709 if (gnu_type != gnu_orig_type)
2713 tree gnu_subtype_marker = make_node (RECORD_TYPE);
2714 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
2716 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
2717 gnu_orig_name = DECL_NAME (gnu_orig_name);
2719 TYPE_NAME (gnu_subtype_marker)
2720 = create_concat_name (gnat_entity, "XVS");
2721 finish_record_type (gnu_subtype_marker,
2722 create_field_decl (gnu_orig_name,
2730 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2731 TYPE_NAME (gnu_type) = gnu_entity_id;
2732 TYPE_STUB_DECL (gnu_type)
2733 = create_type_decl (TYPE_NAME (gnu_type), gnu_type,
2734 NULL, 1, debug_info_p, gnat_entity);
2737 /* Otherwise, go down all the components in the new type and
2738 make them equivalent to those in the base type. */
2740 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
2741 gnat_temp = Next_Entity (gnat_temp))
2742 if ((Ekind (gnat_temp) == E_Discriminant
2743 && ! Is_Unchecked_Union (gnat_base_type))
2744 || Ekind (gnat_temp) == E_Component)
2745 save_gnu_tree (gnat_temp,
2747 (Original_Record_Component (gnat_temp)), 0);
2751 case E_Access_Subprogram_Type:
2752 case E_Anonymous_Access_Subprogram_Type:
2753 /* If we are not defining this entity, and we have incomplete
2754 entities being processed above us, make a dummy type and
2755 fill it in later. */
2756 if (! definition && defer_incomplete_level != 0)
2758 struct incomplete *p
2759 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
2762 = build_pointer_type
2763 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
2764 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2765 ! Comes_From_Source (gnat_entity),
2766 debug_info_p, gnat_entity);
2767 save_gnu_tree (gnat_entity, gnu_decl, 0);
2768 this_made_decl = saved = 1;
2770 p->old_type = TREE_TYPE (gnu_type);
2771 p->full_type = Directly_Designated_Type (gnat_entity);
2772 p->next = defer_incomplete_list;
2773 defer_incomplete_list = p;
2777 /* ... fall through ... */
2779 case E_Allocator_Type:
2781 case E_Access_Attribute_Type:
2782 case E_Anonymous_Access_Type:
2783 case E_General_Access_Type:
2785 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
2786 Entity_Id gnat_desig_full
2787 = ((IN (Ekind (Etype (gnat_desig_type)),
2788 Incomplete_Or_Private_Kind))
2789 ? Full_View (gnat_desig_type) : 0);
2790 /* We want to know if we'll be seeing the freeze node for any
2791 incomplete type we may be pointing to. */
2793 = (Present (gnat_desig_full)
2794 ? In_Extended_Main_Code_Unit (gnat_desig_full)
2795 : In_Extended_Main_Code_Unit (gnat_desig_type));
2798 tree gnu_desig_type = 0;
2799 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
2801 if (!targetm.valid_pointer_mode (p_mode))
2804 if (No (gnat_desig_full)
2805 && (Ekind (gnat_desig_type) == E_Class_Wide_Type
2806 || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype
2807 && Present (Equivalent_Type (gnat_desig_type)))))
2809 if (Present (Equivalent_Type (gnat_desig_type)))
2811 gnat_desig_full = Equivalent_Type (gnat_desig_type);
2812 if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind))
2813 gnat_desig_full = Full_View (gnat_desig_full);
2815 else if (IN (Ekind (Root_Type (gnat_desig_type)),
2816 Incomplete_Or_Private_Kind))
2817 gnat_desig_full = Full_View (Root_Type (gnat_desig_type));
2820 if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full))
2821 gnat_desig_full = Corresponding_Record_Type (gnat_desig_full);
2823 /* If either the designated type or its full view is an
2824 unconstrained array subtype, replace it with the type it's a
2825 subtype of. This avoids problems with multiple copies of
2826 unconstrained array types. */
2827 if (Ekind (gnat_desig_type) == E_Array_Subtype
2828 && ! Is_Constrained (gnat_desig_type))
2829 gnat_desig_type = Etype (gnat_desig_type);
2830 if (Present (gnat_desig_full)
2831 && Ekind (gnat_desig_full) == E_Array_Subtype
2832 && ! Is_Constrained (gnat_desig_full))
2833 gnat_desig_full = Etype (gnat_desig_full);
2835 /* If the designated type is a subtype of an incomplete record type,
2836 use the parent type to avoid order of elaboration issues. This
2837 can lose some code efficiency, but there is no alternative. */
2838 if (Present (gnat_desig_full)
2839 && Ekind (gnat_desig_full) == E_Record_Subtype
2840 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)
2841 gnat_desig_full = Etype (gnat_desig_full);
2843 /* If we are pointing to an incomplete type whose completion is an
2844 unconstrained array, make a fat pointer type instead of a pointer
2845 to VOID. The two types in our fields will be pointers to VOID and
2846 will be replaced in update_pointer_to. Similiarly, if the type
2847 itself is a dummy type or an unconstrained array. Also make
2848 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
2851 if ((Present (gnat_desig_full)
2852 && Is_Array_Type (gnat_desig_full)
2853 && ! Is_Constrained (gnat_desig_full))
2854 || (present_gnu_tree (gnat_desig_type)
2855 && TYPE_IS_DUMMY_P (TREE_TYPE
2856 (get_gnu_tree (gnat_desig_type)))
2857 && Is_Array_Type (gnat_desig_type)
2858 && ! Is_Constrained (gnat_desig_type))
2859 || (present_gnu_tree (gnat_desig_type)
2860 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type)))
2861 == UNCONSTRAINED_ARRAY_TYPE)
2862 && (TYPE_POINTER_TO (TREE_TYPE
2863 (get_gnu_tree (gnat_desig_type)))
2865 || (No (gnat_desig_full) && ! in_main_unit
2866 && defer_incomplete_level != 0
2867 && ! present_gnu_tree (gnat_desig_type)
2868 && Is_Array_Type (gnat_desig_type)
2869 && ! Is_Constrained (gnat_desig_type)))
2872 = (present_gnu_tree (gnat_desig_type)
2873 ? gnat_to_gnu_type (gnat_desig_type)
2874 : make_dummy_type (gnat_desig_type));
2877 /* Show the dummy we get will be a fat pointer. */
2878 got_fat_p = made_dummy = 1;
2880 /* If the call above got something that has a pointer, that
2881 pointer is our type. This could have happened either
2882 because the type was elaborated or because somebody
2883 else executed the code below. */
2884 gnu_type = TYPE_POINTER_TO (gnu_old);
2887 gnu_type = make_node (RECORD_TYPE);
2888 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
2889 TYPE_POINTER_TO (gnu_old) = gnu_type;
2891 Sloc_to_locus (Sloc (gnat_entity), &input_location);
2893 = chainon (chainon (NULL_TREE,
2895 (get_identifier ("P_ARRAY"),
2896 ptr_void_type_node, gnu_type,
2898 create_field_decl (get_identifier ("P_BOUNDS"),
2900 gnu_type, 0, 0, 0, 0));
2902 /* Make sure we can place this into a register. */
2903 TYPE_ALIGN (gnu_type)
2904 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
2905 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
2906 finish_record_type (gnu_type, fields, 0, 1);
2908 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
2909 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
2910 = concat_id_with_name (get_entity_name (gnat_desig_type),
2912 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
2916 /* If we already know what the full type is, use it. */
2917 else if (Present (gnat_desig_full)
2918 && present_gnu_tree (gnat_desig_full))
2919 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
2921 /* Get the type of the thing we are to point to and build a pointer
2922 to it. If it is a reference to an incomplete or private type with a
2923 full view that is a record, make a dummy type node and get the
2924 actual type later when we have verified it is safe. */
2925 else if (! in_main_unit
2926 && ! present_gnu_tree (gnat_desig_type)
2927 && Present (gnat_desig_full)
2928 && ! present_gnu_tree (gnat_desig_full)
2929 && Is_Record_Type (gnat_desig_full))
2931 gnu_desig_type = make_dummy_type (gnat_desig_type);
2935 /* Likewise if we are pointing to a record or array and we are to defer
2936 elaborating incomplete types. We do this since this access type
2937 may be the full view of some private type. Note that the
2938 unconstrained array case is handled above. */
2939 else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0
2940 && ! present_gnu_tree (gnat_desig_type)
2941 && ((Is_Record_Type (gnat_desig_type)
2942 || Is_Array_Type (gnat_desig_type))
2943 || (Present (gnat_desig_full)
2944 && (Is_Record_Type (gnat_desig_full)
2945 || Is_Array_Type (gnat_desig_full)))))
2947 gnu_desig_type = make_dummy_type (gnat_desig_type);
2950 else if (gnat_desig_type == gnat_entity)
2953 = build_pointer_type_for_mode (make_node (VOID_TYPE),
2955 No_Strict_Aliasing (gnat_entity));
2956 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
2959 gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
2961 /* It is possible that the above call to gnat_to_gnu_type resolved our
2962 type. If so, just return it. */
2963 if (present_gnu_tree (gnat_entity))
2969 /* If we have a GCC type for the designated type, possibly modify it
2970 if we are pointing only to constant objects and then make a pointer
2971 to it. Don't do this for unconstrained arrays. */
2972 if (gnu_type == 0 && gnu_desig_type != 0)
2974 if (Is_Access_Constant (gnat_entity)
2975 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
2978 = build_qualified_type
2980 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
2982 /* Some extra processing is required if we are building a
2983 pointer to an incomplete type (in the GCC sense). We might
2984 have such a type if we just made a dummy, or directly out
2985 of the call to gnat_to_gnu_type above if we are processing
2986 an access type for a record component designating the
2987 record type itself. */
2988 if (! COMPLETE_TYPE_P (gnu_desig_type))
2990 /* We must ensure that the pointer to variant we make will
2991 be processed by update_pointer_to when the initial type
2992 is completed. Pretend we made a dummy and let further
2993 processing act as usual. */
2996 /* We must ensure that update_pointer_to will not retrieve
2997 the dummy variant when building a properly qualified
2998 version of the complete type. We take advantage of the
2999 fact that get_qualified_type is requiring TYPE_NAMEs to
3000 match to influence build_qualified_type and then also
3001 update_pointer_to here. */
3002 TYPE_NAME (gnu_desig_type)
3003 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3008 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3009 No_Strict_Aliasing (gnat_entity));
3012 /* If we are not defining this object and we made a dummy pointer,
3013 save our current definition, evaluate the actual type, and replace
3014 the tentative type we made with the actual one. If we are to defer
3015 actually looking up the actual type, make an entry in the
3018 if (! in_main_unit && made_dummy)
3021 = TYPE_FAT_POINTER_P (gnu_type)
3022 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3024 if (esize == POINTER_SIZE
3025 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3027 = build_pointer_type
3028 (TYPE_OBJECT_RECORD_TYPE
3029 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3031 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3032 ! Comes_From_Source (gnat_entity),
3033 debug_info_p, gnat_entity);
3034 save_gnu_tree (gnat_entity, gnu_decl, 0);
3035 this_made_decl = saved = 1;
3037 if (defer_incomplete_level == 0)
3039 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3040 gnat_to_gnu_type (gnat_desig_type));
3041 /* Note that the call to gnat_to_gnu_type here might have
3042 updated gnu_old_type directly, in which case it is not a
3043 dummy type any more when we get into update_pointer_to.
3045 This may happen for instance when the designated type is a
3046 record type, because their elaboration starts with an
3047 initial node from make_dummy_type, which may yield the same
3048 node as the one we got.
3050 Besides, variants of this non-dummy type might have been
3051 created along the way. update_pointer_to is expected to
3052 properly take care of those situations. */
3056 struct incomplete *p
3057 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3059 p->old_type = gnu_old_type;
3060 p->full_type = gnat_desig_type;
3061 p->next = defer_incomplete_list;
3062 defer_incomplete_list = p;
3068 case E_Access_Protected_Subprogram_Type:
3069 case E_Anonymous_Access_Protected_Subprogram_Type:
3070 if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
3071 gnu_type = build_pointer_type (void_type_node);
3073 /* The runtime representation is the equivalent type. */
3074 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3076 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3077 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3078 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3079 && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3080 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3085 case E_Access_Subtype:
3087 /* We treat this as identical to its base type; any constraint is
3088 meaningful only to the front end.
3090 The designated type must be elaborated as well, if it does
3091 not have its own freeze node. Designated (sub)types created
3092 for constrained components of records with discriminants are
3093 not frozen by the front end and thus not elaborated by gigi,
3094 because their use may appear before the base type is frozen,
3095 and because it is not clear that they are needed anywhere in
3096 Gigi. With the current model, there is no correct place where
3097 they could be elaborated. */
3099 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3100 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3101 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3102 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3103 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3105 /* If we are not defining this entity, and we have incomplete
3106 entities being processed above us, make a dummy type and
3107 elaborate it later. */
3108 if (! definition && defer_incomplete_level != 0)
3110 struct incomplete *p
3111 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3113 = build_pointer_type
3114 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3116 p->old_type = TREE_TYPE (gnu_ptr_type);
3117 p->full_type = Directly_Designated_Type (gnat_entity);
3118 p->next = defer_incomplete_list;
3119 defer_incomplete_list = p;
3122 (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))),
3123 Incomplete_Or_Private_Kind))
3126 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3133 /* Subprogram Entities
3135 The following access functions are defined for subprograms (functions
3138 First_Formal The first formal parameter.
3139 Is_Imported Indicates that the subprogram has appeared in
3140 an INTERFACE or IMPORT pragma. For now we
3141 assume that the external language is C.
3142 Is_Inlined True if the subprogram is to be inlined.
3144 In addition for function subprograms we have:
3146 Etype Return type of the function.
3148 Each parameter is first checked by calling must_pass_by_ref on its
3149 type to determine if it is passed by reference. For parameters which
3150 are copied in, if they are Ada IN OUT or OUT parameters, their return
3151 value becomes part of a record which becomes the return type of the
3152 function (C function - note that this applies only to Ada procedures
3153 so there is no Ada return type). Additional code to store back the
3154 parameters will be generated on the caller side. This transformation
3155 is done here, not in the front-end.
3157 The intended result of the transformation can be seen from the
3158 equivalent source rewritings that follow:
3160 struct temp {int a,b};
3161 procedure P (A,B: IN OUT ...) is temp P (int A,B) {
3163 end P; return {A,B};
3173 For subprogram types we need to perform mainly the same conversions to
3174 GCC form that are needed for procedures and function declarations. The
3175 only difference is that at the end, we make a type declaration instead
3176 of a function declaration. */
3178 case E_Subprogram_Type:
3182 /* The first GCC parameter declaration (a PARM_DECL node). The
3183 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3184 actually is the head of this parameter list. */
3185 tree gnu_param_list = NULL_TREE;
3186 /* The type returned by a function. If the subprogram is a procedure
3187 this type should be void_type_node. */
3188 tree gnu_return_type = void_type_node;
3189 /* List of fields in return type of procedure with copy in copy out
3191 tree gnu_field_list = NULL_TREE;
3192 /* Non-null for subprograms containing parameters passed by copy in
3193 copy out (Ada IN OUT or OUT parameters not passed by reference),
3194 in which case it is the list of nodes used to specify the values of
3195 the in out/out parameters that are returned as a record upon
3196 procedure return. The TREE_PURPOSE of an element of this list is
3197 a field of the record and the TREE_VALUE is the PARM_DECL
3198 corresponding to that field. This list will be saved in the
3199 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3200 tree gnu_return_list = NULL_TREE;
3201 Entity_Id gnat_param;
3202 int inline_flag = Is_Inlined (gnat_entity);
3203 int public_flag = Is_Public (gnat_entity);
3205 = (Is_Public (gnat_entity) && !definition) || imported_p;
3206 int pure_flag = Is_Pure (gnat_entity);
3207 int volatile_flag = No_Return (gnat_entity);
3208 int returns_by_ref = 0;
3209 int returns_unconstrained = 0;
3210 tree gnu_ext_name = create_concat_name (gnat_entity, 0);
3211 int has_copy_in_out = 0;
3214 if (kind == E_Subprogram_Type && ! definition)
3215 /* A parameter may refer to this type, so defer completion
3216 of any incomplete types. */
3217 defer_incomplete_level++, this_deferred = 1;
3219 /* If the subprogram has an alias, it is probably inherited, so
3220 we can use the original one. If the original "subprogram"
3221 is actually an enumeration literal, it may be the first use
3222 of its type, so we must elaborate that type now. */
3223 if (Present (Alias (gnat_entity)))
3225 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3226 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3228 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3231 /* Elaborate any Itypes in the parameters of this entity. */
3232 for (gnat_temp = First_Formal (gnat_entity);
3233 Present (gnat_temp);
3234 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3235 if (Is_Itype (Etype (gnat_temp)))
3236 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3241 if (kind == E_Function || kind == E_Subprogram_Type)
3242 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3244 /* If this function returns by reference, make the actual
3245 return type of this function the pointer and mark the decl. */
3246 if (Returns_By_Ref (gnat_entity))
3249 gnu_return_type = build_pointer_type (gnu_return_type);
3252 /* If the Mechanism is By_Reference, ensure the return type uses
3253 the machine's by-reference mechanism, which may not the same
3254 as above (e.g., it might be by passing a fake parameter). */
3255 else if (kind == E_Function
3256 && Mechanism (gnat_entity) == By_Reference)
3258 gnu_return_type = copy_type (gnu_return_type);
3259 TREE_ADDRESSABLE (gnu_return_type) = 1;
3262 /* If we are supposed to return an unconstrained array,
3263 actually return a fat pointer and make a note of that. Return
3264 a pointer to an unconstrained record of variable size. */
3265 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3267 gnu_return_type = TREE_TYPE (gnu_return_type);
3268 returns_unconstrained = 1;
3271 /* If the type requires a transient scope, the result is allocated
3272 on the secondary stack, so the result type of the function is
3274 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3276 gnu_return_type = build_pointer_type (gnu_return_type);
3277 returns_unconstrained = 1;
3280 /* If the type is a padded type and the underlying type would not
3281 be passed by reference or this function has a foreign convention,
3282 return the underlying type. */
3283 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3284 && TYPE_IS_PADDING_P (gnu_return_type)
3285 && (! default_pass_by_ref (TREE_TYPE
3286 (TYPE_FIELDS (gnu_return_type)))
3287 || Has_Foreign_Convention (gnat_entity)))
3288 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3290 /* Look at all our parameters and get the type of
3291 each. While doing this, build a copy-out structure if
3294 /* If the return type has a size that overflows, we cannot have
3295 a function that returns that type. This usage doesn't make
3296 sense anyway, so give an error here. */
3297 if (TYPE_SIZE_UNIT (gnu_return_type)
3298 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3300 post_error ("cannot return type whose size overflows",
3302 gnu_return_type = copy_node (gnu_return_type);
3303 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3304 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3305 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3306 TYPE_NEXT_VARIANT (gnu_return_type) = 0;
3309 for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
3310 Present (gnat_param);
3311 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3313 tree gnu_param_name = get_entity_name (gnat_param);
3314 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3315 tree gnu_param, gnu_field;
3318 int by_component_ptr_p = 0;
3319 int copy_in_copy_out_flag = 0;
3320 int req_by_copy = 0, req_by_ref = 0;
3322 /* See if a Mechanism was supplied that forced this
3323 parameter to be passed one way or another. */
3324 if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3326 else if (Mechanism (gnat_param) == Default)
3328 else if (Mechanism (gnat_param) == By_Copy)
3330 else if (Mechanism (gnat_param) == By_Reference)
3332 else if (Mechanism (gnat_param) <= By_Descriptor)
3334 else if (Mechanism (gnat_param) > 0)
3336 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3337 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3338 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3339 Mechanism (gnat_param)))
3345 post_error ("unsupported mechanism for&", gnat_param);
3347 /* If this is either a foreign function or if the
3348 underlying type won't be passed by refererence, strip off
3349 possible padding type. */
3350 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
3351 && TYPE_IS_PADDING_P (gnu_param_type)
3352 && (req_by_ref || Has_Foreign_Convention (gnat_entity)
3353 || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
3354 (gnu_param_type)))))
3355 gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
3357 /* If this is an IN parameter it is read-only, so make a variant
3358 of the type that is read-only.
3360 ??? However, if this is an unconstrained array, that type can
3361 be very complex. So skip it for now. Likewise for any other
3362 self-referential type. */
3363 if (Ekind (gnat_param) == E_In_Parameter
3364 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
3365 && ! (TYPE_SIZE (gnu_param_type) != 0
3366 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))))
3368 = build_qualified_type (gnu_param_type,
3369 (TYPE_QUALS (gnu_param_type)
3370 | TYPE_QUAL_CONST));
3372 /* For foreign conventions, pass arrays as a pointer to the
3373 underlying type. First check for unconstrained array and get
3374 the underlying array. Then get the component type and build
3376 if (Has_Foreign_Convention (gnat_entity)
3377 && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
3379 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3380 (TREE_TYPE (gnu_param_type))));
3384 = build_pointer_type
3385 (build_vms_descriptor (gnu_param_type,
3386 Mechanism (gnat_param),
3389 else if (Has_Foreign_Convention (gnat_entity)
3391 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
3393 /* Strip off any multi-dimensional entries, then strip
3394 off the last array to get the component type. */
3395 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
3396 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
3397 gnu_param_type = TREE_TYPE (gnu_param_type);
3399 by_component_ptr_p = 1;
3400 gnu_param_type = TREE_TYPE (gnu_param_type);
3402 if (Ekind (gnat_param) == E_In_Parameter)
3404 = build_qualified_type (gnu_param_type,
3405 (TYPE_QUALS (gnu_param_type)
3406 | TYPE_QUAL_CONST));
3408 gnu_param_type = build_pointer_type (gnu_param_type);
3411 /* Fat pointers are passed as thin pointers for foreign
3413 else if (Has_Foreign_Convention (gnat_entity)
3414 && TYPE_FAT_POINTER_P (gnu_param_type))
3416 = make_type_from_size (gnu_param_type,
3417 size_int (POINTER_SIZE), 0);
3419 /* If we must pass or were requested to pass by reference, do so.
3420 If we were requested to pass by copy, do so.
3421 Otherwise, for foreign conventions, pass all in out parameters
3422 or aggregates by reference. For COBOL and Fortran, pass
3423 all integer and FP types that way too. For Convention Ada,
3424 use the standard Ada default. */
3425 else if (must_pass_by_ref (gnu_param_type) || req_by_ref
3427 && ((Has_Foreign_Convention (gnat_entity)
3428 && (Ekind (gnat_param) != E_In_Parameter
3429 || AGGREGATE_TYPE_P (gnu_param_type)))
3430 || (((Convention (gnat_entity)
3431 == Convention_Fortran)
3432 || (Convention (gnat_entity)
3433 == Convention_COBOL))
3434 && (INTEGRAL_TYPE_P (gnu_param_type)
3435 || FLOAT_TYPE_P (gnu_param_type)))
3436 /* For convention Ada, see if we pass by reference
3438 || (! Has_Foreign_Convention (gnat_entity)
3439 && default_pass_by_ref (gnu_param_type)))))
3441 gnu_param_type = build_reference_type (gnu_param_type);
3445 else if (Ekind (gnat_param) != E_In_Parameter)
3446 copy_in_copy_out_flag = 1;
3448 if (req_by_copy && (by_ref_p || by_component_ptr_p))
3449 post_error ("?cannot pass & by copy", gnat_param);
3451 /* If this is an OUT parameter that isn't passed by reference
3452 and isn't a pointer or aggregate, we don't make a PARM_DECL
3453 for it. Instead, it will be a VAR_DECL created when we process
3454 the procedure. For the special parameter of Valued_Procedure,
3457 An exception is made to cover the RM-6.4.1 rule requiring "by
3458 copy" out parameters with discriminants or implicit initial
3459 values to be handled like in out parameters. These type are
3460 normally built as aggregates, and hence passed by reference,
3461 except for some packed arrays which end up encoded in special
3464 The exception we need to make is then for packed arrays of
3465 records with discriminants or implicit initial values. We have
3466 no light/easy way to check for the latter case, so we merely
3467 check for packed arrays of records. This may lead to useless
3468 copy-in operations, but in very rare cases only, as these would
3469 be exceptions in a set of already exceptional situations. */
3470 if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p
3471 && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3473 && ! POINTER_TYPE_P (gnu_param_type)
3474 && ! AGGREGATE_TYPE_P (gnu_param_type)))
3475 && ! (Is_Array_Type (Etype (gnat_param))
3476 && Is_Packed (Etype (gnat_param))
3477 && Is_Composite_Type (Component_Type
3478 (Etype (gnat_param)))))
3484 (gnu_param_name, gnu_param_type,
3485 by_ref_p || by_component_ptr_p
3486 || Ekind (gnat_param) == E_In_Parameter);
3488 DECL_BY_REF_P (gnu_param) = by_ref_p;
3489 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p;
3490 DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p;
3491 DECL_POINTS_TO_READONLY_P (gnu_param)
3492 = (Ekind (gnat_param) == E_In_Parameter
3493 && (by_ref_p || by_component_ptr_p));
3494 Sloc_to_locus (Sloc (gnat_param),
3495 &DECL_SOURCE_LOCATION (gnu_param));
3496 save_gnu_tree (gnat_param, gnu_param, 0);
3497 gnu_param_list = chainon (gnu_param, gnu_param_list);
3499 /* If a parameter is a pointer, this function may modify
3500 memory through it and thus shouldn't be considered
3501 a pure function. Also, the memory may be modified
3502 between two calls, so they can't be CSE'ed. The latter
3503 case also handles by-ref parameters. */
3504 if (POINTER_TYPE_P (gnu_param_type)
3505 || TYPE_FAT_POINTER_P (gnu_param_type))
3509 if (copy_in_copy_out_flag)
3511 if (! has_copy_in_out)
3513 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
3516 gnu_return_type = make_node (RECORD_TYPE);
3517 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3518 has_copy_in_out = 1;
3521 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3522 gnu_return_type, 0, 0, 0, 0);
3523 Sloc_to_locus (Sloc (gnat_param),
3524 &DECL_SOURCE_LOCATION (gnu_field));
3525 TREE_CHAIN (gnu_field) = gnu_field_list;
3526 gnu_field_list = gnu_field;
3527 gnu_return_list = tree_cons (gnu_field, gnu_param,
3532 /* Do not compute record for out parameters if subprogram is
3533 stubbed since structures are incomplete for the back-end. */
3534 if (gnu_field_list != 0
3535 && Convention (gnat_entity) != Convention_Stubbed)
3536 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3539 /* If we have a CICO list but it has only one entry, we convert
3540 this function into a function that simply returns that one
3542 if (list_length (gnu_return_list) == 1)
3543 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3546 if (Convention (gnat_entity) == Convention_Stdcall)
3549 = (struct attrib *) xmalloc (sizeof (struct attrib));
3551 attr->next = attr_list;
3552 attr->type = ATTR_MACHINE_ATTRIBUTE;
3553 attr->name = get_identifier ("stdcall");
3554 attr->arg = NULL_TREE;
3555 attr->error_point = gnat_entity;
3560 /* Both lists ware built in reverse. */
3561 gnu_param_list = nreverse (gnu_param_list);
3562 gnu_return_list = nreverse (gnu_return_list);
3565 = create_subprog_type (gnu_return_type, gnu_param_list,
3566 gnu_return_list, returns_unconstrained,
3568 Function_Returns_With_DSP (gnat_entity));
3570 /* ??? For now, don't consider nested functions pure. */
3571 if (! global_bindings_p ())
3574 /* A subprogram (something that doesn't return anything) shouldn't
3575 be considered Pure since there would be no reason for such a
3576 subprogram. Note that procedures with Out (or In Out) parameters
3577 have already been converted into a function with a return type. */
3578 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
3582 = build_qualified_type (gnu_type,
3583 (TYPE_QUALS (gnu_type)
3584 | (TYPE_QUAL_CONST * pure_flag)
3585 | (TYPE_QUAL_VOLATILE * volatile_flag)));
3587 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3589 /* If there was no specified Interface_Name and the external and
3590 internal names of the subprogram are the same, only use the
3591 internal name to allow disambiguation of nested subprograms. */
3592 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
3595 /* If we are defining the subprogram and it has an Address clause
3596 we must get the address expression from the saved GCC tree for the
3597 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3598 the address expression here since the front-end has guaranteed
3599 in that case that the elaboration has no effects. If there is
3600 an Address clause and we are not defining the object, just
3601 make it a constant. */
3602 if (Present (Address_Clause (gnat_entity)))
3604 tree gnu_address = 0;
3608 = (present_gnu_tree (gnat_entity)
3609 ? get_gnu_tree (gnat_entity)
3610 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
3612 save_gnu_tree (gnat_entity, NULL_TREE, 0);
3614 gnu_type = build_reference_type (gnu_type);
3615 if (gnu_address != 0)
3616 gnu_address = convert (gnu_type, gnu_address);
3619 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
3620 gnu_address, 0, Is_Public (gnat_entity),
3621 extern_flag, 0, 0, gnat_entity);
3622 DECL_BY_REF_P (gnu_decl) = 1;
3625 else if (kind == E_Subprogram_Type)
3626 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3627 ! Comes_From_Source (gnat_entity),
3628 debug_info_p, gnat_entity);
3631 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
3632 gnu_type, gnu_param_list,
3633 inline_flag, public_flag,
3634 extern_flag, attr_list,
3636 DECL_STUBBED_P (gnu_decl)
3637 = Convention (gnat_entity) == Convention_Stubbed;
3642 case E_Incomplete_Type:
3643 case E_Private_Type:
3644 case E_Limited_Private_Type:
3645 case E_Record_Type_With_Private:
3646 case E_Private_Subtype:
3647 case E_Limited_Private_Subtype:
3648 case E_Record_Subtype_With_Private:
3650 /* If this type does not have a full view in the unit we are
3651 compiling, then just get the type from its Etype. */
3652 if (No (Full_View (gnat_entity)))
3654 /* If this is an incomplete type with no full view, it must
3655 be a Taft Amendement type, so just return a dummy type. */
3656 if (kind == E_Incomplete_Type)
3657 gnu_type = make_dummy_type (gnat_entity);
3659 else if (Present (Underlying_Full_View (gnat_entity)))
3660 gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
3664 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
3672 /* Otherwise, if we are not defining the type now, get the
3673 type from the full view. But always get the type from the full
3674 view for define on use types, since otherwise we won't see them! */
3676 else if (! definition
3677 || (Is_Itype (Full_View (gnat_entity))
3678 && No (Freeze_Node (gnat_entity)))
3679 || (Is_Itype (gnat_entity)
3680 && No (Freeze_Node (Full_View (gnat_entity)))))
3682 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
3688 /* For incomplete types, make a dummy type entry which will be
3690 gnu_type = make_dummy_type (gnat_entity);
3692 /* Save this type as the full declaration's type so we can do any needed
3693 updates when we see it. */
3694 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3695 ! Comes_From_Source (gnat_entity),
3696 debug_info_p, gnat_entity);
3697 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
3700 /* Simple class_wide types are always viewed as their root_type
3701 by Gigi unless an Equivalent_Type is specified. */
3702 case E_Class_Wide_Type:
3703 if (Present (Equivalent_Type (gnat_entity)))
3704 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3706 gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity));
3712 case E_Task_Subtype:
3713 case E_Protected_Type:
3714 case E_Protected_Subtype:
3715 if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity)))
3716 gnu_type = void_type_node;
3718 gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity));
3724 gnu_decl = create_label_decl (gnu_entity_id);
3729 /* Nothing at all to do here, so just return an ERROR_MARK and claim
3730 we've already saved it, so we don't try to. */
3731 gnu_decl = error_mark_node;
3739 /* If we had a case where we evaluated another type and it might have
3740 defined this one, handle it here. */
3741 if (maybe_present && present_gnu_tree (gnat_entity))
3743 gnu_decl = get_gnu_tree (gnat_entity);
3747 /* If we are processing a type and there is either no decl for it or
3748 we just made one, do some common processing for the type, such as
3749 handling alignment and possible padding. */
3751 if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind))
3753 if (Is_Tagged_Type (gnat_entity)
3754 || Is_Class_Wide_Equivalent_Type (gnat_entity))
3755 TYPE_ALIGN_OK (gnu_type) = 1;
3757 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
3758 TYPE_BY_REFERENCE_P (gnu_type) = 1;
3760 /* ??? Don't set the size for a String_Literal since it is either
3761 confirming or we don't handle it properly (if the low bound is
3763 if (gnu_size == 0 && kind != E_String_Literal_Subtype)
3764 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
3765 TYPE_DECL, 0, Has_Size_Clause (gnat_entity));
3767 /* If a size was specified, see if we can make a new type of that size
3768 by rearranging the type, for example from a fat to a thin pointer. */
3772 = make_type_from_size (gnu_type, gnu_size,
3773 Has_Biased_Representation (gnat_entity));
3775 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
3776 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
3780 /* If the alignment hasn't already been processed and this is
3781 not an unconstrained array, see if an alignment is specified.
3782 If not, we pick a default alignment for atomic objects. */
3783 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3785 else if (Known_Alignment (gnat_entity))
3786 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
3787 TYPE_ALIGN (gnu_type));
3788 else if (Is_Atomic (gnat_entity) && gnu_size == 0
3789 && host_integerp (TYPE_SIZE (gnu_type), 1)
3790 && integer_pow2p (TYPE_SIZE (gnu_type)))
3791 align = MIN (BIGGEST_ALIGNMENT,
3792 tree_low_cst (TYPE_SIZE (gnu_type), 1));
3793 else if (Is_Atomic (gnat_entity) && gnu_size != 0
3794 && host_integerp (gnu_size, 1)
3795 && integer_pow2p (gnu_size))
3796 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
3798 /* See if we need to pad the type. If we did, and made a record,
3799 the name of the new type may be changed. So get it back for
3800 us when we make the new TYPE_DECL below. */
3801 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
3802 gnat_entity, "PAD", 1, definition, 0);
3803 if (TREE_CODE (gnu_type) == RECORD_TYPE
3804 && TYPE_IS_PADDING_P (gnu_type))
3806 gnu_entity_id = TYPE_NAME (gnu_type);
3807 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
3808 gnu_entity_id = DECL_NAME (gnu_entity_id);
3811 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
3813 /* If we are at global level, GCC will have applied variable_size to
3814 the type, but that won't have done anything. So, if it's not
3815 a constant or self-referential, call elaborate_expression_1 to
3816 make a variable for the size rather than calculating it each time.
3817 Handle both the RM size and the actual size. */
3818 if (global_bindings_p ()
3819 && TYPE_SIZE (gnu_type) != 0
3820 && ! TREE_CONSTANT (TYPE_SIZE (gnu_type))
3821 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
3823 if (TREE_CODE (gnu_type) == RECORD_TYPE
3824 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
3825 TYPE_SIZE (gnu_type), 0))
3827 TYPE_SIZE (gnu_type)
3828 = elaborate_expression_1 (gnat_entity, gnat_entity,
3829 TYPE_SIZE (gnu_type),
3830 get_identifier ("SIZE"),
3832 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
3836 TYPE_SIZE (gnu_type)
3837 = elaborate_expression_1 (gnat_entity, gnat_entity,
3838 TYPE_SIZE (gnu_type),
3839 get_identifier ("SIZE"),
3842 /* ??? For now, store the size as a multiple of the alignment
3843 in bytes so that we can see the alignment from the tree. */
3844 TYPE_SIZE_UNIT (gnu_type)
3846 (MULT_EXPR, sizetype,
3847 elaborate_expression_1
3848 (gnat_entity, gnat_entity,
3849 build_binary_op (EXACT_DIV_EXPR, sizetype,
3850 TYPE_SIZE_UNIT (gnu_type),
3851 size_int (TYPE_ALIGN (gnu_type)
3853 get_identifier ("SIZE_A_UNIT"),
3855 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3857 if (TREE_CODE (gnu_type) == RECORD_TYPE)
3860 elaborate_expression_1 (gnat_entity,
3862 TYPE_ADA_SIZE (gnu_type),
3863 get_identifier ("RM_SIZE"),
3868 /* If this is a record type or subtype, call elaborate_expression_1 on
3869 any field position. Do this for both global and local types.
3870 Skip any fields that we haven't made trees for to avoid problems with
3871 class wide types. */
3872 if (IN (kind, Record_Kind))
3873 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3874 gnat_temp = Next_Entity (gnat_temp))
3875 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
3877 tree gnu_field = get_gnu_tree (gnat_temp);
3879 /* ??? Unfortunately, GCC needs to be able to prove the
3880 alignment of this offset and if it's a variable, it can't.
3881 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
3882 right now, we have to put in an explicit multiply and
3883 divide by that value. */
3884 if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
3885 DECL_FIELD_OFFSET (gnu_field)
3887 (MULT_EXPR, sizetype,
3888 elaborate_expression_1
3889 (gnat_temp, gnat_temp,
3890 build_binary_op (EXACT_DIV_EXPR, sizetype,
3891 DECL_FIELD_OFFSET (gnu_field),
3892 size_int (DECL_OFFSET_ALIGN (gnu_field)
3894 get_identifier ("OFFSET"),
3896 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
3899 gnu_type = build_qualified_type (gnu_type,
3900 (TYPE_QUALS (gnu_type)
3901 | (TYPE_QUAL_VOLATILE
3902 * Treat_As_Volatile (gnat_entity))));
3904 if (Is_Atomic (gnat_entity))
3905 check_ok_for_atomic (gnu_type, gnat_entity, 0);
3907 if (Known_Alignment (gnat_entity))
3908 TYPE_USER_ALIGN (gnu_type) = 1;
3911 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3912 ! Comes_From_Source (gnat_entity),
3913 debug_info_p, gnat_entity);
3915 TREE_TYPE (gnu_decl) = gnu_type;
3918 if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
3920 gnu_type = TREE_TYPE (gnu_decl);
3922 /* Back-annotate the Alignment of the type if not already in the
3923 tree. Likewise for sizes. */
3924 if (Unknown_Alignment (gnat_entity))
3925 Set_Alignment (gnat_entity,
3926 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3928 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0)
3930 /* If the size is self-referential, we annotate the maximum
3931 value of that size. */
3932 tree gnu_size = TYPE_SIZE (gnu_type);
3934 if (CONTAINS_PLACEHOLDER_P (gnu_size))
3935 gnu_size = max_size (gnu_size, 1);
3937 Set_Esize (gnat_entity, annotate_value (gnu_size));
3939 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
3941 /* In this mode the tag and the parent components are not
3942 generated by the front-end, so the sizes must be adjusted
3948 if (Is_Derived_Type (gnat_entity))
3951 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
3952 Set_Alignment (gnat_entity,
3953 Alignment (Etype (Base_Type (gnat_entity))));
3956 size_offset = POINTER_SIZE;
3958 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
3959 Set_Esize (gnat_entity,
3960 UI_From_Int (((new_size + (POINTER_SIZE - 1))
3961 / POINTER_SIZE) * POINTER_SIZE));
3962 Set_RM_Size (gnat_entity, Esize (gnat_entity));
3966 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0)
3967 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
3970 if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
3971 DECL_ARTIFICIAL (gnu_decl) = 1;
3973 if (! debug_info_p && DECL_P (gnu_decl)
3974 && TREE_CODE (gnu_decl) != FUNCTION_DECL)
3975 DECL_IGNORED_P (gnu_decl) = 1;
3977 /* If we haven't already, associate the ..._DECL node that we just made with
3978 the input GNAT entity node. */
3980 save_gnu_tree (gnat_entity, gnu_decl, 0);
3982 /* If this is an enumeral or floating-point type, we were not able to set
3983 the bounds since they refer to the type. These bounds are always static.
3985 For enumeration types, also write debugging information and declare the
3986 enumeration literal table, if needed. */
3988 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
3989 || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity)))
3991 tree gnu_scalar_type = gnu_type;
3993 /* If this is a padded type, we need to use the underlying type. */
3994 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
3995 && TYPE_IS_PADDING_P (gnu_scalar_type))
3996 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
3998 /* If this is a floating point type and we haven't set a floating
3999 point type yet, use this in the evaluation of the bounds. */
4000 if (longest_float_type_node == 0 && kind == E_Floating_Point_Type)
4001 longest_float_type_node = gnu_type;
4003 TYPE_MIN_VALUE (gnu_scalar_type)
4004 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4005 TYPE_MAX_VALUE (gnu_scalar_type)
4006 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4008 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4010 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
4012 /* Since this has both a typedef and a tag, avoid outputting
4014 DECL_ARTIFICIAL (gnu_decl) = 1;
4015 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
4019 /* If we deferred processing of incomplete types, re-enable it. If there
4020 were no other disables and we have some to process, do so. */
4021 if (this_deferred && --defer_incomplete_level == 0
4022 && defer_incomplete_list != 0)
4024 struct incomplete *incp = defer_incomplete_list;
4025 struct incomplete *next;
4027 defer_incomplete_list = 0;
4028 for (; incp; incp = next)
4032 if (incp->old_type != 0)
4033 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4034 gnat_to_gnu_type (incp->full_type));
4039 /* If we are not defining this type, see if it's in the incomplete list.
4040 If so, handle that list entry now. */
4041 else if (! definition)
4043 struct incomplete *incp;
4045 for (incp = defer_incomplete_list; incp; incp = incp->next)
4046 if (incp->old_type != 0 && incp->full_type == gnat_entity)
4048 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4049 TREE_TYPE (gnu_decl));
4057 if (Is_Packed_Array_Type (gnat_entity)
4058 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4059 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4060 && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4061 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4066 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4067 be elaborated at the point of its definition, but do nothing else. */
4070 elaborate_entity (Entity_Id gnat_entity)
4072 switch (Ekind (gnat_entity))
4074 case E_Signed_Integer_Subtype:
4075 case E_Modular_Integer_Subtype:
4076 case E_Enumeration_Subtype:
4077 case E_Ordinary_Fixed_Point_Subtype:
4078 case E_Decimal_Fixed_Point_Subtype:
4079 case E_Floating_Point_Subtype:
4081 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4082 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4084 /* ??? Tests for avoiding static constaint error expression
4085 is needed until the front stops generating bogus conversions
4086 on bounds of real types. */
4088 if (! Raises_Constraint_Error (gnat_lb))
4089 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4090 1, 0, Needs_Debug_Info (gnat_entity));
4091 if (! Raises_Constraint_Error (gnat_hb))
4092 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4093 1, 0, Needs_Debug_Info (gnat_entity));
4099 Node_Id full_definition = Declaration_Node (gnat_entity);
4100 Node_Id record_definition = Type_Definition (full_definition);
4102 /* If this is a record extension, go a level further to find the
4103 record definition. */
4104 if (Nkind (record_definition) == N_Derived_Type_Definition)
4105 record_definition = Record_Extension_Part (record_definition);
4109 case E_Record_Subtype:
4110 case E_Private_Subtype:
4111 case E_Limited_Private_Subtype:
4112 case E_Record_Subtype_With_Private:
4113 if (Is_Constrained (gnat_entity)
4114 && Has_Discriminants (Base_Type (gnat_entity))
4115 && Present (Discriminant_Constraint (gnat_entity)))
4117 Node_Id gnat_discriminant_expr;
4118 Entity_Id gnat_field;
4120 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
4121 gnat_discriminant_expr
4122 = First_Elmt (Discriminant_Constraint (gnat_entity));
4123 Present (gnat_field);
4124 gnat_field = Next_Discriminant (gnat_field),
4125 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
4126 /* ??? For now, ignore access discriminants. */
4127 if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
4128 elaborate_expression (Node (gnat_discriminant_expr),
4130 get_entity_name (gnat_field), 1, 0, 0);
4137 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4138 any entities on its entity chain similarly. */
4141 mark_out_of_scope (Entity_Id gnat_entity)
4143 Entity_Id gnat_sub_entity;
4144 unsigned int kind = Ekind (gnat_entity);
4146 /* If this has an entity list, process all in the list. */
4147 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
4148 || IN (kind, Private_Kind)
4149 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
4150 || kind == E_Function || kind == E_Generic_Function
4151 || kind == E_Generic_Package || kind == E_Generic_Procedure
4152 || kind == E_Loop || kind == E_Operator || kind == E_Package
4153 || kind == E_Package_Body || kind == E_Procedure
4154 || kind == E_Record_Type || kind == E_Record_Subtype
4155 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
4156 for (gnat_sub_entity = First_Entity (gnat_entity);
4157 Present (gnat_sub_entity);
4158 gnat_sub_entity = Next_Entity (gnat_sub_entity))
4159 if (Scope (gnat_sub_entity) == gnat_entity
4160 && gnat_sub_entity != gnat_entity)
4161 mark_out_of_scope (gnat_sub_entity);
4163 /* Now clear this if it has been defined, but only do so if it isn't
4164 a subprogram or parameter. We could refine this, but it isn't
4165 worth it. If this is statically allocated, it is supposed to
4166 hang around out of cope. */
4167 if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity)
4168 && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind))
4170 save_gnu_tree (gnat_entity, NULL_TREE, 1);
4171 save_gnu_tree (gnat_entity, error_mark_node, 1);
4175 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4176 is a multi-dimensional array type, do this recursively. */
4179 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
4181 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
4182 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
4183 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
4185 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4186 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4187 so we need to go down to what does. */
4188 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
4190 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
4192 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
4195 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
4196 record_component_aliases (gnu_new_type);
4199 /* Return a TREE_LIST describing the substitutions needed to reflect
4200 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4201 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4202 of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE
4203 gives the tree for the discriminant and TREE_VALUES is the replacement
4204 value. They are in the form of operands to substitute_in_expr.
4205 DEFINITION is as in gnat_to_gnu_entity. */
4208 substitution_list (Entity_Id gnat_subtype,
4209 Entity_Id gnat_type,
4213 Entity_Id gnat_discrim;
4217 gnat_type = Implementation_Base_Type (gnat_subtype);
4219 if (Has_Discriminants (gnat_type))
4220 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
4221 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
4222 Present (gnat_discrim);
4223 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
4224 gnat_value = Next_Elmt (gnat_value))
4225 /* Ignore access discriminants. */
4226 if (! Is_Access_Type (Etype (Node (gnat_value))))
4227 gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0),
4228 elaborate_expression
4229 (Node (gnat_value), gnat_subtype,
4230 get_entity_name (gnat_discrim), definition,
4237 /* For the following two functions: for each GNAT entity, the GCC
4238 tree node used as a dummy for that entity, if any. */
4240 static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
4242 /* Initialize the above table. */
4245 init_dummy_type (void)
4249 dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
4251 for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
4252 dummy_node_table[gnat_node] = NULL_TREE;
4254 dummy_node_table -= First_Node_Id;
4257 /* Make a dummy type corresponding to GNAT_TYPE. */
4260 make_dummy_type (Entity_Id gnat_type)
4262 Entity_Id gnat_underlying;
4265 /* Find a full type for GNAT_TYPE, taking into account any class wide
4267 if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
4268 gnat_type = Equivalent_Type (gnat_type);
4269 else if (Ekind (gnat_type) == E_Class_Wide_Type)
4270 gnat_type = Root_Type (gnat_type);
4272 for (gnat_underlying = gnat_type;
4273 (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
4274 && Present (Full_View (gnat_underlying)));
4275 gnat_underlying = Full_View (gnat_underlying))
4278 /* If it there already a dummy type, use that one. Else make one. */
4279 if (dummy_node_table[gnat_underlying])
4280 return dummy_node_table[gnat_underlying];
4282 /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
4284 if (Is_Record_Type (gnat_underlying))
4285 gnu_type = make_node (Is_Unchecked_Union (gnat_underlying)
4286 ? UNION_TYPE : RECORD_TYPE);
4288 gnu_type = make_node (ENUMERAL_TYPE);
4290 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
4291 TYPE_DUMMY_P (gnu_type) = 1;
4292 if (AGGREGATE_TYPE_P (gnu_type))
4293 TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
4295 dummy_node_table[gnat_underlying] = gnu_type;
4300 /* Return 1 if the size represented by GNU_SIZE can be handled by an
4301 allocation. If STATIC_P is non-zero, consider only what can be
4302 done with a static allocation. */
4305 allocatable_size_p (tree gnu_size, int static_p)
4307 HOST_WIDE_INT our_size;
4309 /* If this is not a static allocation, the only case we want to forbid
4310 is an overflowing size. That will be converted into a raise a
4313 return ! (TREE_CODE (gnu_size) == INTEGER_CST
4314 && TREE_CONSTANT_OVERFLOW (gnu_size));
4316 /* Otherwise, we need to deal with both variable sizes and constant
4317 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4318 since assemblers may not like very large sizes. */
4319 if (!host_integerp (gnu_size, 1))
4322 our_size = tree_low_cst (gnu_size, 1);
4323 return (int) our_size == our_size;
4326 /* Return a list of attributes for GNAT_ENTITY, if any. */
4328 static struct attrib *
4329 build_attr_list (Entity_Id gnat_entity)
4331 struct attrib *attr_list = 0;
4334 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
4335 gnat_temp = Next_Rep_Item (gnat_temp))
4336 if (Nkind (gnat_temp) == N_Pragma)
4338 struct attrib *attr;
4339 tree gnu_arg0 = 0, gnu_arg1 = 0;
4340 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
4341 enum attr_type etype;
4343 if (Present (gnat_assoc) && Present (First (gnat_assoc))
4344 && Present (Next (First (gnat_assoc)))
4345 && (Nkind (Expression (Next (First (gnat_assoc))))
4346 == N_String_Literal))
4348 gnu_arg0 = get_identifier (TREE_STRING_POINTER
4351 (First (gnat_assoc))))));
4352 if (Present (Next (Next (First (gnat_assoc))))
4353 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
4354 == N_String_Literal))
4355 gnu_arg1 = get_identifier (TREE_STRING_POINTER
4359 (First (gnat_assoc)))))));
4362 switch (Get_Pragma_Id (Chars (gnat_temp)))
4364 case Pragma_Machine_Attribute:
4365 etype = ATTR_MACHINE_ATTRIBUTE;
4368 case Pragma_Linker_Alias:
4369 etype = ATTR_LINK_ALIAS;
4372 case Pragma_Linker_Section:
4373 etype = ATTR_LINK_SECTION;
4376 case Pragma_Weak_External:
4377 etype = ATTR_WEAK_EXTERNAL;
4384 attr = (struct attrib *) xmalloc (sizeof (struct attrib));
4385 attr->next = attr_list;
4387 attr->name = gnu_arg0;
4388 attr->arg = gnu_arg1;
4390 = Present (Next (First (gnat_assoc)))
4391 ? Expression (Next (First (gnat_assoc))) : gnat_temp;
4398 /* Get the unpadded version of a GNAT type. */
4401 get_unpadded_type (Entity_Id gnat_entity)
4403 tree type = gnat_to_gnu_type (gnat_entity);
4405 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4406 type = TREE_TYPE (TYPE_FIELDS (type));
4411 /* Called when we need to protect a variable object using a save_expr. */
4414 maybe_variable (tree gnu_operand)
4416 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
4417 || TREE_CODE (gnu_operand) == SAVE_EXPR
4418 || TREE_CODE (gnu_operand) == NULL_EXPR)
4421 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
4423 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
4424 TREE_TYPE (gnu_operand),
4425 variable_size (TREE_OPERAND (gnu_operand, 0)));
4427 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
4428 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
4432 return variable_size (gnu_operand);
4435 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4436 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4437 return the GCC tree to use for that expression. GNU_NAME is the
4438 qualification to use if an external name is appropriate and DEFINITION is
4439 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4440 we need a result. Otherwise, we are just elaborating this for
4441 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4442 purposes even if it isn't needed for code generation. */
4445 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
4446 tree gnu_name, bool definition, bool need_value,
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. Since
4470 this is not a DECL, don't check it. Don't save if it's a discriminant. */
4471 if (! CONTAINS_PLACEHOLDER_P (gnu_expr))
4472 save_gnu_tree (gnat_expr, gnu_expr, 1);
4474 return need_value ? gnu_expr : error_mark_node;
4477 /* Similar, but take a GNU expression. */
4480 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
4481 tree gnu_expr, tree gnu_name, bool definition,
4485 /* Strip any conversions to see if the expression is a readonly variable.
4486 ??? This really should remain readonly, but we have to think about
4487 the typing of the tree here. */
4488 tree gnu_inner_expr = remove_conversions (gnu_expr, 1);
4489 int expr_global = Is_Public (gnat_entity) || global_bindings_p ();
4492 /* In most cases, we won't see a naked FIELD_DECL here because a
4493 discriminant reference will have been replaced with a COMPONENT_REF
4494 when the type is being elaborated. However, there are some cases
4495 involving child types where we will. So convert it to a COMPONENT_REF
4496 here. We have to hope it will be at the highest level of the
4497 expression in these cases. */
4498 if (TREE_CODE (gnu_expr) == FIELD_DECL)
4499 gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
4500 build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
4501 gnu_expr, NULL_TREE);
4503 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
4504 that is a constant, make a variable that is initialized to contain the
4505 bound when the package containing the definition is elaborated. If
4506 this entity is defined at top level and a bound or discriminant value
4507 isn't a constant or a reference to a discriminant, replace the bound
4508 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
4509 rely here on the fact that an expression cannot contain both the
4510 discriminant and some other variable. */
4512 expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c'
4513 && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL
4514 && TREE_READONLY (gnu_inner_expr))
4515 && ! CONTAINS_PLACEHOLDER_P (gnu_expr));
4517 /* If this is a static expression or contains a discriminant, we don't
4518 need the variable for debugging (and can't elaborate anyway if a
4521 && (Is_OK_Static_Expression (gnat_expr)
4522 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
4525 /* Now create the variable if we need it. */
4526 if (need_debug || (expr_variable && expr_global))
4528 = create_var_decl (create_concat_name (gnat_entity,
4529 IDENTIFIER_POINTER (gnu_name)),
4530 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
4531 Is_Public (gnat_entity), ! definition, 0, 0,
4534 /* We only need to use this variable if we are in global context since GCC
4535 can do the right thing in the local case. */
4536 if (expr_global && expr_variable)
4538 else if (! expr_variable)
4541 return maybe_variable (gnu_expr);
4544 /* Create a record type that contains a field of TYPE with a starting bit
4545 position so that it is aligned to ALIGN bits and is SIZE bytes long. */
4548 make_aligning_type (tree type, int align, tree size)
4550 tree record_type = make_node (RECORD_TYPE);
4551 tree place = build (PLACEHOLDER_EXPR, record_type);
4552 tree size_addr_place = convert (sizetype,
4553 build_unary_op (ADDR_EXPR, NULL_TREE,
4555 tree name = TYPE_NAME (type);
4558 if (TREE_CODE (name) == TYPE_DECL)
4559 name = DECL_NAME (name);
4561 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
4563 /* The bit position is obtained by "and"ing the alignment minus 1
4564 with the two's complement of the address and multiplying
4565 by the number of bits per unit. Do all this in sizetype. */
4567 pos = size_binop (MULT_EXPR,
4568 convert (bitsizetype,
4569 size_binop (BIT_AND_EXPR,
4570 size_diffop (size_zero_node,
4572 ssize_int ((align / BITS_PER_UNIT)
4576 field = create_field_decl (get_identifier ("F"), type, record_type,
4578 DECL_BIT_FIELD (field) = 0;
4580 finish_record_type (record_type, field, 1, 0);
4581 TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
4582 TYPE_SIZE (record_type)
4583 = size_binop (PLUS_EXPR,
4584 size_binop (MULT_EXPR, convert (bitsizetype, size),
4586 bitsize_int (align));
4587 TYPE_SIZE_UNIT (record_type)
4588 = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
4589 copy_alias_set (record_type, type);
4593 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
4594 being used as the field type of a packed record. See if we can rewrite it
4595 as a record that has a non-BLKmode type, which we can pack tighter. If so,
4596 return the new type. If not, return the original type. */
4599 make_packable_type (tree type)
4601 tree new_type = make_node (TREE_CODE (type));
4602 tree field_list = NULL_TREE;
4605 /* Copy the name and flags from the old type to that of the new and set
4606 the alignment to try for an integral type. For QUAL_UNION_TYPE,
4607 also copy the size. */
4608 TYPE_NAME (new_type) = TYPE_NAME (type);
4609 TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
4610 = TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
4611 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
4613 if (TREE_CODE (type) == RECORD_TYPE)
4614 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
4615 else if (TREE_CODE (type) == QUAL_UNION_TYPE)
4617 TYPE_SIZE (new_type) = TYPE_SIZE (type);
4618 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
4621 TYPE_ALIGN (new_type)
4622 = ((HOST_WIDE_INT) 1
4623 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
4625 /* Now copy the fields, keeping the position and size. */
4626 for (old_field = TYPE_FIELDS (type); old_field != 0;
4627 old_field = TREE_CHAIN (old_field))
4629 tree new_field_type = TREE_TYPE (old_field);
4632 if (TYPE_MODE (new_field_type) == BLKmode
4633 && (TREE_CODE (new_field_type) == RECORD_TYPE
4634 || TREE_CODE (new_field_type) == UNION_TYPE
4635 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
4636 && host_integerp (TYPE_SIZE (new_field_type), 1))
4637 new_field_type = make_packable_type (new_field_type);
4639 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
4640 new_type, TYPE_PACKED (type),
4641 DECL_SIZE (old_field),
4642 bit_position (old_field),
4643 ! DECL_NONADDRESSABLE_P (old_field));
4645 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
4646 SET_DECL_ORIGINAL_FIELD
4647 (new_field, (DECL_ORIGINAL_FIELD (old_field) != 0
4648 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
4650 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
4651 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
4653 TREE_CHAIN (new_field) = field_list;
4654 field_list = new_field;
4657 finish_record_type (new_type, nreverse (field_list), 1, 1);
4658 copy_alias_set (new_type, type);
4659 return TYPE_MODE (new_type) == BLKmode ? type : new_type;
4662 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
4663 if needed. We have already verified that SIZE and TYPE are large enough.
4665 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
4668 IS_USER_TYPE is nonzero if we must be sure we complete the original type.
4670 DEFINITION is nonzero if this type is being defined.
4672 SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be
4673 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
4677 maybe_pad_type (tree type, tree size, unsigned int align,
4678 Entity_Id gnat_entity, const char *name_trailer,
4679 int is_user_type, int definition, int same_rm_size)
4681 tree orig_size = TYPE_SIZE (type);
4685 /* If TYPE is a padded type, see if it agrees with any size and alignment
4686 we were given. If so, return the original type. Otherwise, strip
4687 off the padding, since we will either be returning the inner type
4688 or repadding it. If no size or alignment is specified, use that of
4689 the original padded type. */
4691 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4694 || operand_equal_p (round_up (size,
4695 MAX (align, TYPE_ALIGN (type))),
4696 round_up (TYPE_SIZE (type),
4697 MAX (align, TYPE_ALIGN (type))),
4699 && (align == 0 || align == TYPE_ALIGN (type)))
4703 size = TYPE_SIZE (type);
4705 align = TYPE_ALIGN (type);
4707 type = TREE_TYPE (TYPE_FIELDS (type));
4708 orig_size = TYPE_SIZE (type);
4711 /* If the size is either not being changed or is being made smaller (which
4712 is not done here (and is only valid for bitfields anyway), show the size
4713 isn't changing. Likewise, clear the alignment if it isn't being
4714 changed. Then return if we aren't doing anything. */
4717 && (operand_equal_p (size, orig_size, 0)
4718 || (TREE_CODE (orig_size) == INTEGER_CST
4719 && tree_int_cst_lt (size, orig_size))))
4722 if (align == TYPE_ALIGN (type))
4725 if (align == 0 && size == 0)
4728 /* We used to modify the record in place in some cases, but that could
4729 generate incorrect debugging information. So make a new record
4731 record = make_node (RECORD_TYPE);
4733 if (Present (gnat_entity))
4734 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
4736 /* If we were making a type, complete the original type and give it a
4739 create_type_decl (get_entity_name (gnat_entity), type,
4740 0, ! Comes_From_Source (gnat_entity),
4741 ! (TYPE_NAME (type) != 0
4742 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
4743 && DECL_IGNORED_P (TYPE_NAME (type))),
4746 /* If we are changing the alignment and the input type is a record with
4747 BLKmode and a small constant size, try to make a form that has an
4748 integral mode. That might allow this record to have an integral mode,
4749 which will be much more efficient. There is no point in doing this if a
4750 size is specified unless it is also smaller than the biggest alignment
4751 and it is incorrect to do this if the size of the original type is not a
4752 multiple of the alignment. */
4754 && TREE_CODE (type) == RECORD_TYPE
4755 && TYPE_MODE (type) == BLKmode
4756 && host_integerp (orig_size, 1)
4757 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
4759 || (TREE_CODE (size) == INTEGER_CST
4760 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
4761 && tree_low_cst (orig_size, 1) % align == 0)
4762 type = make_packable_type (type);
4764 field = create_field_decl (get_identifier ("F"), type, record, 0,
4765 NULL_TREE, bitsize_zero_node, 1);
4767 DECL_INTERNAL_P (field) = 1;
4768 TYPE_SIZE (record) = size != 0 ? size : orig_size;
4769 TYPE_SIZE_UNIT (record)
4770 = convert (sizetype,
4771 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
4772 bitsize_unit_node));
4773 TYPE_ALIGN (record) = align;
4774 TYPE_IS_PADDING_P (record) = 1;
4775 TYPE_VOLATILE (record)
4776 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
4777 finish_record_type (record, field, 1, 0);
4779 /* Keep the RM_Size of the padded record as that of the old record
4781 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
4783 /* Unless debugging information isn't being written for the input type,
4784 write a record that shows what we are a subtype of and also make a
4785 variable that indicates our size, if variable. */
4786 if (TYPE_NAME (record) != 0
4787 && AGGREGATE_TYPE_P (type)
4788 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
4789 || ! DECL_IGNORED_P (TYPE_NAME (type))))
4791 tree marker = make_node (RECORD_TYPE);
4792 tree name = (TREE_CODE (TYPE_NAME (record)) == TYPE_DECL
4793 ? DECL_NAME (TYPE_NAME (record))
4794 : TYPE_NAME (record));
4795 tree orig_name = TYPE_NAME (type);
4797 if (TREE_CODE (orig_name) == TYPE_DECL)
4798 orig_name = DECL_NAME (orig_name);
4800 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
4801 finish_record_type (marker,
4802 create_field_decl (orig_name, integer_type_node,
4803 marker, 0, NULL_TREE, NULL_TREE,
4807 if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
4808 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
4809 sizetype, TYPE_SIZE (record), 0, 0, 0, 0, 0,
4815 if (CONTAINS_PLACEHOLDER_P (orig_size))
4816 orig_size = max_size (orig_size, 1);
4818 /* If the size was widened explicitly, maybe give a warning. */
4819 if (size != 0 && Present (gnat_entity)
4820 && ! operand_equal_p (size, orig_size, 0)
4821 && ! (TREE_CODE (size) == INTEGER_CST
4822 && TREE_CODE (orig_size) == INTEGER_CST
4823 && tree_int_cst_lt (size, orig_size)))
4825 Node_Id gnat_error_node = Empty;
4827 if (Is_Packed_Array_Type (gnat_entity))
4828 gnat_entity = Associated_Node_For_Itype (gnat_entity);
4830 if ((Ekind (gnat_entity) == E_Component
4831 || Ekind (gnat_entity) == E_Discriminant)
4832 && Present (Component_Clause (gnat_entity)))
4833 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
4834 else if (Present (Size_Clause (gnat_entity)))
4835 gnat_error_node = Expression (Size_Clause (gnat_entity));
4837 /* Generate message only for entities that come from source, since
4838 if we have an entity created by expansion, the message will be
4839 generated for some other corresponding source entity. */
4840 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
4841 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
4843 size_diffop (size, orig_size));
4845 else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity))
4846 post_error_ne_tree ("component of& padded{ by ^ bits}?",
4847 gnat_entity, gnat_entity,
4848 size_diffop (size, orig_size));
4854 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
4855 the value passed against the list of choices. */
4858 choices_to_gnu (tree operand, Node_Id choices)
4862 tree result = integer_zero_node;
4863 tree this_test, low = 0, high = 0, single = 0;
4865 for (choice = First (choices); Present (choice); choice = Next (choice))
4867 switch (Nkind (choice))
4870 low = gnat_to_gnu (Low_Bound (choice));
4871 high = gnat_to_gnu (High_Bound (choice));
4873 /* There's no good type to use here, so we might as well use
4874 integer_type_node. */
4876 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4877 build_binary_op (GE_EXPR, integer_type_node,
4879 build_binary_op (LE_EXPR, integer_type_node,
4884 case N_Subtype_Indication:
4885 gnat_temp = Range_Expression (Constraint (choice));
4886 low = gnat_to_gnu (Low_Bound (gnat_temp));
4887 high = gnat_to_gnu (High_Bound (gnat_temp));
4890 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4891 build_binary_op (GE_EXPR, integer_type_node,
4893 build_binary_op (LE_EXPR, integer_type_node,
4898 case N_Expanded_Name:
4899 /* This represents either a subtype range, an enumeration
4900 literal, or a constant Ekind says which. If an enumeration
4901 literal or constant, fall through to the next case. */
4902 if (Ekind (Entity (choice)) != E_Enumeration_Literal
4903 && Ekind (Entity (choice)) != E_Constant)
4905 tree type = gnat_to_gnu_type (Entity (choice));
4907 low = TYPE_MIN_VALUE (type);
4908 high = TYPE_MAX_VALUE (type);
4911 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4912 build_binary_op (GE_EXPR, integer_type_node,
4914 build_binary_op (LE_EXPR, integer_type_node,
4918 /* ... fall through ... */
4919 case N_Character_Literal:
4920 case N_Integer_Literal:
4921 single = gnat_to_gnu (choice);
4922 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
4926 case N_Others_Choice:
4927 this_test = integer_one_node;
4934 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4941 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
4942 placed in GNU_RECORD_TYPE.
4944 PACKED is 1 if the enclosing record is packed and -1 if the enclosing
4945 record has a Component_Alignment of Storage_Unit.
4947 DEFINITION is nonzero if this field is for a record being defined. */
4950 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
4953 tree gnu_field_id = get_entity_name (gnat_field);
4954 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
4955 tree gnu_orig_field_type = gnu_field_type;
4959 int needs_strict_alignment
4960 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
4961 || Treat_As_Volatile (gnat_field));
4963 /* If this field requires strict alignment or contains an item of
4964 variable sized, pretend it isn't packed. */
4965 if (needs_strict_alignment || is_variable_size (gnu_field_type))
4968 /* For packed records, this is one of the few occasions on which we use
4969 the official RM size for discrete or fixed-point components, instead
4970 of the normal GNAT size stored in Esize. See description in Einfo:
4971 "Handling of Type'Size Values" for further details. */
4974 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
4975 gnat_field, FIELD_DECL, 0, 1);
4977 if (Known_Static_Esize (gnat_field))
4978 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
4979 gnat_field, FIELD_DECL, 0, 1);
4981 /* If the field's type is left-justified modular, the wrapper can prevent
4982 packing so we make the field the type of the inner object unless the
4983 situation forbids it. We may not do that when the field is addressable_p,
4984 typically because in that case this field may later be passed by-ref for
4985 a formal argument expecting the left justification. The condition below
4986 is then matching the addressable_p code for COMPONENT_REF. */
4987 if (! Is_Aliased (gnat_field) && flag_strict_aliasing
4988 && TREE_CODE (gnu_field_type) == RECORD_TYPE
4989 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
4990 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
4992 /* If we are packing this record, have a specified size that's smaller than
4993 that of the field type, or a position is specified, and the field type
4994 is also a record that's BLKmode and with a small constant size, see if
4995 we can get a better form of the type that allows more packing. If we
4996 can, show a size was specified for it if there wasn't one so we know to
4997 make this a bitfield and avoid making things wider. */
4998 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
4999 && TYPE_MODE (gnu_field_type) == BLKmode
5000 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
5001 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
5003 || (gnu_size != 0 && tree_int_cst_lt (gnu_size,
5004 TYPE_SIZE (gnu_field_type)))
5005 || Present (Component_Clause (gnat_field))))
5007 gnu_field_type = make_packable_type (gnu_field_type);
5009 if (gnu_field_type != gnu_orig_field_type && gnu_size == 0)
5010 gnu_size = rm_size (gnu_field_type);
5013 /* If we are packing the record and the field is BLKmode, round the
5014 size up to a byte boundary. */
5015 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0)
5016 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
5018 if (Present (Component_Clause (gnat_field)))
5020 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
5021 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5022 gnat_field, FIELD_DECL, 0, 1);
5024 /* Ensure the position does not overlap with the parent subtype,
5026 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
5029 = gnat_to_gnu_type (Parent_Subtype
5030 (Underlying_Type (Scope (gnat_field))));
5032 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
5033 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
5036 ("offset of& must be beyond parent{, minimum allowed is ^}",
5037 First_Bit (Component_Clause (gnat_field)), gnat_field,
5038 TYPE_SIZE_UNIT (gnu_parent));
5042 /* If this field needs strict alignment, ensure the record is
5043 sufficiently aligned and that that position and size are
5044 consistent with the alignment. */
5045 if (needs_strict_alignment)
5047 tree gnu_min_size = round_up (rm_size (gnu_field_type),
5048 TYPE_ALIGN (gnu_field_type));
5050 TYPE_ALIGN (gnu_record_type)
5051 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
5053 /* If Atomic, the size must match exactly and if aliased, the size
5054 must not be less than the rounded size. */
5055 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
5056 && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
5059 ("atomic field& must be natural size of type{ (^)}",
5060 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5061 TYPE_SIZE (gnu_field_type));
5066 else if (Is_Aliased (gnat_field)
5068 && tree_int_cst_lt (gnu_size, gnu_min_size))
5071 ("size of aliased field& too small{, minimum required is ^}",
5072 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5077 if (! integer_zerop (size_binop
5078 (TRUNC_MOD_EXPR, gnu_pos,
5079 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
5081 if (Is_Aliased (gnat_field))
5083 ("position of aliased field& must be multiple of ^ bits",
5084 First_Bit (Component_Clause (gnat_field)), gnat_field,
5085 TYPE_ALIGN (gnu_field_type));
5087 else if (Treat_As_Volatile (gnat_field))
5089 ("position of volatile field& must be multiple of ^ bits",
5090 First_Bit (Component_Clause (gnat_field)), gnat_field,
5091 TYPE_ALIGN (gnu_field_type));
5093 else if (Strict_Alignment (Etype (gnat_field)))
5095 ("position of & with aliased or tagged components not multiple of ^ bits",
5096 First_Bit (Component_Clause (gnat_field)), gnat_field,
5097 TYPE_ALIGN (gnu_field_type));
5104 /* If an error set the size to zero, show we have no position
5110 if (Is_Atomic (gnat_field))
5111 check_ok_for_atomic (gnu_field_type, gnat_field, 0);
5114 /* If the record has rep clauses and this is the tag field, make a rep
5115 clause for it as well. */
5116 else if (Has_Specified_Layout (Scope (gnat_field))
5117 && Chars (gnat_field) == Name_uTag)
5119 gnu_pos = bitsize_zero_node;
5120 gnu_size = TYPE_SIZE (gnu_field_type);
5123 /* We need to make the size the maximum for the type if it is
5124 self-referential and an unconstrained type. In that case, we can't
5125 pack the field since we can't make a copy to align it. */
5126 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5128 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
5129 && ! Is_Constrained (Underlying_Type (Etype (gnat_field))))
5131 gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1);
5135 /* If no size is specified (or if there was an error), don't specify a
5141 /* Unless this field is aliased, we can remove any left-justified
5142 modular type since it's only needed in the unchecked conversion
5143 case, which doesn't apply here. */
5144 if (! needs_strict_alignment
5145 && TREE_CODE (gnu_field_type) == RECORD_TYPE
5146 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
5147 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5150 = make_type_from_size (gnu_field_type, gnu_size,
5151 Has_Biased_Representation (gnat_field));
5152 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0,
5153 gnat_field, "PAD", 0, definition, 1);
5156 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5157 && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
5160 /* Now create the decl for the field. */
5161 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
5162 packed, gnu_size, gnu_pos,
5163 Is_Aliased (gnat_field));
5164 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
5165 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
5167 if (Ekind (gnat_field) == E_Discriminant)
5168 DECL_DISCRIMINANT_NUMBER (gnu_field)
5169 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
5174 /* Return 1 if TYPE is a type with variable size, a padding type with a field
5175 of variable size or is a record that has a field such a field. */
5178 is_variable_size (tree type)
5182 /* We need not be concerned about this at all if we don't have
5183 strict alignment. */
5184 if (! STRICT_ALIGNMENT)
5186 else if (! TREE_CONSTANT (TYPE_SIZE (type)))
5188 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
5189 && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
5191 else if (TREE_CODE (type) != RECORD_TYPE
5192 && TREE_CODE (type) != UNION_TYPE
5193 && TREE_CODE (type) != QUAL_UNION_TYPE)
5196 for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field))
5197 if (is_variable_size (TREE_TYPE (field)))
5203 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5204 of GCC trees for fields that are in the record and have already been
5205 processed. When called from gnat_to_gnu_entity during the processing of a
5206 record type definition, the GCC nodes for the discriminants will be on
5207 the chain. The other calls to this function are recursive calls from
5208 itself for the Component_List of a variant and the chain is empty.
5210 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is
5211 for a record type with "pragma component_alignment (storage_unit)".
5213 FINISH_RECORD is nonzero if this call will supply all of the remaining
5214 fields of the record.
5216 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5217 with a rep clause is to be added. If it is nonzero, that is all that
5218 should be done with such fields.
5220 CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed
5221 before laying out the record. This means the alignment only serves
5222 to force fields to be bitfields, but not require the record to be
5223 that aligned. This is used for variants.
5225 ALL_REP, if nonzero, means that a rep clause was found for all the
5226 fields. This simplifies the logic since we know we're not in the mixed
5229 The processing of the component list fills in the chain with all of the
5230 fields of the record and then the record type is finished. */
5233 components_to_record (tree gnu_record_type, Node_Id component_list,
5234 tree gnu_field_list, int packed, int definition,
5235 tree *p_gnu_rep_list, int cancel_alignment, int all_rep)
5237 Node_Id component_decl;
5238 Entity_Id gnat_field;
5239 Node_Id variant_part;
5241 tree gnu_our_rep_list = NULL_TREE;
5242 tree gnu_field, gnu_last;
5243 int layout_with_rep = 0;
5244 int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0;
5246 /* For each variable within each component declaration create a GCC field
5247 and add it to the list, skipping any pragmas in the list. */
5249 if (Present (Component_Items (component_list)))
5250 for (component_decl = First_Non_Pragma (Component_Items (component_list));
5251 Present (component_decl);
5252 component_decl = Next_Non_Pragma (component_decl))
5254 gnat_field = Defining_Entity (component_decl);
5256 if (Chars (gnat_field) == Name_uParent)
5257 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
5260 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
5261 packed, definition);
5263 /* If this is the _Tag field, put it before any discriminants,
5264 instead of after them as is the case for all other fields.
5265 Ignore field of void type if only annotating. */
5266 if (Chars (gnat_field) == Name_uTag)
5267 gnu_field_list = chainon (gnu_field_list, gnu_field);
5270 TREE_CHAIN (gnu_field) = gnu_field_list;
5271 gnu_field_list = gnu_field;
5275 save_gnu_tree (gnat_field, gnu_field, 0);
5278 /* At the end of the component list there may be a variant part. */
5279 variant_part = Variant_Part (component_list);
5281 /* If this is an unchecked union, each variant must have exactly one
5282 component, each of which becomes one component of this union. */
5283 if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part))
5284 for (variant = First_Non_Pragma (Variants (variant_part));
5286 variant = Next_Non_Pragma (variant))
5289 = First_Non_Pragma (Component_Items (Component_List (variant)));
5290 gnat_field = Defining_Entity (component_decl);
5291 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
5293 TREE_CHAIN (gnu_field) = gnu_field_list;
5294 gnu_field_list = gnu_field;
5295 save_gnu_tree (gnat_field, gnu_field, 0);
5298 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5299 mutually exclusive and should go in the same memory. To do this we need
5300 to treat each variant as a record whose elements are created from the
5301 component list for the variant. So here we create the records from the
5302 lists for the variants and put them all into the QUAL_UNION_TYPE. */
5303 else if (Present (variant_part))
5305 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
5307 tree gnu_union_type = make_node (QUAL_UNION_TYPE);
5308 tree gnu_union_field;
5309 tree gnu_variant_list = NULL_TREE;
5310 tree gnu_name = TYPE_NAME (gnu_record_type);
5312 = concat_id_with_name
5313 (get_identifier (Get_Name_String (Chars (Name (variant_part)))),
5316 if (TREE_CODE (gnu_name) == TYPE_DECL)
5317 gnu_name = DECL_NAME (gnu_name);
5319 TYPE_NAME (gnu_union_type)
5320 = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
5321 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
5323 for (variant = First_Non_Pragma (Variants (variant_part));
5325 variant = Next_Non_Pragma (variant))
5327 tree gnu_variant_type = make_node (RECORD_TYPE);
5328 tree gnu_inner_name;
5331 Get_Variant_Encoding (variant);
5332 gnu_inner_name = get_identifier (Name_Buffer);
5333 TYPE_NAME (gnu_variant_type)
5334 = concat_id_with_name (TYPE_NAME (gnu_union_type),
5335 IDENTIFIER_POINTER (gnu_inner_name));
5337 /* Set the alignment of the inner type in case we need to make
5338 inner objects into bitfields, but then clear it out
5339 so the record actually gets only the alignment required. */
5340 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
5341 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
5343 /* Similarly, if the outer record has a size specified and all fields
5344 have record rep clauses, we can propagate the size into the
5346 if (all_rep_and_size)
5348 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
5349 TYPE_SIZE_UNIT (gnu_variant_type)
5350 = TYPE_SIZE_UNIT (gnu_record_type);
5353 components_to_record (gnu_variant_type, Component_List (variant),
5354 NULL_TREE, packed, definition,
5355 &gnu_our_rep_list, !all_rep_and_size, all_rep);
5357 gnu_qual = choices_to_gnu (gnu_discriminant,
5358 Discrete_Choices (variant));
5360 Set_Present_Expr (variant, annotate_value (gnu_qual));
5361 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
5364 ? TYPE_SIZE (gnu_record_type) : 0),
5366 ? bitsize_zero_node : 0),
5369 DECL_INTERNAL_P (gnu_field) = 1;
5370 DECL_QUALIFIER (gnu_field) = gnu_qual;
5371 TREE_CHAIN (gnu_field) = gnu_variant_list;
5372 gnu_variant_list = gnu_field;
5375 /* We use to delete the empty variants from the end. However,
5376 we no longer do that because we need them to generate complete
5377 debugging information for the variant record. Otherwise,
5378 the union type definition will be missing the fields associated
5379 to these empty variants. */
5381 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
5382 if (gnu_variant_list != 0)
5384 if (all_rep_and_size)
5386 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
5387 TYPE_SIZE_UNIT (gnu_union_type)
5388 = TYPE_SIZE_UNIT (gnu_record_type);
5391 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
5392 all_rep_and_size, 0);
5395 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
5397 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
5398 all_rep ? bitsize_zero_node : 0, 0);
5400 DECL_INTERNAL_P (gnu_union_field) = 1;
5401 TREE_CHAIN (gnu_union_field) = gnu_field_list;
5402 gnu_field_list = gnu_union_field;
5406 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
5407 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
5408 in a separate pass since we want to handle the discriminants but can't
5409 play with them until we've used them in debugging data above.
5411 ??? Note: if we then reorder them, debugging information will be wrong,
5412 but there's nothing that can be done about this at the moment. */
5414 for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; )
5416 if (DECL_FIELD_OFFSET (gnu_field) != 0)
5418 tree gnu_next = TREE_CHAIN (gnu_field);
5421 gnu_field_list = gnu_next;
5423 TREE_CHAIN (gnu_last) = gnu_next;
5425 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
5426 gnu_our_rep_list = gnu_field;
5427 gnu_field = gnu_next;
5431 gnu_last = gnu_field;
5432 gnu_field = TREE_CHAIN (gnu_field);
5436 /* If we have any items in our rep'ed field list, it is not the case that all
5437 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
5438 set it and ignore the items. Otherwise, sort the fields by bit position
5439 and put them into their own record if we have any fields without
5441 if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep)
5442 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
5443 else if (gnu_our_rep_list != 0)
5446 = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE);
5447 int len = list_length (gnu_our_rep_list);
5448 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
5451 /* Set DECL_SECTION_NAME to increasing integers so we have a
5453 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
5454 gnu_field = TREE_CHAIN (gnu_field), i++)
5456 gnu_arr[i] = gnu_field;
5457 DECL_SECTION_NAME (gnu_field) = size_int (i);
5460 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
5462 /* Put the fields in the list in order of increasing position, which
5463 means we start from the end. */
5464 gnu_our_rep_list = NULL_TREE;
5465 for (i = len - 1; i >= 0; i--)
5467 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
5468 gnu_our_rep_list = gnu_arr[i];
5469 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
5470 DECL_SECTION_NAME (gnu_arr[i]) = 0;
5473 if (gnu_field_list != 0)
5475 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0);
5476 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
5477 gnu_record_type, 0, 0, 0, 1);
5478 DECL_INTERNAL_P (gnu_field) = 1;
5479 gnu_field_list = chainon (gnu_field_list, gnu_field);
5483 layout_with_rep = 1;
5484 gnu_field_list = nreverse (gnu_our_rep_list);
5488 if (cancel_alignment)
5489 TYPE_ALIGN (gnu_record_type) = 0;
5491 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
5492 layout_with_rep, 0);
5495 /* Called via qsort from the above. Returns -1, 1, depending on the
5496 bit positions and ordinals of the two fields. */
5499 compare_field_bitpos (const PTR rt1, const PTR rt2)
5501 tree *t1 = (tree *) rt1;
5502 tree *t2 = (tree *) rt2;
5504 if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
5506 (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2))
5508 else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
5514 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
5515 placed into an Esize, Component_Bit_Offset, or Component_Size value
5516 in the GNAT tree. */
5519 annotate_value (tree gnu_size)
5521 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
5523 Node_Ref_Or_Val ops[3], ret;
5527 /* If back annotation is suppressed by the front end, return No_Uint */
5528 if (!Back_Annotate_Rep_Info)
5531 /* See if we've already saved the value for this node. */
5532 if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size)))
5533 && TREE_COMPLEXITY (gnu_size) != 0)
5534 return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
5536 /* If we do not return inside this switch, TCODE will be set to the
5537 code to use for a Create_Node operand and LEN (set above) will be
5538 the number of recursive calls for us to make. */
5540 switch (TREE_CODE (gnu_size))
5543 if (TREE_OVERFLOW (gnu_size))
5546 /* This may have come from a conversion from some smaller type,
5547 so ensure this is in bitsizetype. */
5548 gnu_size = convert (bitsizetype, gnu_size);
5550 /* For negative values, use NEGATE_EXPR of the supplied value. */
5551 if (tree_int_cst_sgn (gnu_size) < 0)
5553 /* The rediculous code below is to handle the case of the largest
5554 negative integer. */
5555 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
5559 if (TREE_CONSTANT_OVERFLOW (negative_size))
5562 = size_binop (MINUS_EXPR, bitsize_zero_node,
5563 size_binop (PLUS_EXPR, gnu_size,
5568 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
5570 temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
5572 return annotate_value (temp);
5575 if (! host_integerp (gnu_size, 1))
5578 size = tree_low_cst (gnu_size, 1);
5580 /* This peculiar test is to make sure that the size fits in an int
5581 on machines where HOST_WIDE_INT is not "int". */
5582 if (tree_low_cst (gnu_size, 1) == size)
5583 return UI_From_Int (size);
5588 /* The only case we handle here is a simple discriminant reference. */
5589 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
5590 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
5591 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0)
5592 return Create_Node (Discrim_Val,
5593 annotate_value (DECL_DISCRIMINANT_NUMBER
5594 (TREE_OPERAND (gnu_size, 1))),
5599 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
5600 return annotate_value (TREE_OPERAND (gnu_size, 0));
5602 /* Now just list the operations we handle. */
5603 case COND_EXPR: tcode = Cond_Expr; break;
5604 case PLUS_EXPR: tcode = Plus_Expr; break;
5605 case MINUS_EXPR: tcode = Minus_Expr; break;
5606 case MULT_EXPR: tcode = Mult_Expr; break;
5607 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
5608 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
5609 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
5610 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
5611 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
5612 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
5613 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
5614 case NEGATE_EXPR: tcode = Negate_Expr; break;
5615 case MIN_EXPR: tcode = Min_Expr; break;
5616 case MAX_EXPR: tcode = Max_Expr; break;
5617 case ABS_EXPR: tcode = Abs_Expr; break;
5618 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
5619 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
5620 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
5621 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
5622 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
5623 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
5624 case LT_EXPR: tcode = Lt_Expr; break;
5625 case LE_EXPR: tcode = Le_Expr; break;
5626 case GT_EXPR: tcode = Gt_Expr; break;
5627 case GE_EXPR: tcode = Ge_Expr; break;
5628 case EQ_EXPR: tcode = Eq_Expr; break;
5629 case NE_EXPR: tcode = Ne_Expr; break;
5635 /* Now get each of the operands that's relevant for this code. If any
5636 cannot be expressed as a repinfo node, say we can't. */
5637 for (i = 0; i < 3; i++)
5640 for (i = 0; i < len; i++)
5642 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
5643 if (ops[i] == No_Uint)
5647 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
5648 TREE_COMPLEXITY (gnu_size) = ret;
5652 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
5653 GCC type, set Component_Bit_Offset and Esize to the position and size
5657 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
5661 Entity_Id gnat_field;
5663 /* We operate by first making a list of all field and their positions
5664 (we can get the sizes easily at any time) by a recursive call
5665 and then update all the sizes into the tree. */
5666 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
5667 size_zero_node, bitsize_zero_node,
5670 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
5671 gnat_field = Next_Entity (gnat_field))
5672 if ((Ekind (gnat_field) == E_Component
5673 || (Ekind (gnat_field) == E_Discriminant
5674 && ! Is_Unchecked_Union (Scope (gnat_field)))))
5676 tree parent_offset = bitsize_zero_node;
5679 = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0),
5684 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
5686 /* In this mode the tag and parent components have not been
5687 generated, so we add the appropriate offset to each
5688 component. For a component appearing in the current
5689 extension, the offset is the size of the parent. */
5690 if (Is_Derived_Type (gnat_entity)
5691 && Original_Record_Component (gnat_field) == gnat_field)
5693 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
5696 parent_offset = bitsize_int (POINTER_SIZE);
5699 Set_Component_Bit_Offset
5702 (size_binop (PLUS_EXPR,
5703 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
5704 TREE_VALUE (TREE_VALUE
5705 (TREE_VALUE (gnu_entry)))),
5708 Set_Esize (gnat_field,
5709 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
5711 else if (type_annotate_only
5712 && Is_Tagged_Type (gnat_entity)
5713 && Is_Derived_Type (gnat_entity))
5715 /* If there is no gnu_entry, this is an inherited component whose
5716 position is the same as in the parent type. */
5717 Set_Component_Bit_Offset
5719 Component_Bit_Offset (Original_Record_Component (gnat_field)));
5720 Set_Esize (gnat_field,
5721 Esize (Original_Record_Component (gnat_field)));
5726 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
5727 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
5728 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
5729 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
5730 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
5731 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
5735 compute_field_positions (tree gnu_type,
5739 unsigned int offset_align)
5742 tree gnu_result = gnu_list;
5744 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
5745 gnu_field = TREE_CHAIN (gnu_field))
5747 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
5748 DECL_FIELD_BIT_OFFSET (gnu_field));
5749 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
5750 DECL_FIELD_OFFSET (gnu_field));
5751 unsigned int our_offset_align
5752 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
5755 = tree_cons (gnu_field,
5756 tree_cons (gnu_our_offset,
5757 tree_cons (size_int (our_offset_align),
5758 gnu_our_bitpos, NULL_TREE),
5762 if (DECL_INTERNAL_P (gnu_field))
5764 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
5765 gnu_our_offset, gnu_our_bitpos,
5772 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
5773 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
5774 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
5775 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
5776 for the size of a field. COMPONENT_P is true if we are being called
5777 to process the Component_Size of GNAT_OBJECT. This is used for error
5778 message handling and to indicate to use the object size of GNU_TYPE.
5779 ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero,
5780 it means that a size of zero should be treated as an unspecified size. */
5783 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
5784 enum tree_code kind, int component_p, int zero_ok)
5786 Node_Id gnat_error_node;
5788 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
5791 /* Find the node to use for errors. */
5792 if ((Ekind (gnat_object) == E_Component
5793 || Ekind (gnat_object) == E_Discriminant)
5794 && Present (Component_Clause (gnat_object)))
5795 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
5796 else if (Present (Size_Clause (gnat_object)))
5797 gnat_error_node = Expression (Size_Clause (gnat_object));
5799 gnat_error_node = gnat_object;
5801 /* Return 0 if no size was specified, either because Esize was not Present or
5802 the specified size was zero. */
5803 if (No (uint_size) || uint_size == No_Uint)
5806 /* Get the size as a tree. Give an error if a size was specified, but cannot
5807 be represented as in sizetype. */
5808 size = UI_To_gnu (uint_size, bitsizetype);
5809 if (TREE_OVERFLOW (size))
5811 post_error_ne (component_p ? "component size of & is too large"
5812 : "size of & is too large",
5813 gnat_error_node, gnat_object);
5816 /* Ignore a negative size since that corresponds to our back-annotation.
5817 Also ignore a zero size unless a size clause exists. */
5818 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok))
5821 /* The size of objects is always a multiple of a byte. */
5822 if (kind == VAR_DECL
5823 && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size,
5824 bitsize_unit_node)))
5827 post_error_ne ("component size for& is not a multiple of Storage_Unit",
5828 gnat_error_node, gnat_object);
5830 post_error_ne ("size for& is not a multiple of Storage_Unit",
5831 gnat_error_node, gnat_object);
5835 /* If this is an integral type or a packed array type, the front-end has
5836 verified the size, so we need not do it here (which would entail
5837 checking against the bounds). However, if this is an aliased object, it
5838 may not be smaller than the type of the object. */
5839 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
5840 && ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
5843 /* If the object is a record that contains a template, add the size of
5844 the template to the specified size. */
5845 if (TREE_CODE (gnu_type) == RECORD_TYPE
5846 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
5847 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
5849 /* Modify the size of the type to be that of the maximum size if it has a
5850 discriminant or the size of a thin pointer if this is a fat pointer. */
5851 if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size))
5852 type_size = max_size (type_size, 1);
5853 else if (TYPE_FAT_POINTER_P (gnu_type))
5854 type_size = bitsize_int (POINTER_SIZE);
5856 /* If this is an access type, the minimum size is that given by the smallest
5857 integral mode that's valid for pointers. */
5858 if (TREE_CODE (gnu_type) == POINTER_TYPE)
5860 enum machine_mode p_mode;
5862 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
5863 !targetm.valid_pointer_mode (p_mode);
5864 p_mode = GET_MODE_WIDER_MODE (p_mode))
5867 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
5870 /* If the size of the object is a constant, the new size must not be
5872 if (TREE_CODE (type_size) != INTEGER_CST
5873 || TREE_OVERFLOW (type_size)
5874 || tree_int_cst_lt (size, type_size))
5878 ("component size for& too small{, minimum allowed is ^}",
5879 gnat_error_node, gnat_object, type_size);
5881 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
5882 gnat_error_node, gnat_object, type_size);
5884 if (kind == VAR_DECL && ! component_p
5885 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
5886 && ! tree_int_cst_lt (size, rm_size (gnu_type)))
5887 post_error_ne_tree_2
5888 ("\\size of ^ is not a multiple of alignment (^ bits)",
5889 gnat_error_node, gnat_object, rm_size (gnu_type),
5890 TYPE_ALIGN (gnu_type));
5892 else if (INTEGRAL_TYPE_P (gnu_type))
5893 post_error_ne ("\\size would be legal if & were not aliased!",
5894 gnat_error_node, gnat_object);
5902 /* Similarly, but both validate and process a value of RM_Size. This
5903 routine is only called for types. */
5906 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
5908 /* Only give an error if a Value_Size clause was explicitly given.
5909 Otherwise, we'd be duplicating an error on the Size clause. */
5910 Node_Id gnat_attr_node
5911 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
5912 tree old_size = rm_size (gnu_type);
5915 /* Get the size as a tree. Do nothing if none was specified, either
5916 because RM_Size was not Present or if the specified size was zero.
5917 Give an error if a size was specified, but cannot be represented as
5919 if (No (uint_size) || uint_size == No_Uint)
5922 size = UI_To_gnu (uint_size, bitsizetype);
5923 if (TREE_OVERFLOW (size))
5925 if (Present (gnat_attr_node))
5926 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
5932 /* Ignore a negative size since that corresponds to our back-annotation.
5933 Also ignore a zero size unless a size clause exists, a Value_Size
5934 clause exists, or this is an integer type, in which case the
5935 front end will have always set it. */
5936 else if (tree_int_cst_sgn (size) < 0
5937 || (integer_zerop (size) && No (gnat_attr_node)
5938 && ! Has_Size_Clause (gnat_entity)
5939 && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
5942 /* If the old size is self-referential, get the maximum size. */
5943 if (CONTAINS_PLACEHOLDER_P (old_size))
5944 old_size = max_size (old_size, 1);
5946 /* If the size of the object is a constant, the new size must not be
5947 smaller (the front end checks this for scalar types). */
5948 if (TREE_CODE (old_size) != INTEGER_CST
5949 || TREE_OVERFLOW (old_size)
5950 || (AGGREGATE_TYPE_P (gnu_type)
5951 && tree_int_cst_lt (size, old_size)))
5953 if (Present (gnat_attr_node))
5955 ("Value_Size for& too small{, minimum allowed is ^}",
5956 gnat_attr_node, gnat_entity, old_size);
5961 /* Otherwise, set the RM_Size. */
5962 if (TREE_CODE (gnu_type) == INTEGER_TYPE
5963 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
5964 TYPE_RM_SIZE_INT (gnu_type) = size;
5965 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
5966 SET_TYPE_RM_SIZE_ENUM (gnu_type, size);
5967 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
5968 || TREE_CODE (gnu_type) == UNION_TYPE
5969 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
5970 && ! TYPE_IS_FAT_POINTER_P (gnu_type))
5971 SET_TYPE_ADA_SIZE (gnu_type, size);
5974 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
5975 If TYPE is the best type, return it. Otherwise, make a new type. We
5976 only support new integral and pointer types. BIASED_P is nonzero if
5977 we are making a biased type. */
5980 make_type_from_size (tree type, tree size_tree, int biased_p)
5983 unsigned HOST_WIDE_INT size;
5985 /* If size indicates an error, just return TYPE to avoid propagating the
5986 error. Likewise if it's too large to represent. */
5987 if (size_tree == 0 || ! host_integerp (size_tree, 1))
5990 size = tree_low_cst (size_tree, 1);
5991 switch (TREE_CODE (type))
5995 /* Only do something if the type is not already the proper size and is
5996 not a packed array type. */
5997 if (TYPE_PACKED_ARRAY_TYPE_P (type)
5998 || (TYPE_PRECISION (type) == size
5999 && biased_p == (TREE_CODE (type) == INTEGER_CST
6000 && TYPE_BIASED_REPRESENTATION_P (type))))
6003 size = MIN (size, LONG_LONG_TYPE_SIZE);
6004 new_type = make_signed_type (size);
6005 TREE_TYPE (new_type)
6006 = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type;
6007 TYPE_MIN_VALUE (new_type)
6008 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
6009 TYPE_MAX_VALUE (new_type)
6010 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
6011 TYPE_BIASED_REPRESENTATION_P (new_type)
6012 = ((TREE_CODE (type) == INTEGER_TYPE
6013 && TYPE_BIASED_REPRESENTATION_P (type))
6015 TYPE_UNSIGNED (new_type)
6016 = TYPE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type);
6017 TYPE_RM_SIZE_INT (new_type) = bitsize_int (size);
6021 /* Do something if this is a fat pointer, in which case we
6022 may need to return the thin pointer. */
6023 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
6026 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
6030 /* Only do something if this is a thin pointer, in which case we
6031 may need to return the fat pointer. */
6032 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
6034 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
6045 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6046 a type or object whose present alignment is ALIGN. If this alignment is
6047 valid, return it. Otherwise, give an error and return ALIGN. */
6050 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
6052 Node_Id gnat_error_node = gnat_entity;
6053 unsigned int new_align;
6055 #ifndef MAX_OFILE_ALIGNMENT
6056 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
6059 if (Present (Alignment_Clause (gnat_entity)))
6060 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
6062 /* Don't worry about checking alignment if alignment was not specified
6063 by the source program and we already posted an error for this entity. */
6065 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
6068 /* Within GCC, an alignment is an integer, so we must make sure a
6069 value is specified that fits in that range. Also, alignments of
6070 more than MAX_OFILE_ALIGNMENT can't be supported. */
6072 if (! UI_Is_In_Int_Range (alignment)
6073 || ((new_align = UI_To_Int (alignment))
6074 > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT))
6075 post_error_ne_num ("largest supported alignment for& is ^",
6076 gnat_error_node, gnat_entity,
6077 MAX_OFILE_ALIGNMENT / BITS_PER_UNIT);
6078 else if (! (Present (Alignment_Clause (gnat_entity))
6079 && From_At_Mod (Alignment_Clause (gnat_entity)))
6080 && new_align * BITS_PER_UNIT < align)
6081 post_error_ne_num ("alignment for& must be at least ^",
6082 gnat_error_node, gnat_entity,
6083 align / BITS_PER_UNIT);
6085 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
6090 /* Verify that OBJECT, a type or decl, is something we can implement
6091 atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero
6092 if we require atomic components. */
6095 check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p)
6097 Node_Id gnat_error_point = gnat_entity;
6099 enum machine_mode mode;
6103 /* There are three case of what OBJECT can be. It can be a type, in which
6104 case we take the size, alignment and mode from the type. It can be a
6105 declaration that was indirect, in which case the relevant values are
6106 that of the type being pointed to, or it can be a normal declaration,
6107 in which case the values are of the decl. The code below assumes that
6108 OBJECT is either a type or a decl. */
6109 if (TYPE_P (object))
6111 mode = TYPE_MODE (object);
6112 align = TYPE_ALIGN (object);
6113 size = TYPE_SIZE (object);
6115 else if (DECL_BY_REF_P (object))
6117 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
6118 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
6119 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
6123 mode = DECL_MODE (object);
6124 align = DECL_ALIGN (object);
6125 size = DECL_SIZE (object);
6128 /* Consider all floating-point types atomic and any types that that are
6129 represented by integers no wider than a machine word. */
6130 if (GET_MODE_CLASS (mode) == MODE_FLOAT
6131 || ((GET_MODE_CLASS (mode) == MODE_INT
6132 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
6133 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
6136 /* For the moment, also allow anything that has an alignment equal
6137 to its size and which is smaller than a word. */
6138 if (size != 0 && TREE_CODE (size) == INTEGER_CST
6139 && compare_tree_int (size, align) == 0
6140 && align <= BITS_PER_WORD)
6143 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
6144 gnat_node = Next_Rep_Item (gnat_node))
6146 if (! comp_p && Nkind (gnat_node) == N_Pragma
6147 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
6148 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6149 else if (comp_p && Nkind (gnat_node) == N_Pragma
6150 && (Get_Pragma_Id (Chars (gnat_node))
6151 == Pragma_Atomic_Components))
6152 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6156 post_error_ne ("atomic access to component of & cannot be guaranteed",
6157 gnat_error_point, gnat_entity);
6159 post_error_ne ("atomic access to & cannot be guaranteed",
6160 gnat_error_point, gnat_entity);
6163 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type
6164 with all size expressions that contain F updated by replacing F with R.
6165 This is identical to GCC's substitute_in_type except that it knows about
6166 TYPE_INDEX_TYPE. If F is NULL_TREE, always make a new RECORD_TYPE, even if
6167 nothing has changed. */
6170 gnat_substitute_in_type (tree t, tree f, tree r)
6175 switch (TREE_CODE (t))
6181 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6182 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6184 tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6185 tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6187 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6190 new = build_range_type (TREE_TYPE (t), low, high);
6191 if (TYPE_INDEX_TYPE (t))
6193 (new, gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
6200 if ((TYPE_MIN_VALUE (t) != 0
6201 && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)))
6202 || (TYPE_MAX_VALUE (t) != 0
6203 && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))))
6205 tree low = 0, high = 0;
6207 if (TYPE_MIN_VALUE (t))
6208 low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6209 if (TYPE_MAX_VALUE (t))
6210 high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6212 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6216 TYPE_MIN_VALUE (t) = low;
6217 TYPE_MAX_VALUE (t) = high;
6222 tem = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6223 if (tem == TREE_TYPE (t))
6226 return build_complex_type (tem);
6234 /* Don't know how to do these yet. */
6239 tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6240 tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r);
6242 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
6245 new = build_array_type (component, domain);
6246 TYPE_SIZE (new) = 0;
6247 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
6248 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
6250 TYPE_ALIGN (new) = TYPE_ALIGN (t);
6256 case QUAL_UNION_TYPE:
6260 = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t)));
6261 int field_has_rep = 0;
6262 tree last_field = 0;
6264 tree new = copy_type (t);
6266 /* Start out with no fields, make new fields, and chain them
6267 in. If we haven't actually changed the type of any field,
6268 discard everything we've done and return the old type. */
6270 TYPE_FIELDS (new) = 0;
6271 TYPE_SIZE (new) = 0;
6273 for (field = TYPE_FIELDS (t); field;
6274 field = TREE_CHAIN (field))
6276 tree new_field = copy_node (field);
6278 TREE_TYPE (new_field)
6279 = gnat_substitute_in_type (TREE_TYPE (new_field), f, r);
6281 if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field))
6283 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
6286 /* If this is an internal field and the type of this field is
6287 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
6288 the type just has one element, treat that as the field.
6289 But don't do this if we are processing a QUAL_UNION_TYPE. */
6290 if (TREE_CODE (t) != QUAL_UNION_TYPE
6291 && DECL_INTERNAL_P (new_field)
6292 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
6293 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
6295 if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0)
6298 if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0)
6301 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
6303 /* Make sure omitting the union doesn't change
6305 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
6306 new_field = next_new_field;
6310 DECL_CONTEXT (new_field) = new;
6311 SET_DECL_ORIGINAL_FIELD (new_field,
6312 (DECL_ORIGINAL_FIELD (field) != 0
6313 ? DECL_ORIGINAL_FIELD (field) : field));
6315 /* If the size of the old field was set at a constant,
6316 propagate the size in case the type's size was variable.
6317 (This occurs in the case of a variant or discriminated
6318 record with a default size used as a field of another
6320 DECL_SIZE (new_field)
6321 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
6322 ? DECL_SIZE (field) : 0;
6323 DECL_SIZE_UNIT (new_field)
6324 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
6325 ? DECL_SIZE_UNIT (field) : 0;
6327 if (TREE_CODE (t) == QUAL_UNION_TYPE)
6329 tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r);
6331 if (new_q != DECL_QUALIFIER (new_field))
6334 /* Do the substitution inside the qualifier and if we find
6335 that this field will not be present, omit it. */
6336 DECL_QUALIFIER (new_field) = new_q;
6338 if (integer_zerop (DECL_QUALIFIER (new_field)))
6342 if (last_field == 0)
6343 TYPE_FIELDS (new) = new_field;
6345 TREE_CHAIN (last_field) = new_field;
6347 last_field = new_field;
6349 /* If this is a qualified type and this field will always be
6350 present, we are done. */
6351 if (TREE_CODE (t) == QUAL_UNION_TYPE
6352 && integer_onep (DECL_QUALIFIER (new_field)))
6356 /* If this used to be a qualified union type, but we now know what
6357 field will be present, make this a normal union. */
6358 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
6359 && (TYPE_FIELDS (new) == 0
6360 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
6361 TREE_SET_CODE (new, UNION_TYPE);
6362 else if (! changed_field)
6370 /* If the size was originally a constant use it. */
6371 if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
6372 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
6374 TYPE_SIZE (new) = TYPE_SIZE (t);
6375 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
6376 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
6387 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
6388 needed to represent the object. */
6391 rm_size (tree gnu_type)
6393 /* For integer types, this is the precision. For record types, we store
6394 the size explicitly. For other types, this is just the size. */
6396 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0)
6397 return TYPE_RM_SIZE (gnu_type);
6398 else if (TREE_CODE (gnu_type) == RECORD_TYPE
6399 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6400 /* Return the rm_size of the actual data plus the size of the template. */
6402 size_binop (PLUS_EXPR,
6403 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
6404 DECL_SIZE (TYPE_FIELDS (gnu_type)));
6405 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6406 || TREE_CODE (gnu_type) == UNION_TYPE
6407 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6408 && ! TYPE_IS_FAT_POINTER_P (gnu_type)
6409 && TYPE_ADA_SIZE (gnu_type) != 0)
6410 return TYPE_ADA_SIZE (gnu_type);
6412 return TYPE_SIZE (gnu_type);
6415 /* Return an identifier representing the external name to be used for
6416 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
6417 and the specified suffix. */
6420 create_concat_name (Entity_Id gnat_entity, const char *suffix)
6422 const char *str = (suffix == 0 ? "" : suffix);
6423 String_Template temp = {1, strlen (str)};
6424 Fat_Pointer fp = {str, &temp};
6426 Get_External_Name_With_Suffix (gnat_entity, fp);
6429 /* A variable using the Stdcall convention (meaning we are running
6430 on a Windows box) live in a DLL. Here we adjust its name to use
6431 the jump-table, the _imp__NAME contains the address for the NAME
6435 Entity_Kind kind = Ekind (gnat_entity);
6436 const char *prefix = "_imp__";
6437 int plen = strlen (prefix);
6439 if ((kind == E_Variable || kind == E_Constant)
6440 && Convention (gnat_entity) == Convention_Stdcall)
6443 for (k = 0; k <= Name_Len; k++)
6444 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
6445 strncpy (Name_Buffer, prefix, plen);
6450 return get_identifier (Name_Buffer);
6453 /* Return the name to be used for GNAT_ENTITY. If a type, create a
6454 fully-qualified name, possibly with type information encoding.
6455 Otherwise, return the name. */
6458 get_entity_name (Entity_Id gnat_entity)
6460 Get_Encoded_Name (gnat_entity);
6461 return get_identifier (Name_Buffer);
6464 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
6465 string, return a new IDENTIFIER_NODE that is the concatenation of
6466 the name in GNU_ID and SUFFIX. */
6469 concat_id_with_name (tree gnu_id, const char *suffix)
6471 int len = IDENTIFIER_LENGTH (gnu_id);
6473 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
6474 IDENTIFIER_LENGTH (gnu_id));
6475 strncpy (Name_Buffer + len, "___", 3);
6477 strcpy (Name_Buffer + len, suffix);
6478 return get_identifier (Name_Buffer);
6481 #include "gt-ada-decl.h"