* doc/extend.texi: Document optional priority argument to
[official-gcc.git] / gcc / ada / decl.c
blob6b14064641591f7ed022d3389373c49a03838248
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2007, Free Software Foundation, Inc. *
10 * *
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, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
21 * *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 * *
25 ****************************************************************************/
27 #include "config.h"
28 #include "system.h"
29 #include "coretypes.h"
30 #include "tm.h"
31 #include "tree.h"
32 #include "flags.h"
33 #include "toplev.h"
34 #include "convert.h"
35 #include "ggc.h"
36 #include "obstack.h"
37 #include "target.h"
38 #include "expr.h"
40 #include "ada.h"
41 #include "types.h"
42 #include "atree.h"
43 #include "elists.h"
44 #include "namet.h"
45 #include "nlists.h"
46 #include "repinfo.h"
47 #include "snames.h"
48 #include "stringt.h"
49 #include "uintp.h"
50 #include "fe.h"
51 #include "sinfo.h"
52 #include "einfo.h"
53 #include "hashtab.h"
54 #include "ada-tree.h"
55 #include "gigi.h"
57 /* Convention_Stdcall should be processed in a specific way on Windows targets
58 only. The macro below is a helper to avoid having to check for a Windows
59 specific attribute throughout this unit. */
61 #if TARGET_DLLIMPORT_DECL_ATTRIBUTES
62 #define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
63 #else
64 #define Has_Stdcall_Convention(E) (0)
65 #endif
67 /* These two variables are used to defer recursively expanding incomplete
68 types while we are processing a record or subprogram type. */
70 static int defer_incomplete_level = 0;
71 static struct incomplete
73 struct incomplete *next;
74 tree old_type;
75 Entity_Id full_type;
76 } *defer_incomplete_list = 0;
78 /* These two variables are used to defer emission of debug information for
79 nested incomplete record types */
81 static int defer_debug_level = 0;
82 static tree defer_debug_incomplete_list;
84 /* A hash table used as to cache the result of annotate_value. */
85 static GTY ((if_marked ("tree_int_map_marked_p"), param_is (struct tree_int_map)))
86 htab_t annotate_value_cache;
88 static void copy_alias_set (tree, tree);
89 static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
90 static bool allocatable_size_p (tree, bool);
91 static void prepend_attributes (Entity_Id, struct attrib **);
92 static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
93 static bool is_variable_size (tree);
94 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
95 bool, bool);
96 static tree make_packable_type (tree);
97 static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
98 static bool same_discriminant_p (Entity_Id, Entity_Id);
99 static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
100 bool, bool, bool, bool);
101 static int compare_field_bitpos (const PTR, const PTR);
102 static Uint annotate_value (tree);
103 static void annotate_rep (Entity_Id, tree);
104 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
105 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
106 static void set_rm_size (Uint, tree, Entity_Id);
107 static tree make_type_from_size (tree, tree, bool);
108 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
109 static void check_ok_for_atomic (tree, Entity_Id, bool);
110 static int compatible_signatures_p (tree ftype1, tree ftype2);
112 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
113 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
114 refer to an Ada type. */
116 tree
117 gnat_to_gnu_type (Entity_Id gnat_entity)
119 tree gnu_decl;
121 /* The back end never attempts to annotate generic types */
122 if (Is_Generic_Type (gnat_entity) && type_annotate_only)
123 return void_type_node;
125 /* Convert the ada entity type into a GCC TYPE_DECL node. */
126 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
127 gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
128 return TREE_TYPE (gnu_decl);
131 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
132 entity, this routine returns the equivalent GCC tree for that entity
133 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
134 defining identifier.
136 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
137 initial value (in GCC tree form). This is optional for variables.
138 For renamed entities, GNU_EXPR gives the object being renamed.
140 DEFINITION is nonzero if this call is intended for a definition. This is
141 used for separate compilation where it necessary to know whether an
142 external declaration or a definition should be created if the GCC equivalent
143 was not created previously. The value of 1 is normally used for a nonzero
144 DEFINITION, but a value of 2 is used in special circumstances, defined in
145 the code. */
147 tree
148 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
150 tree gnu_entity_id;
151 tree gnu_type = NULL_TREE;
152 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
153 GNAT tree. This node will be associated with the GNAT node by calling
154 the save_gnu_tree routine at the end of the `switch' statement. */
155 tree gnu_decl = NULL_TREE;
156 /* true if we have already saved gnu_decl as a gnat association. */
157 bool saved = false;
158 /* Nonzero if we incremented defer_incomplete_level. */
159 bool this_deferred = false;
160 /* Nonzero if we incremented defer_debug_level. */
161 bool debug_deferred = false;
162 /* Nonzero if we incremented force_global. */
163 bool this_global = false;
164 /* Nonzero if we should check to see if elaborated during processing. */
165 bool maybe_present = false;
166 /* Nonzero if we made GNU_DECL and its type here. */
167 bool this_made_decl = false;
168 struct attrib *attr_list = NULL;
169 bool debug_info_p = (Needs_Debug_Info (gnat_entity)
170 || debug_info_level == DINFO_LEVEL_VERBOSE);
171 Entity_Kind kind = Ekind (gnat_entity);
172 Entity_Id gnat_temp;
173 unsigned int esize
174 = ((Known_Esize (gnat_entity)
175 && UI_Is_In_Int_Range (Esize (gnat_entity)))
176 ? MIN (UI_To_Int (Esize (gnat_entity)),
177 IN (kind, Float_Kind)
178 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
179 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
180 : LONG_LONG_TYPE_SIZE)
181 : LONG_LONG_TYPE_SIZE);
182 tree gnu_size = 0;
183 bool imported_p
184 = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
185 unsigned int align = 0;
187 /* Since a use of an Itype is a definition, process it as such if it
188 is not in a with'ed unit. */
190 if (!definition && Is_Itype (gnat_entity)
191 && !present_gnu_tree (gnat_entity)
192 && In_Extended_Main_Code_Unit (gnat_entity))
194 /* Ensure that we are in a subprogram mentioned in the Scope
195 chain of this entity, our current scope is global,
196 or that we encountered a task or entry (where we can't currently
197 accurately check scoping). */
198 if (!current_function_decl
199 || DECL_ELABORATION_PROC_P (current_function_decl))
201 process_type (gnat_entity);
202 return get_gnu_tree (gnat_entity);
205 for (gnat_temp = Scope (gnat_entity);
206 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
208 if (Is_Type (gnat_temp))
209 gnat_temp = Underlying_Type (gnat_temp);
211 if (Ekind (gnat_temp) == E_Subprogram_Body)
212 gnat_temp
213 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
215 if (IN (Ekind (gnat_temp), Subprogram_Kind)
216 && Present (Protected_Body_Subprogram (gnat_temp)))
217 gnat_temp = Protected_Body_Subprogram (gnat_temp);
219 if (Ekind (gnat_temp) == E_Entry
220 || Ekind (gnat_temp) == E_Entry_Family
221 || Ekind (gnat_temp) == E_Task_Type
222 || (IN (Ekind (gnat_temp), Subprogram_Kind)
223 && present_gnu_tree (gnat_temp)
224 && (current_function_decl
225 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
227 process_type (gnat_entity);
228 return get_gnu_tree (gnat_entity);
232 /* This abort means the entity "gnat_entity" has an incorrect scope,
233 i.e. that its scope does not correspond to the subprogram in which
234 it is declared */
235 gcc_unreachable ();
238 /* If this is entity 0, something went badly wrong. */
239 gcc_assert (Present (gnat_entity));
241 /* If we've already processed this entity, return what we got last time.
242 If we are defining the node, we should not have already processed it.
243 In that case, we will abort below when we try to save a new GCC tree for
244 this object. We also need to handle the case of getting a dummy type
245 when a Full_View exists. */
247 if (present_gnu_tree (gnat_entity)
248 && (! definition
249 || (Is_Type (gnat_entity) && imported_p)))
251 gnu_decl = get_gnu_tree (gnat_entity);
253 if (TREE_CODE (gnu_decl) == TYPE_DECL
254 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
255 && IN (kind, Incomplete_Or_Private_Kind)
256 && Present (Full_View (gnat_entity)))
258 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
259 NULL_TREE, 0);
261 save_gnu_tree (gnat_entity, NULL_TREE, false);
262 save_gnu_tree (gnat_entity, gnu_decl, false);
265 return gnu_decl;
268 /* If this is a numeric or enumeral type, or an access type, a nonzero
269 Esize must be specified unless it was specified by the programmer. */
270 gcc_assert (!Unknown_Esize (gnat_entity)
271 || Has_Size_Clause (gnat_entity)
272 || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
273 && (!IN (kind, Access_Kind)
274 || kind == E_Access_Protected_Subprogram_Type
275 || kind == E_Access_Subtype)));
277 /* Likewise, RM_Size must be specified for all discrete and fixed-point
278 types. */
279 gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
280 || !Unknown_RM_Size (gnat_entity));
282 /* Get the name of the entity and set up the line number and filename of
283 the original definition for use in any decl we make. */
284 gnu_entity_id = get_entity_name (gnat_entity);
285 Sloc_to_locus (Sloc (gnat_entity), &input_location);
287 /* If we get here, it means we have not yet done anything with this
288 entity. If we are not defining it here, it must be external,
289 otherwise we should have defined it already. */
290 gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
291 || kind == E_Discriminant || kind == E_Component
292 || kind == E_Label
293 || (kind == E_Constant && Present (Full_View (gnat_entity)))
294 || IN (kind, Type_Kind));
296 /* For cases when we are not defining (i.e., we are referencing from
297 another compilation unit) Public entities, show we are at global level
298 for the purpose of computing scopes. Don't do this for components or
299 discriminants since the relevant test is whether or not the record is
300 being defined. But do this for Imported functions or procedures in
301 all cases. */
302 if ((!definition && Is_Public (gnat_entity)
303 && !Is_Statically_Allocated (gnat_entity)
304 && kind != E_Discriminant && kind != E_Component)
305 || (Is_Imported (gnat_entity)
306 && (kind == E_Function || kind == E_Procedure)))
307 force_global++, this_global = true;
309 /* Handle any attributes directly attached to the entity. */
310 if (Has_Gigi_Rep_Item (gnat_entity))
311 prepend_attributes (gnat_entity, &attr_list);
313 /* Machine_Attributes on types are expected to be propagated to subtypes.
314 The corresponding Gigi_Rep_Items are only attached to the first subtype
315 though, so we handle the propagation here. */
316 if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
317 && !Is_First_Subtype (gnat_entity)
318 && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
319 prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
321 switch (kind)
323 case E_Constant:
324 /* If this is a use of a deferred constant, get its full
325 declaration. */
326 if (!definition && Present (Full_View (gnat_entity)))
328 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
329 gnu_expr, definition);
330 saved = true;
331 break;
334 /* If we have an external constant that we are not defining,
335 get the expression that is was defined to represent. We
336 may throw that expression away later if it is not a
337 constant.
338 Do not retrieve the expression if it is an aggregate, because
339 in complex instantiation contexts it may not be expanded */
341 if (!definition
342 && Present (Expression (Declaration_Node (gnat_entity)))
343 && !No_Initialization (Declaration_Node (gnat_entity))
344 && (Nkind (Expression (Declaration_Node (gnat_entity)))
345 != N_Aggregate))
346 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
348 /* Ignore deferred constant definitions; they are processed fully in the
349 front-end. For deferred constant references, get the full
350 definition. On the other hand, constants that are renamings are
351 handled like variable renamings. If No_Initialization is set, this is
352 not a deferred constant but a constant whose value is built
353 manually. */
355 if (definition && !gnu_expr
356 && !No_Initialization (Declaration_Node (gnat_entity))
357 && No (Renamed_Object (gnat_entity)))
359 gnu_decl = error_mark_node;
360 saved = true;
361 break;
363 else if (!definition && IN (kind, Incomplete_Or_Private_Kind)
364 && Present (Full_View (gnat_entity)))
366 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
367 NULL_TREE, 0);
368 saved = true;
369 break;
372 goto object;
374 case E_Exception:
375 /* We used to special case VMS exceptions here to directly map them to
376 their associated condition code. Since this code had to be masked
377 dynamically to strip off the severity bits, this caused trouble in
378 the GCC/ZCX case because the "type" pointers we store in the tables
379 have to be static. We now don't special case here anymore, and let
380 the regular processing take place, which leaves us with a regular
381 exception data object for VMS exceptions too. The condition code
382 mapping is taken care of by the front end and the bitmasking by the
383 runtime library. */
384 goto object;
386 case E_Discriminant:
387 case E_Component:
389 /* The GNAT record where the component was defined. */
390 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
392 /* If the variable is an inherited record component (in the case of
393 extended record types), just return the inherited entity, which
394 must be a FIELD_DECL. Likewise for discriminants.
395 For discriminants of untagged records which have explicit
396 stored discriminants, return the entity for the corresponding
397 stored discriminant. Also use Original_Record_Component
398 if the record has a private extension. */
400 if (Present (Original_Record_Component (gnat_entity))
401 && Original_Record_Component (gnat_entity) != gnat_entity)
403 gnu_decl
404 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
405 gnu_expr, definition);
406 saved = true;
407 break;
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
415 branch). */
417 else if (Present (Corresponding_Discriminant (gnat_entity))
418 && Is_Tagged_Type (gnat_record))
420 /* A tagged record has no explicit stored discriminants. */
422 gcc_assert (First_Discriminant (gnat_record)
423 == First_Stored_Discriminant (gnat_record));
424 gnu_decl
425 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
426 gnu_expr, definition);
427 saved = true;
428 break;
431 else if (Present (CR_Discriminant (gnat_entity))
432 && type_annotate_only)
434 gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
435 gnu_expr, definition);
436 saved = 1;
437 break;
440 /* If the enclosing record has explicit stored discriminants,
441 then it is an untagged record. If the Corresponding_Discriminant
442 is not empty then this must be a renamed discriminant and its
443 Original_Record_Component must point to the corresponding explicit
444 stored discriminant (i.e., we should have taken the first
445 branch). */
447 else if (Present (Corresponding_Discriminant (gnat_entity))
448 && (First_Discriminant (gnat_record)
449 != First_Stored_Discriminant (gnat_record)))
450 gcc_unreachable ();
452 /* Otherwise, if we are not defining this and we have no GCC type
453 for the containing record, make one for it. Then we should
454 have made our own equivalent. */
455 else if (!definition && !present_gnu_tree (gnat_record))
457 /* ??? If this is in a record whose scope is a protected
458 type and we have an Original_Record_Component, use it.
459 This is a workaround for major problems in protected type
460 handling. */
462 Entity_Id Scop = Scope (Scope (gnat_entity));
463 if ((Is_Protected_Type (Scop)
464 || (Is_Private_Type (Scop)
465 && Present (Full_View (Scop))
466 && Is_Protected_Type (Full_View (Scop))))
467 && Present (Original_Record_Component (gnat_entity)))
469 gnu_decl
470 = gnat_to_gnu_entity (Original_Record_Component
471 (gnat_entity),
472 gnu_expr, definition);
473 saved = true;
474 break;
477 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
478 gnu_decl = get_gnu_tree (gnat_entity);
479 saved = true;
480 break;
483 else
484 /* Here we have no GCC type and this is a reference rather than a
485 definition. This should never happen. Most likely the cause is a
486 reference before declaration in the gnat tree for gnat_entity. */
487 gcc_unreachable ();
490 case E_Loop_Parameter:
491 case E_Out_Parameter:
492 case E_Variable:
494 /* Simple variables, loop variables, OUT parameters, and exceptions. */
495 object:
497 bool used_by_ref = false;
498 bool const_flag
499 = ((kind == E_Constant || kind == E_Variable)
500 && !Is_Statically_Allocated (gnat_entity)
501 && Is_True_Constant (gnat_entity)
502 && (((Nkind (Declaration_Node (gnat_entity))
503 == N_Object_Declaration)
504 && Present (Expression (Declaration_Node (gnat_entity))))
505 || Present (Renamed_Object (gnat_entity))));
506 bool inner_const_flag = const_flag;
507 bool static_p = Is_Statically_Allocated (gnat_entity);
508 bool mutable_p = false;
509 tree gnu_ext_name = NULL_TREE;
510 tree renamed_obj = NULL_TREE;
512 if (Present (Renamed_Object (gnat_entity)) && !definition)
514 if (kind == E_Exception)
515 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
516 NULL_TREE, 0);
517 else
518 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
521 /* Get the type after elaborating the renamed object. */
522 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
524 /* If this is a loop variable, its type should be the base type.
525 This is because the code for processing a loop determines whether
526 a normal loop end test can be done by comparing the bounds of the
527 loop against those of the base type, which is presumed to be the
528 size used for computation. But this is not correct when the size
529 of the subtype is smaller than the type. */
530 if (kind == E_Loop_Parameter)
531 gnu_type = get_base_type (gnu_type);
533 /* Reject non-renamed objects whose types are unconstrained arrays or
534 any object whose type is a dummy type or VOID_TYPE. */
536 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
537 && No (Renamed_Object (gnat_entity)))
538 || TYPE_IS_DUMMY_P (gnu_type)
539 || TREE_CODE (gnu_type) == VOID_TYPE)
541 gcc_assert (type_annotate_only);
542 if (this_global)
543 force_global--;
544 return error_mark_node;
547 /* If an alignment is specified, use it if valid. Note that
548 exceptions are objects but don't have alignments. We must do this
549 before we validate the size, since the alignment can affect the
550 size. */
551 if (kind != E_Exception && Known_Alignment (gnat_entity))
553 gcc_assert (Present (Alignment (gnat_entity)));
554 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
555 TYPE_ALIGN (gnu_type));
556 gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align,
557 gnat_entity, "PAD", 0, definition, 1);
560 /* If we are defining the object, see if it has a Size value and
561 validate it if so. If we are not defining the object and a Size
562 clause applies, simply retrieve the value. We don't want to ignore
563 the clause and it is expected to have been validated already. Then
564 get the new type, if any. */
565 if (definition)
566 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
567 gnat_entity, VAR_DECL, false,
568 Has_Size_Clause (gnat_entity));
569 else if (Has_Size_Clause (gnat_entity))
570 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
572 if (gnu_size)
574 gnu_type
575 = make_type_from_size (gnu_type, gnu_size,
576 Has_Biased_Representation (gnat_entity));
578 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
579 gnu_size = NULL_TREE;
582 /* If this object has self-referential size, it must be a record with
583 a default value. We are supposed to allocate an object of the
584 maximum size in this case unless it is a constant with an
585 initializing expression, in which case we can get the size from
586 that. Note that the resulting size may still be a variable, so
587 this may end up with an indirect allocation. */
589 if (No (Renamed_Object (gnat_entity))
590 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
592 if (gnu_expr && kind == E_Constant)
593 gnu_size
594 = SUBSTITUTE_PLACEHOLDER_IN_EXPR
595 (TYPE_SIZE (TREE_TYPE (gnu_expr)), gnu_expr);
597 /* We may have no GNU_EXPR because No_Initialization is
598 set even though there's an Expression. */
599 else if (kind == E_Constant
600 && (Nkind (Declaration_Node (gnat_entity))
601 == N_Object_Declaration)
602 && Present (Expression (Declaration_Node (gnat_entity))))
603 gnu_size
604 = TYPE_SIZE (gnat_to_gnu_type
605 (Etype
606 (Expression (Declaration_Node (gnat_entity)))));
607 else
609 gnu_size = max_size (TYPE_SIZE (gnu_type), true);
610 mutable_p = true;
614 /* If the size is zero bytes, make it one byte since some linkers have
615 trouble with zero-sized objects. If the object will have a
616 template, that will make it nonzero so don't bother. Also avoid
617 doing that for an object renaming or an object with an address
618 clause, as we would lose useful information on the view size
619 (e.g. for null array slices) and we are not allocating the object
620 here anyway. */
621 if (((gnu_size && integer_zerop (gnu_size))
622 || (TYPE_SIZE (gnu_type) && integer_zerop (TYPE_SIZE (gnu_type))))
623 && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
624 || !Is_Array_Type (Etype (gnat_entity)))
625 && !Present (Renamed_Object (gnat_entity))
626 && !Present (Address_Clause (gnat_entity)))
627 gnu_size = bitsize_unit_node;
629 /* If this is an atomic object with no specified size and alignment,
630 but where the size of the type is a constant, set the alignment to
631 the lowest power of two greater than the size, or to the
632 biggest meaningful alignment, whichever is smaller. */
634 if (Is_Atomic (gnat_entity) && !gnu_size && align == 0
635 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
637 if (!host_integerp (TYPE_SIZE (gnu_type), 1)
638 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
639 BIGGEST_ALIGNMENT))
640 align = BIGGEST_ALIGNMENT;
641 else
642 align = ((unsigned int) 1
643 << (floor_log2 (tree_low_cst
644 (TYPE_SIZE (gnu_type), 1) - 1)
645 + 1));
648 /* If the object is set to have atomic components, find the component
649 type and validate it.
651 ??? Note that we ignore Has_Volatile_Components on objects; it's
652 not at all clear what to do in that case. */
654 if (Has_Atomic_Components (gnat_entity))
656 tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
657 ? TREE_TYPE (gnu_type) : gnu_type);
659 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
660 && TYPE_MULTI_ARRAY_P (gnu_inner))
661 gnu_inner = TREE_TYPE (gnu_inner);
663 check_ok_for_atomic (gnu_inner, gnat_entity, true);
666 /* Now check if the type of the object allows atomic access. Note
667 that we must test the type, even if this object has size and
668 alignment to allow such access, because we will be going
669 inside the padded record to assign to the object. We could fix
670 this by always copying via an intermediate value, but it's not
671 clear it's worth the effort. */
672 if (Is_Atomic (gnat_entity))
673 check_ok_for_atomic (gnu_type, gnat_entity, false);
675 /* If this is an aliased object with an unconstrained nominal subtype,
676 make a type that includes the template. */
677 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
678 && Is_Array_Type (Etype (gnat_entity))
679 && !type_annotate_only)
681 tree gnu_fat
682 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
684 gnu_type
685 = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
686 concat_id_with_name (gnu_entity_id,
687 "UNC"));
690 #ifdef MINIMUM_ATOMIC_ALIGNMENT
691 /* If the size is a constant and no alignment is specified, force
692 the alignment to be the minimum valid atomic alignment. The
693 restriction on constant size avoids problems with variable-size
694 temporaries; if the size is variable, there's no issue with
695 atomic access. Also don't do this for a constant, since it isn't
696 necessary and can interfere with constant replacement. Finally,
697 do not do it for Out parameters since that creates an
698 size inconsistency with In parameters. */
699 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
700 && !FLOAT_TYPE_P (gnu_type)
701 && !const_flag && No (Renamed_Object (gnat_entity))
702 && !imported_p && No (Address_Clause (gnat_entity))
703 && kind != E_Out_Parameter
704 && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
705 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
706 align = MINIMUM_ATOMIC_ALIGNMENT;
707 #endif
709 /* Make a new type with the desired size and alignment, if needed. */
710 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
711 "PAD", false, definition, true);
713 /* Make a volatile version of this object's type if we are to
714 make the object volatile. Note that 13.3(19) says that we
715 should treat other types of objects as volatile as well. */
716 if ((Treat_As_Volatile (gnat_entity)
717 || Is_Exported (gnat_entity)
718 || Is_Imported (gnat_entity)
719 || Present (Address_Clause (gnat_entity)))
720 && !TYPE_VOLATILE (gnu_type))
721 gnu_type = build_qualified_type (gnu_type,
722 (TYPE_QUALS (gnu_type)
723 | TYPE_QUAL_VOLATILE));
725 /* Convert the expression to the type of the object except in the
726 case where the object's type is unconstrained or the object's type
727 is a padded record whose field is of self-referential size. In
728 the former case, converting will generate unnecessary evaluations
729 of the CONSTRUCTOR to compute the size and in the latter case, we
730 want to only copy the actual data. */
731 if (gnu_expr
732 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
733 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
734 && !(TREE_CODE (gnu_type) == RECORD_TYPE
735 && TYPE_IS_PADDING_P (gnu_type)
736 && (CONTAINS_PLACEHOLDER_P
737 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
738 gnu_expr = convert (gnu_type, gnu_expr);
740 /* See if this is a renaming, and handle appropriately depending on
741 what is renamed and in which context. There are three major
742 cases:
744 1/ This is a constant renaming and we can just make an object
745 with what is renamed as its initial value,
747 2/ We can reuse a stabilized version of what is renamed in place
748 of the renaming,
750 3/ If neither 1 or 2 applies, we make the renaming entity a constant
751 pointer to what is being renamed. */
753 if (Present (Renamed_Object (gnat_entity)))
755 /* If the renamed object had padding, strip off the reference
756 to the inner object and reset our type. */
757 if (TREE_CODE (gnu_expr) == COMPONENT_REF
758 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
759 == RECORD_TYPE)
760 && (TYPE_IS_PADDING_P
761 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
763 gnu_expr = TREE_OPERAND (gnu_expr, 0);
764 gnu_type = TREE_TYPE (gnu_expr);
767 /* Case 1: If this is a constant renaming, treat it as a normal
768 object whose initial value is what is being renamed. We cannot
769 do this if the type is unconstrained or class-wide. */
770 if (const_flag
771 && !TREE_SIDE_EFFECTS (gnu_expr)
772 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
773 && TYPE_MODE (gnu_type) != BLKmode
774 && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
775 && !Is_Array_Type (Etype (gnat_entity)))
778 /* Otherwise, see if we can proceed with a stabilized version of
779 the renamed entity or if we need to make a pointer. */
780 else
782 bool stabilized = false;
783 tree maybe_stable_expr = NULL_TREE;
785 /* Case 2: If the renaming entity need not be materialized and
786 the renamed expression is something we can stabilize, use
787 that for the renaming. At the global level, we can only do
788 this if we know no SAVE_EXPRs need be made, because the
789 expression we return might be used in arbitrary conditional
790 branches so we must force the SAVE_EXPRs evaluation
791 immediately and this requires a function context. */
792 if (!Materialize_Entity (gnat_entity)
793 && (!global_bindings_p ()
794 || (staticp (gnu_expr)
795 && !TREE_SIDE_EFFECTS (gnu_expr))))
797 maybe_stable_expr
798 = maybe_stabilize_reference (gnu_expr, true, false,
799 &stabilized);
801 if (stabilized)
803 gnu_decl = maybe_stable_expr;
804 save_gnu_tree (gnat_entity, gnu_decl, true);
805 saved = true;
806 break;
809 /* The stabilization failed. Keep maybe_stable_expr
810 untouched here to let the pointer case below know
811 about that failure. */
814 /* Case 3: Make this into a constant pointer to the object we
815 are to rename and attach the object to the pointer if it is
816 an lvalue that can be stabilized.
818 From the proper scope, attached objects will be referenced
819 directly instead of indirectly via the pointer to avoid
820 subtle aliasing problems with non addressable entities.
821 They have to be stable because we must not evaluate the
822 variables in the expression every time the renaming is used.
823 They also have to be lvalues because the context in which
824 they are reused sometimes requires so. We call pointers
825 with an attached object "renaming" pointers.
827 In the rare cases where we cannot stabilize the renamed
828 object, we just make a "bare" pointer, and the renamed
829 entity is always accessed indirectly through it. */
831 inner_const_flag = TREE_READONLY (gnu_expr);
832 const_flag = true;
833 gnu_type = build_reference_type (gnu_type);
835 /* If a previous attempt at unrestricted stabilization
836 failed, there is no point trying again and we can reuse
837 the result without attaching it to the pointer. In this
838 case it will only be used as the initializing expression
839 of the pointer and thus needs no special treatment with
840 regard to multiple evaluations. */
841 if (maybe_stable_expr)
844 /* Otherwise, try to stabilize now, restricting to lvalues
845 only, and attach the expression to the pointer if the
846 stabilization succeeds.
848 Note that this might introduce SAVE_EXPRs and we don't
849 check whether we're at the global level or not. This is
850 fine since we are building a pointer initializer and
851 neither the pointer nor the initializing expression can
852 be accessed before the pointer elaboration has taken
853 place in a correct program.
855 SAVE_EXPRs will be evaluated at the right spots by either
856 create_var_decl->expand_decl_init for the non-global case
857 or build_unit_elab for the global case, and will be
858 attached to the elaboration procedure by the RTL expander
859 in the latter case. We have no need to force an early
860 evaluation here. */
861 else
863 maybe_stable_expr
864 = maybe_stabilize_reference (gnu_expr, true, true,
865 &stabilized);
867 if (stabilized)
868 renamed_obj = maybe_stable_expr;
870 /* Attaching is actually performed downstream, as soon
871 as we have a VAR_DECL for the pointer we make. */
874 gnu_expr
875 = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
877 gnu_size = NULL_TREE;
878 used_by_ref = true;
883 /* If this is an aliased object whose nominal subtype is unconstrained,
884 the object is a record that contains both the template and
885 the object. If there is an initializer, it will have already
886 been converted to the right type, but we need to create the
887 template if there is no initializer. */
888 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
889 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
890 /* Beware that padding might have been introduced
891 via maybe_pad_type above. */
892 || (TYPE_IS_PADDING_P (gnu_type)
893 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
894 == RECORD_TYPE
895 && TYPE_CONTAINS_TEMPLATE_P
896 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
897 && !gnu_expr)
899 tree template_field
900 = TYPE_IS_PADDING_P (gnu_type)
901 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
902 : TYPE_FIELDS (gnu_type);
904 gnu_expr
905 = gnat_build_constructor
906 (gnu_type,
907 tree_cons
908 (template_field,
909 build_template (TREE_TYPE (template_field),
910 TREE_TYPE (TREE_CHAIN (template_field)),
911 NULL_TREE),
912 NULL_TREE));
915 /* If this is a pointer and it does not have an initializing
916 expression, initialize it to NULL, unless the object is
917 imported. */
918 if (definition
919 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
920 && !Is_Imported (gnat_entity) && !gnu_expr)
921 gnu_expr = integer_zero_node;
923 /* If we are defining the object and it has an Address clause we must
924 get the address expression from the saved GCC tree for the
925 object if the object has a Freeze_Node. Otherwise, we elaborate
926 the address expression here since the front-end has guaranteed
927 in that case that the elaboration has no effects. Note that
928 only the latter mechanism is currently in use. */
929 if (definition && Present (Address_Clause (gnat_entity)))
931 tree gnu_address
932 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
933 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
935 save_gnu_tree (gnat_entity, NULL_TREE, false);
937 /* Ignore the size. It's either meaningless or was handled
938 above. */
939 gnu_size = NULL_TREE;
940 /* The address expression contains a conversion from pointer type
941 to the system__address integer type, which means the address
942 of the underlying object escapes. We therefore have no other
943 choice than forcing the type of the object being defined to
944 alias everything in order to make type-based alias analysis
945 aware that it will dereference the escaped address.
946 ??? This uncovers problems in ACATS at -O2 with the volatility
947 of the original type: it may not be correctly propagated, thus
948 causing PRE to enter an infinite loop creating value numbers
949 out of volatile expressions. Disable it for now. */
950 gnu_type
951 = build_reference_type_for_mode (gnu_type, ptr_mode, false);
952 gnu_address = convert (gnu_type, gnu_address);
953 used_by_ref = true;
954 const_flag = !Is_Public (gnat_entity);
956 /* If we don't have an initializing expression for the underlying
957 variable, the initializing expression for the pointer is the
958 specified address. Otherwise, we have to make a COMPOUND_EXPR
959 to assign both the address and the initial value. */
960 if (!gnu_expr)
961 gnu_expr = gnu_address;
962 else
963 gnu_expr
964 = build2 (COMPOUND_EXPR, gnu_type,
965 build_binary_op
966 (MODIFY_EXPR, NULL_TREE,
967 build_unary_op (INDIRECT_REF, NULL_TREE,
968 gnu_address),
969 gnu_expr),
970 gnu_address);
973 /* If it has an address clause and we are not defining it, mark it
974 as an indirect object. Likewise for Stdcall objects that are
975 imported. */
976 if ((!definition && Present (Address_Clause (gnat_entity)))
977 || (Is_Imported (gnat_entity)
978 && Has_Stdcall_Convention (gnat_entity)))
980 /* See the definition case above for the rationale. */
981 gnu_type
982 = build_reference_type_for_mode (gnu_type, ptr_mode, false);
983 gnu_size = NULL_TREE;
985 gnu_expr = NULL_TREE;
986 /* No point in taking the address of an initializing expression
987 that isn't going to be used. */
989 used_by_ref = true;
992 /* If we are at top level and this object is of variable size,
993 make the actual type a hidden pointer to the real type and
994 make the initializer be a memory allocation and initialization.
995 Likewise for objects we aren't defining (presumed to be
996 external references from other packages), but there we do
997 not set up an initialization.
999 If the object's size overflows, make an allocator too, so that
1000 Storage_Error gets raised. Note that we will never free
1001 such memory, so we presume it never will get allocated. */
1003 if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
1004 global_bindings_p () || !definition
1005 || static_p)
1006 || (gnu_size
1007 && ! allocatable_size_p (gnu_size,
1008 global_bindings_p () || !definition
1009 || static_p)))
1011 gnu_type = build_reference_type (gnu_type);
1012 gnu_size = NULL_TREE;
1013 used_by_ref = true;
1014 const_flag = true;
1016 /* In case this was a aliased object whose nominal subtype is
1017 unconstrained, the pointer above will be a thin pointer and
1018 build_allocator will automatically make the template.
1020 If we have a template initializer only (that we made above),
1021 pretend there is none and rely on what build_allocator creates
1022 again anyway. Otherwise (if we have a full initializer), get
1023 the data part and feed that to build_allocator.
1025 If we are elaborating a mutable object, tell build_allocator to
1026 ignore a possibly simpler size from the initializer, if any, as
1027 we must allocate the maximum possible size in this case. */
1029 if (definition)
1031 tree gnu_alloc_type = TREE_TYPE (gnu_type);
1033 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
1034 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
1036 gnu_alloc_type
1037 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
1039 if (TREE_CODE (gnu_expr) == CONSTRUCTOR
1040 && 1 == VEC_length (constructor_elt,
1041 CONSTRUCTOR_ELTS (gnu_expr)))
1042 gnu_expr = 0;
1043 else
1044 gnu_expr
1045 = build_component_ref
1046 (gnu_expr, NULL_TREE,
1047 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
1048 false);
1051 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
1052 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
1053 && !Is_Imported (gnat_entity))
1054 post_error ("Storage_Error will be raised at run-time?",
1055 gnat_entity);
1057 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
1058 0, 0, gnat_entity, mutable_p);
1060 else
1062 gnu_expr = NULL_TREE;
1063 const_flag = false;
1067 /* If this object would go into the stack and has an alignment
1068 larger than the default largest alignment, make a variable
1069 to hold the "aligning type" with a modified initial value,
1070 if any, then point to it and make that the value of this
1071 variable, which is now indirect. */
1072 if (!global_bindings_p () && !static_p && definition
1073 && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
1075 tree gnu_new_type
1076 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
1077 TYPE_SIZE_UNIT (gnu_type));
1078 tree gnu_new_var;
1080 gnu_new_var
1081 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
1082 NULL_TREE, gnu_new_type, NULL_TREE, false,
1083 false, false, false, NULL, gnat_entity);
1085 if (gnu_expr)
1086 add_stmt_with_node
1087 (build_binary_op (MODIFY_EXPR, NULL_TREE,
1088 build_component_ref
1089 (gnu_new_var, NULL_TREE,
1090 TYPE_FIELDS (gnu_new_type), false),
1091 gnu_expr),
1092 gnat_entity);
1094 gnu_type = build_reference_type (gnu_type);
1095 gnu_expr
1096 = build_unary_op
1097 (ADDR_EXPR, gnu_type,
1098 build_component_ref (gnu_new_var, NULL_TREE,
1099 TYPE_FIELDS (gnu_new_type), false));
1101 gnu_size = NULL_TREE;
1102 used_by_ref = true;
1103 const_flag = true;
1106 if (const_flag)
1107 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1108 | TYPE_QUAL_CONST));
1110 /* Convert the expression to the type of the object except in the
1111 case where the object's type is unconstrained or the object's type
1112 is a padded record whose field is of self-referential size. In
1113 the former case, converting will generate unnecessary evaluations
1114 of the CONSTRUCTOR to compute the size and in the latter case, we
1115 want to only copy the actual data. */
1116 if (gnu_expr
1117 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1118 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1119 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1120 && TYPE_IS_PADDING_P (gnu_type)
1121 && (CONTAINS_PLACEHOLDER_P
1122 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1123 gnu_expr = convert (gnu_type, gnu_expr);
1125 /* If this name is external or there was a name specified, use it,
1126 unless this is a VMS exception object since this would conflict
1127 with the symbol we need to export in addition. Don't use the
1128 Interface_Name if there is an address clause (see CD30005). */
1129 if (!Is_VMS_Exception (gnat_entity)
1130 && ((Present (Interface_Name (gnat_entity))
1131 && No (Address_Clause (gnat_entity)))
1132 || (Is_Public (gnat_entity)
1133 && (!Is_Imported (gnat_entity)
1134 || Is_Exported (gnat_entity)))))
1135 gnu_ext_name = create_concat_name (gnat_entity, 0);
1137 /* If this is constant initialized to a static constant and the
1138 object has an aggregate type, force it to be statically
1139 allocated. */
1140 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1141 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1142 && (AGGREGATE_TYPE_P (gnu_type)
1143 && !(TREE_CODE (gnu_type) == RECORD_TYPE
1144 && TYPE_IS_PADDING_P (gnu_type))))
1145 static_p = true;
1147 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1148 gnu_expr, const_flag,
1149 Is_Public (gnat_entity),
1150 imported_p || !definition,
1151 static_p, attr_list, gnat_entity);
1152 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1153 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1154 if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
1156 SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
1157 if (global_bindings_p ())
1159 DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
1160 record_global_renaming_pointer (gnu_decl);
1164 if (definition && DECL_SIZE (gnu_decl)
1165 && get_block_jmpbuf_decl ()
1166 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1167 || (flag_stack_check && !STACK_CHECK_BUILTIN
1168 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1169 STACK_CHECK_MAX_VAR_SIZE))))
1170 add_stmt_with_node (build_call_1_expr
1171 (update_setjmp_buf_decl,
1172 build_unary_op (ADDR_EXPR, NULL_TREE,
1173 get_block_jmpbuf_decl ())),
1174 gnat_entity);
1176 /* If this is a public constant or we're not optimizing and we're not
1177 making a VAR_DECL for it, make one just for export or debugger
1178 use. Likewise if the address is taken or if the object or type is
1179 aliased. */
1180 if (definition && TREE_CODE (gnu_decl) == CONST_DECL
1181 && (Is_Public (gnat_entity)
1182 || optimize == 0
1183 || Address_Taken (gnat_entity)
1184 || Is_Aliased (gnat_entity)
1185 || Is_Aliased (Etype (gnat_entity))))
1187 tree gnu_corr_var
1188 = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1189 gnu_expr, true, Is_Public (gnat_entity),
1190 false, static_p, NULL, gnat_entity);
1192 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
1195 /* If this is declared in a block that contains a block with an
1196 exception handler, we must force this variable in memory to
1197 suppress an invalid optimization. */
1198 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1199 && Exception_Mechanism != Back_End_Exceptions)
1200 TREE_ADDRESSABLE (gnu_decl) = 1;
1202 /* Back-annotate the Alignment of the object if not already in the
1203 tree. Likewise for Esize if the object is of a constant size.
1204 But if the "object" is actually a pointer to an object, the
1205 alignment and size are the same as the type, so don't back-annotate
1206 the values for the pointer. */
1207 if (!used_by_ref && Unknown_Alignment (gnat_entity))
1208 Set_Alignment (gnat_entity,
1209 UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT));
1211 if (!used_by_ref && Unknown_Esize (gnat_entity)
1212 && DECL_SIZE (gnu_decl))
1214 tree gnu_back_size = DECL_SIZE (gnu_decl);
1216 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
1217 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl)))
1218 gnu_back_size
1219 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN
1220 (TYPE_FIELDS (TREE_TYPE (gnu_decl)))));
1222 Set_Esize (gnat_entity, annotate_value (gnu_back_size));
1225 break;
1227 case E_Void:
1228 /* Return a TYPE_DECL for "void" that we previously made. */
1229 gnu_decl = void_type_decl_node;
1230 break;
1232 case E_Enumeration_Type:
1233 /* A special case, for the types Character and Wide_Character in
1234 Standard, we do not list all the literals. So if the literals
1235 are not specified, make this an unsigned type. */
1236 if (No (First_Literal (gnat_entity)))
1238 gnu_type = make_unsigned_type (esize);
1239 TYPE_NAME (gnu_type) = gnu_entity_id;
1241 /* Set the TYPE_STRING_FLAG for Ada Character and
1242 Wide_Character types. This is needed by the dwarf-2 debug writer to
1243 distinguish between unsigned integer types and character types. */
1244 TYPE_STRING_FLAG (gnu_type) = 1;
1245 break;
1248 /* Normal case of non-character type, or non-Standard character type */
1250 /* Here we have a list of enumeral constants in First_Literal.
1251 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1252 the list to be places into TYPE_FIELDS. Each node in the list
1253 is a TREE_LIST node whose TREE_VALUE is the literal name
1254 and whose TREE_PURPOSE is the value of the literal.
1256 Esize contains the number of bits needed to represent the enumeral
1257 type, Type_Low_Bound also points to the first literal and
1258 Type_High_Bound points to the last literal. */
1260 Entity_Id gnat_literal;
1261 tree gnu_literal_list = NULL_TREE;
1263 if (Is_Unsigned_Type (gnat_entity))
1264 gnu_type = make_unsigned_type (esize);
1265 else
1266 gnu_type = make_signed_type (esize);
1268 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1270 for (gnat_literal = First_Literal (gnat_entity);
1271 Present (gnat_literal);
1272 gnat_literal = Next_Literal (gnat_literal))
1274 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1275 gnu_type);
1276 tree gnu_literal
1277 = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
1278 gnu_type, gnu_value, true, false, false,
1279 false, NULL, gnat_literal);
1281 save_gnu_tree (gnat_literal, gnu_literal, false);
1282 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1283 gnu_value, gnu_literal_list);
1286 TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
1288 /* Note that the bounds are updated at the end of this function
1289 because to avoid an infinite recursion when we get the bounds of
1290 this type, since those bounds are objects of this type. */
1292 break;
1294 case E_Signed_Integer_Type:
1295 case E_Ordinary_Fixed_Point_Type:
1296 case E_Decimal_Fixed_Point_Type:
1297 /* For integer types, just make a signed type the appropriate number
1298 of bits. */
1299 gnu_type = make_signed_type (esize);
1300 break;
1302 case E_Modular_Integer_Type:
1303 /* For modular types, make the unsigned type of the proper number of
1304 bits and then set up the modulus, if required. */
1306 enum machine_mode mode;
1307 tree gnu_modulus;
1308 tree gnu_high = 0;
1310 if (Is_Packed_Array_Type (gnat_entity))
1311 esize = UI_To_Int (RM_Size (gnat_entity));
1313 /* Find the smallest mode at least ESIZE bits wide and make a class
1314 using that mode. */
1316 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1317 GET_MODE_BITSIZE (mode) < esize;
1318 mode = GET_MODE_WIDER_MODE (mode))
1321 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1322 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1323 = Is_Packed_Array_Type (gnat_entity);
1325 /* Get the modulus in this type. If it overflows, assume it is because
1326 it is equal to 2**Esize. Note that there is no overflow checking
1327 done on unsigned type, so we detect the overflow by looking for
1328 a modulus of zero, which is otherwise invalid. */
1329 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1331 if (!integer_zerop (gnu_modulus))
1333 TYPE_MODULAR_P (gnu_type) = 1;
1334 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1335 gnu_high = fold (build2 (MINUS_EXPR, gnu_type, gnu_modulus,
1336 convert (gnu_type, integer_one_node)));
1339 /* If we have to set TYPE_PRECISION different from its natural value,
1340 make a subtype to do do. Likewise if there is a modulus and
1341 it is not one greater than TYPE_MAX_VALUE. */
1342 if (TYPE_PRECISION (gnu_type) != esize
1343 || (TYPE_MODULAR_P (gnu_type)
1344 && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1346 tree gnu_subtype = make_node (INTEGER_TYPE);
1348 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1349 TREE_TYPE (gnu_subtype) = gnu_type;
1350 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1351 TYPE_MAX_VALUE (gnu_subtype)
1352 = TYPE_MODULAR_P (gnu_type)
1353 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1354 TYPE_PRECISION (gnu_subtype) = esize;
1355 TYPE_UNSIGNED (gnu_subtype) = 1;
1356 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1357 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1358 = Is_Packed_Array_Type (gnat_entity);
1359 layout_type (gnu_subtype);
1361 gnu_type = gnu_subtype;
1364 break;
1366 case E_Signed_Integer_Subtype:
1367 case E_Enumeration_Subtype:
1368 case E_Modular_Integer_Subtype:
1369 case E_Ordinary_Fixed_Point_Subtype:
1370 case E_Decimal_Fixed_Point_Subtype:
1372 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1373 that we do not want to call build_range_type since we would
1374 like each subtype node to be distinct. This will be important
1375 when memory aliasing is implemented.
1377 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1378 parent type; this fact is used by the arithmetic conversion
1379 functions.
1381 We elaborate the Ancestor_Subtype if it is not in the current
1382 unit and one of our bounds is non-static. We do this to ensure
1383 consistent naming in the case where several subtypes share the same
1384 bounds by always elaborating the first such subtype first, thus
1385 using its name. */
1387 if (definition == 0
1388 && Present (Ancestor_Subtype (gnat_entity))
1389 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1390 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1391 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1392 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1393 gnu_expr, definition);
1395 gnu_type = make_node (INTEGER_TYPE);
1396 if (Is_Packed_Array_Type (gnat_entity))
1398 esize = UI_To_Int (RM_Size (gnat_entity));
1399 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1402 TYPE_PRECISION (gnu_type) = esize;
1403 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1405 TYPE_MIN_VALUE (gnu_type)
1406 = convert (TREE_TYPE (gnu_type),
1407 elaborate_expression (Type_Low_Bound (gnat_entity),
1408 gnat_entity,
1409 get_identifier ("L"), definition, 1,
1410 Needs_Debug_Info (gnat_entity)));
1412 TYPE_MAX_VALUE (gnu_type)
1413 = convert (TREE_TYPE (gnu_type),
1414 elaborate_expression (Type_High_Bound (gnat_entity),
1415 gnat_entity,
1416 get_identifier ("U"), definition, 1,
1417 Needs_Debug_Info (gnat_entity)));
1419 /* One of the above calls might have caused us to be elaborated,
1420 so don't blow up if so. */
1421 if (present_gnu_tree (gnat_entity))
1423 maybe_present = true;
1424 break;
1427 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1428 = Has_Biased_Representation (gnat_entity);
1430 /* This should be an unsigned type if the lower bound is constant
1431 and non-negative or if the base type is unsigned; a signed type
1432 otherwise. */
1433 TYPE_UNSIGNED (gnu_type)
1434 = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
1435 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1436 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1437 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1438 || Is_Unsigned_Type (gnat_entity));
1440 layout_type (gnu_type);
1442 /* Inherit our alias set from what we're a subtype of. Subtypes
1443 are not different types and a pointer can designate any instance
1444 within a subtype hierarchy. */
1445 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1447 /* If the type we are dealing with is to represent a packed array,
1448 we need to have the bits left justified on big-endian targets
1449 and right justified on little-endian targets. We also need to
1450 ensure that when the value is read (e.g. for comparison of two
1451 such values), we only get the good bits, since the unused bits
1452 are uninitialized. Both goals are accomplished by wrapping the
1453 modular value in an enclosing struct. */
1454 if (Is_Packed_Array_Type (gnat_entity))
1456 tree gnu_field_type = gnu_type;
1457 tree gnu_field;
1459 TYPE_RM_SIZE_NUM (gnu_field_type)
1460 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1461 gnu_type = make_node (RECORD_TYPE);
1462 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
1463 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1464 TYPE_PACKED (gnu_type) = 1;
1466 /* Create a stripped-down declaration of the original type, mainly
1467 for debugging. */
1468 create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
1469 NULL, true, debug_info_p, gnat_entity);
1471 /* Don't notify the field as "addressable", since we won't be taking
1472 it's address and it would prevent create_field_decl from making a
1473 bitfield. */
1474 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1475 gnu_field_type, gnu_type, 1, 0, 0, 0);
1477 finish_record_type (gnu_type, gnu_field, false, false);
1478 TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1479 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1481 copy_alias_set (gnu_type, gnu_field_type);
1484 break;
1486 case E_Floating_Point_Type:
1487 /* If this is a VAX floating-point type, use an integer of the proper
1488 size. All the operations will be handled with ASM statements. */
1489 if (Vax_Float (gnat_entity))
1491 gnu_type = make_signed_type (esize);
1492 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1493 SET_TYPE_DIGITS_VALUE (gnu_type,
1494 UI_To_gnu (Digits_Value (gnat_entity),
1495 sizetype));
1496 break;
1499 /* The type of the Low and High bounds can be our type if this is
1500 a type from Standard, so set them at the end of the function. */
1501 gnu_type = make_node (REAL_TYPE);
1502 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1503 layout_type (gnu_type);
1504 break;
1506 case E_Floating_Point_Subtype:
1507 if (Vax_Float (gnat_entity))
1509 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1510 break;
1514 if (definition == 0
1515 && Present (Ancestor_Subtype (gnat_entity))
1516 && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1517 && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1518 || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1519 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1520 gnu_expr, definition);
1522 gnu_type = make_node (REAL_TYPE);
1523 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1524 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1526 TYPE_MIN_VALUE (gnu_type)
1527 = convert (TREE_TYPE (gnu_type),
1528 elaborate_expression (Type_Low_Bound (gnat_entity),
1529 gnat_entity, get_identifier ("L"),
1530 definition, 1,
1531 Needs_Debug_Info (gnat_entity)));
1533 TYPE_MAX_VALUE (gnu_type)
1534 = convert (TREE_TYPE (gnu_type),
1535 elaborate_expression (Type_High_Bound (gnat_entity),
1536 gnat_entity, get_identifier ("U"),
1537 definition, 1,
1538 Needs_Debug_Info (gnat_entity)));
1540 /* One of the above calls might have caused us to be elaborated,
1541 so don't blow up if so. */
1542 if (present_gnu_tree (gnat_entity))
1544 maybe_present = true;
1545 break;
1548 layout_type (gnu_type);
1550 /* Inherit our alias set from what we're a subtype of, as for
1551 integer subtypes. */
1552 copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
1554 break;
1556 /* Array and String Types and Subtypes
1558 Unconstrained array types are represented by E_Array_Type and
1559 constrained array types are represented by E_Array_Subtype. There
1560 are no actual objects of an unconstrained array type; all we have
1561 are pointers to that type.
1563 The following fields are defined on array types and subtypes:
1565 Component_Type Component type of the array.
1566 Number_Dimensions Number of dimensions (an int).
1567 First_Index Type of first index. */
1569 case E_String_Type:
1570 case E_Array_Type:
1572 tree gnu_template_fields = NULL_TREE;
1573 tree gnu_template_type = make_node (RECORD_TYPE);
1574 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1575 tree gnu_fat_type = make_node (RECORD_TYPE);
1576 int ndim = Number_Dimensions (gnat_entity);
1577 int firstdim
1578 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1579 int nextdim
1580 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1581 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1582 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1583 tree gnu_comp_size = 0;
1584 tree gnu_max_size = size_one_node;
1585 tree gnu_max_size_unit;
1586 int index;
1587 Entity_Id gnat_ind_subtype;
1588 Entity_Id gnat_ind_base_subtype;
1589 tree gnu_template_reference;
1590 tree tem;
1592 TYPE_NAME (gnu_template_type)
1593 = create_concat_name (gnat_entity, "XUB");
1594 TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP");
1595 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1596 TYPE_READONLY (gnu_template_type) = 1;
1598 /* Make a node for the array. If we are not defining the array
1599 suppress expanding incomplete types. */
1600 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1602 if (!definition)
1603 defer_incomplete_level++, this_deferred = true;
1605 /* Build the fat pointer type. Use a "void *" object instead of
1606 a pointer to the array type since we don't have the array type
1607 yet (it will reference the fat pointer via the bounds). */
1608 tem = chainon (chainon (NULL_TREE,
1609 create_field_decl (get_identifier ("P_ARRAY"),
1610 ptr_void_type_node,
1611 gnu_fat_type, 0, 0, 0, 0)),
1612 create_field_decl (get_identifier ("P_BOUNDS"),
1613 gnu_ptr_template,
1614 gnu_fat_type, 0, 0, 0, 0));
1616 /* Make sure we can put this into a register. */
1617 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1618 finish_record_type (gnu_fat_type, tem, false, true);
1620 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1621 is the fat pointer. This will be used to access the individual
1622 fields once we build them. */
1623 tem = build3 (COMPONENT_REF, gnu_ptr_template,
1624 build0 (PLACEHOLDER_EXPR, gnu_fat_type),
1625 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
1626 gnu_template_reference
1627 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1628 TREE_READONLY (gnu_template_reference) = 1;
1630 /* Now create the GCC type for each index and add the fields for
1631 that index to the template. */
1632 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1633 gnat_ind_base_subtype
1634 = First_Index (Implementation_Base_Type (gnat_entity));
1635 index < ndim && index >= 0;
1636 index += nextdim,
1637 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1638 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1640 char field_name[10];
1641 tree gnu_ind_subtype
1642 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1643 tree gnu_base_subtype
1644 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1645 tree gnu_base_min
1646 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1647 tree gnu_base_max
1648 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1649 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1651 /* Make the FIELD_DECLs for the minimum and maximum of this
1652 type and then make extractions of that field from the
1653 template. */
1654 sprintf (field_name, "LB%d", index);
1655 gnu_min_field = create_field_decl (get_identifier (field_name),
1656 gnu_ind_subtype,
1657 gnu_template_type, 0, 0, 0, 0);
1658 field_name[0] = 'U';
1659 gnu_max_field = create_field_decl (get_identifier (field_name),
1660 gnu_ind_subtype,
1661 gnu_template_type, 0, 0, 0, 0);
1663 Sloc_to_locus (Sloc (gnat_entity),
1664 &DECL_SOURCE_LOCATION (gnu_min_field));
1665 Sloc_to_locus (Sloc (gnat_entity),
1666 &DECL_SOURCE_LOCATION (gnu_max_field));
1667 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1669 /* We can't use build_component_ref here since the template
1670 type isn't complete yet. */
1671 gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
1672 gnu_template_reference, gnu_min_field,
1673 NULL_TREE);
1674 gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
1675 gnu_template_reference, gnu_max_field,
1676 NULL_TREE);
1677 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1679 /* Make a range type with the new ranges, but using
1680 the Ada subtype. Then we convert to sizetype. */
1681 gnu_index_types[index]
1682 = create_index_type (convert (sizetype, gnu_min),
1683 convert (sizetype, gnu_max),
1684 build_range_type (gnu_ind_subtype,
1685 gnu_min, gnu_max));
1686 /* Update the maximum size of the array, in elements. */
1687 gnu_max_size
1688 = size_binop (MULT_EXPR, gnu_max_size,
1689 size_binop (PLUS_EXPR, size_one_node,
1690 size_binop (MINUS_EXPR, gnu_base_max,
1691 gnu_base_min)));
1693 TYPE_NAME (gnu_index_types[index])
1694 = create_concat_name (gnat_entity, field_name);
1697 for (index = 0; index < ndim; index++)
1698 gnu_template_fields
1699 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1701 /* Install all the fields into the template. */
1702 finish_record_type (gnu_template_type, gnu_template_fields,
1703 false, false);
1704 TYPE_READONLY (gnu_template_type) = 1;
1706 /* Now make the array of arrays and update the pointer to the array
1707 in the fat pointer. Note that it is the first field. */
1709 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1711 /* Get and validate any specified Component_Size, but if Packed,
1712 ignore it since the front end will have taken care of it. */
1713 gnu_comp_size
1714 = validate_size (Component_Size (gnat_entity), tem,
1715 gnat_entity,
1716 (Is_Bit_Packed_Array (gnat_entity)
1717 ? TYPE_DECL : VAR_DECL),
1718 true, Has_Component_Size_Clause (gnat_entity));
1720 if (Has_Atomic_Components (gnat_entity))
1721 check_ok_for_atomic (tem, gnat_entity, true);
1723 /* If the component type is a RECORD_TYPE that has a self-referential
1724 size, use the maxium size. */
1725 if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
1726 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1727 gnu_comp_size = max_size (TYPE_SIZE (tem), true);
1729 if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
1731 tem = make_type_from_size (tem, gnu_comp_size, false);
1732 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1733 "C_PAD", false, definition, true);
1736 if (Has_Volatile_Components (gnat_entity))
1737 tem = build_qualified_type (tem,
1738 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1740 /* If Component_Size is not already specified, annotate it with the
1741 size of the component. */
1742 if (Unknown_Component_Size (gnat_entity))
1743 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1745 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1746 size_binop (MULT_EXPR, gnu_max_size,
1747 TYPE_SIZE_UNIT (tem)));
1748 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1749 size_binop (MULT_EXPR,
1750 convert (bitsizetype,
1751 gnu_max_size),
1752 TYPE_SIZE (tem)));
1754 for (index = ndim - 1; index >= 0; index--)
1756 tem = build_array_type (tem, gnu_index_types[index]);
1757 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1759 /* If the type below this is a multi-array type, then this
1760 does not have aliased components. But we have to make
1761 them addressable if it must be passed by reference or
1762 if that is the default. */
1763 if ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
1764 && TYPE_MULTI_ARRAY_P (TREE_TYPE (tem)))
1765 || (!Has_Aliased_Components (gnat_entity)
1766 && !must_pass_by_ref (TREE_TYPE (tem))
1767 && !default_pass_by_ref (TREE_TYPE (tem))))
1768 TYPE_NONALIASED_COMPONENT (tem) = 1;
1771 /* If an alignment is specified, use it if valid. But ignore it for
1772 types that represent the unpacked base type for packed arrays. */
1773 if (No (Packed_Array_Type (gnat_entity))
1774 && Known_Alignment (gnat_entity))
1776 gcc_assert (Present (Alignment (gnat_entity)));
1777 TYPE_ALIGN (tem)
1778 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1779 TYPE_ALIGN (tem));
1782 TYPE_CONVENTION_FORTRAN_P (tem)
1783 = (Convention (gnat_entity) == Convention_Fortran);
1784 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1786 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1787 corresponding fat pointer. */
1788 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1789 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1790 TYPE_MODE (gnu_type) = BLKmode;
1791 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1792 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1794 /* If the maximum size doesn't overflow, use it. */
1795 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1796 && !TREE_OVERFLOW (gnu_max_size))
1797 TYPE_SIZE (tem)
1798 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
1799 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1800 && !TREE_OVERFLOW (gnu_max_size_unit))
1801 TYPE_SIZE_UNIT (tem)
1802 = size_binop (MIN_EXPR, gnu_max_size_unit,
1803 TYPE_SIZE_UNIT (tem));
1805 create_type_decl (create_concat_name (gnat_entity, "XUA"),
1806 tem, NULL, !Comes_From_Source (gnat_entity),
1807 debug_info_p, gnat_entity);
1809 /* Create a record type for the object and its template and
1810 set the template at a negative offset. */
1811 tem = build_unc_object_type (gnu_template_type, tem,
1812 create_concat_name (gnat_entity, "XUT"));
1813 DECL_FIELD_OFFSET (TYPE_FIELDS (tem))
1814 = size_binop (MINUS_EXPR, size_zero_node,
1815 byte_position (TREE_CHAIN (TYPE_FIELDS (tem))));
1816 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node;
1817 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem)))
1818 = bitsize_zero_node;
1819 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
1820 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
1822 /* Give the thin pointer type a name. */
1823 create_type_decl (create_concat_name (gnat_entity, "XUX"),
1824 build_pointer_type (tem), NULL,
1825 !Comes_From_Source (gnat_entity), debug_info_p,
1826 gnat_entity);
1828 break;
1830 case E_String_Subtype:
1831 case E_Array_Subtype:
1833 /* This is the actual data type for array variables. Multidimensional
1834 arrays are implemented in the gnu tree as arrays of arrays. Note
1835 that for the moment arrays which have sparse enumeration subtypes as
1836 index components create sparse arrays, which is obviously space
1837 inefficient but so much easier to code for now.
1839 Also note that the subtype never refers to the unconstrained
1840 array type, which is somewhat at variance with Ada semantics.
1842 First check to see if this is simply a renaming of the array
1843 type. If so, the result is the array type. */
1845 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1846 if (!Is_Constrained (gnat_entity))
1847 break;
1848 else
1850 int index;
1851 int array_dim = Number_Dimensions (gnat_entity);
1852 int first_dim
1853 = ((Convention (gnat_entity) == Convention_Fortran)
1854 ? array_dim - 1 : 0);
1855 int next_dim
1856 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
1857 Entity_Id gnat_ind_subtype;
1858 Entity_Id gnat_ind_base_subtype;
1859 tree gnu_base_type = gnu_type;
1860 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
1861 tree gnu_comp_size = NULL_TREE;
1862 tree gnu_max_size = size_one_node;
1863 tree gnu_max_size_unit;
1864 bool need_index_type_struct = false;
1865 bool max_overflow = false;
1867 /* First create the gnu types for each index. Create types for
1868 debugging information to point to the index types if the
1869 are not integer types, have variable bounds, or are
1870 wider than sizetype. */
1872 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
1873 gnat_ind_base_subtype
1874 = First_Index (Implementation_Base_Type (gnat_entity));
1875 index < array_dim && index >= 0;
1876 index += next_dim,
1877 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1878 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1880 tree gnu_index_subtype
1881 = get_unpadded_type (Etype (gnat_ind_subtype));
1882 tree gnu_min
1883 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
1884 tree gnu_max
1885 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
1886 tree gnu_base_subtype
1887 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1888 tree gnu_base_min
1889 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1890 tree gnu_base_max
1891 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1892 tree gnu_base_type = get_base_type (gnu_base_subtype);
1893 tree gnu_base_base_min
1894 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
1895 tree gnu_base_base_max
1896 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
1897 tree gnu_high;
1898 tree gnu_this_max;
1900 /* If the minimum and maximum values both overflow in
1901 SIZETYPE, but the difference in the original type
1902 does not overflow in SIZETYPE, ignore the overflow
1903 indications. */
1904 if ((TYPE_PRECISION (gnu_index_subtype)
1905 > TYPE_PRECISION (sizetype)
1906 || TYPE_UNSIGNED (gnu_index_subtype)
1907 != TYPE_UNSIGNED (sizetype))
1908 && TREE_CODE (gnu_min) == INTEGER_CST
1909 && TREE_CODE (gnu_max) == INTEGER_CST
1910 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
1911 && (!TREE_OVERFLOW
1912 (fold (build2 (MINUS_EXPR, gnu_index_subtype,
1913 TYPE_MAX_VALUE (gnu_index_subtype),
1914 TYPE_MIN_VALUE (gnu_index_subtype))))))
1915 TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max) = 0;
1917 /* Similarly, if the range is null, use bounds of 1..0 for
1918 the sizetype bounds. */
1919 else if ((TYPE_PRECISION (gnu_index_subtype)
1920 > TYPE_PRECISION (sizetype)
1921 || TYPE_UNSIGNED (gnu_index_subtype)
1922 != TYPE_UNSIGNED (sizetype))
1923 && TREE_CODE (gnu_min) == INTEGER_CST
1924 && TREE_CODE (gnu_max) == INTEGER_CST
1925 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
1926 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
1927 TYPE_MIN_VALUE (gnu_index_subtype)))
1928 gnu_min = size_one_node, gnu_max = size_zero_node;
1930 /* Now compute the size of this bound. We need to provide
1931 GCC with an upper bound to use but have to deal with the
1932 "superflat" case. There are three ways to do this. If we
1933 can prove that the array can never be superflat, we can
1934 just use the high bound of the index subtype. If we can
1935 prove that the low bound minus one can't overflow, we
1936 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1937 the expression hb >= lb ? hb : lb - 1. */
1938 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
1940 /* See if the base array type is already flat. If it is, we
1941 are probably compiling an ACVC test, but it will cause the
1942 code below to malfunction if we don't handle it specially. */
1943 if (TREE_CODE (gnu_base_min) == INTEGER_CST
1944 && TREE_CODE (gnu_base_max) == INTEGER_CST
1945 && !TREE_OVERFLOW (gnu_base_min)
1946 && !TREE_OVERFLOW (gnu_base_max)
1947 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
1948 gnu_high = size_zero_node, gnu_min = size_one_node;
1950 /* If gnu_high is now an integer which overflowed, the array
1951 cannot be superflat. */
1952 else if (TREE_CODE (gnu_high) == INTEGER_CST
1953 && TREE_OVERFLOW (gnu_high))
1954 gnu_high = gnu_max;
1955 else if (TYPE_UNSIGNED (gnu_base_subtype)
1956 || TREE_CODE (gnu_high) == INTEGER_CST)
1957 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
1958 else
1959 gnu_high
1960 = build_cond_expr
1961 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
1962 gnu_max, gnu_min),
1963 gnu_max, gnu_high);
1965 gnu_index_type[index]
1966 = create_index_type (gnu_min, gnu_high, gnu_index_subtype);
1968 /* Also compute the maximum size of the array. Here we
1969 see if any constraint on the index type of the base type
1970 can be used in the case of self-referential bound on
1971 the index type of the subtype. We look for a non-"infinite"
1972 and non-self-referential bound from any type involved and
1973 handle each bound separately. */
1975 if ((TREE_CODE (gnu_min) == INTEGER_CST
1976 && !TREE_OVERFLOW (gnu_min)
1977 && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
1978 || !CONTAINS_PLACEHOLDER_P (gnu_min)
1979 || !(TREE_CODE (gnu_base_min) == INTEGER_CST
1980 && !TREE_OVERFLOW (gnu_base_min)))
1981 gnu_base_min = gnu_min;
1983 if ((TREE_CODE (gnu_max) == INTEGER_CST
1984 && !TREE_OVERFLOW (gnu_max)
1985 && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
1986 || !CONTAINS_PLACEHOLDER_P (gnu_max)
1987 || !(TREE_CODE (gnu_base_max) == INTEGER_CST
1988 && !TREE_OVERFLOW (gnu_base_max)))
1989 gnu_base_max = gnu_max;
1991 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
1992 && TREE_OVERFLOW (gnu_base_min))
1993 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
1994 || (TREE_CODE (gnu_base_max) == INTEGER_CST
1995 && TREE_OVERFLOW (gnu_base_max))
1996 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
1997 max_overflow = true;
1999 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
2000 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
2002 gnu_this_max
2003 = size_binop (MAX_EXPR,
2004 size_binop (PLUS_EXPR, size_one_node,
2005 size_binop (MINUS_EXPR, gnu_base_max,
2006 gnu_base_min)),
2007 size_zero_node);
2009 if (TREE_CODE (gnu_this_max) == INTEGER_CST
2010 && TREE_OVERFLOW (gnu_this_max))
2011 max_overflow = true;
2013 gnu_max_size
2014 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
2016 if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
2017 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
2018 != INTEGER_CST)
2019 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
2020 || (TREE_TYPE (gnu_index_subtype)
2021 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
2022 != INTEGER_TYPE))
2023 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
2024 || (TYPE_PRECISION (gnu_index_subtype)
2025 > TYPE_PRECISION (sizetype)))
2026 need_index_type_struct = true;
2029 /* Then flatten: create the array of arrays. */
2031 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
2033 /* One of the above calls might have caused us to be elaborated,
2034 so don't blow up if so. */
2035 if (present_gnu_tree (gnat_entity))
2037 maybe_present = true;
2038 break;
2041 /* Get and validate any specified Component_Size, but if Packed,
2042 ignore it since the front end will have taken care of it. */
2043 gnu_comp_size
2044 = validate_size (Component_Size (gnat_entity), gnu_type,
2045 gnat_entity,
2046 (Is_Bit_Packed_Array (gnat_entity)
2047 ? TYPE_DECL : VAR_DECL),
2048 true, Has_Component_Size_Clause (gnat_entity));
2050 /* If the component type is a RECORD_TYPE that has a self-referential
2051 size, use the maxium size. */
2052 if (!gnu_comp_size && TREE_CODE (gnu_type) == RECORD_TYPE
2053 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2054 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
2056 if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
2058 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
2059 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
2060 gnat_entity, "C_PAD", false,
2061 definition, true);
2064 if (Has_Volatile_Components (Base_Type (gnat_entity)))
2065 gnu_type = build_qualified_type (gnu_type,
2066 (TYPE_QUALS (gnu_type)
2067 | TYPE_QUAL_VOLATILE));
2069 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
2070 TYPE_SIZE_UNIT (gnu_type));
2071 gnu_max_size = size_binop (MULT_EXPR,
2072 convert (bitsizetype, gnu_max_size),
2073 TYPE_SIZE (gnu_type));
2075 for (index = array_dim - 1; index >= 0; index --)
2077 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
2078 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
2080 /* If the type below this is a multi-array type, then this
2081 does not have aliased components. But we have to make
2082 them addressable if it must be passed by reference or
2083 if that is the default. */
2084 if ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2085 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2086 || (!Has_Aliased_Components (gnat_entity)
2087 && !must_pass_by_ref (TREE_TYPE (gnu_type))
2088 && !default_pass_by_ref (TREE_TYPE (gnu_type))))
2089 TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
2092 /* If we are at file level and this is a multi-dimensional array, we
2093 need to make a variable corresponding to the stride of the
2094 inner dimensions. */
2095 if (global_bindings_p () && array_dim > 1)
2097 tree gnu_str_name = get_identifier ("ST");
2098 tree gnu_arr_type;
2100 for (gnu_arr_type = TREE_TYPE (gnu_type);
2101 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
2102 gnu_arr_type = TREE_TYPE (gnu_arr_type),
2103 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
2105 tree eltype = TREE_TYPE (gnu_arr_type);
2107 TYPE_SIZE (gnu_arr_type)
2108 = elaborate_expression_1 (gnat_entity, gnat_entity,
2109 TYPE_SIZE (gnu_arr_type),
2110 gnu_str_name, definition, 0);
2112 /* ??? For now, store the size as a multiple of the
2113 alignment of the element type in bytes so that we
2114 can see the alignment from the tree. */
2115 TYPE_SIZE_UNIT (gnu_arr_type)
2116 = build_binary_op
2117 (MULT_EXPR, sizetype,
2118 elaborate_expression_1
2119 (gnat_entity, gnat_entity,
2120 build_binary_op (EXACT_DIV_EXPR, sizetype,
2121 TYPE_SIZE_UNIT (gnu_arr_type),
2122 size_int (TYPE_ALIGN (eltype)
2123 / BITS_PER_UNIT)),
2124 concat_id_with_name (gnu_str_name, "A_U"),
2125 definition, 0),
2126 size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
2130 /* If we need to write out a record type giving the names of
2131 the bounds, do it now. */
2132 if (need_index_type_struct && debug_info_p)
2134 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
2135 tree gnu_field_list = NULL_TREE;
2136 tree gnu_field;
2138 TYPE_NAME (gnu_bound_rec_type)
2139 = create_concat_name (gnat_entity, "XA");
2141 for (index = array_dim - 1; index >= 0; index--)
2143 tree gnu_type_name
2144 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
2146 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
2147 gnu_type_name = DECL_NAME (gnu_type_name);
2149 gnu_field = create_field_decl (gnu_type_name,
2150 integer_type_node,
2151 gnu_bound_rec_type,
2152 0, NULL_TREE, NULL_TREE, 0);
2153 TREE_CHAIN (gnu_field) = gnu_field_list;
2154 gnu_field_list = gnu_field;
2157 finish_record_type (gnu_bound_rec_type, gnu_field_list,
2158 false, false);
2161 TYPE_CONVENTION_FORTRAN_P (gnu_type)
2162 = (Convention (gnat_entity) == Convention_Fortran);
2163 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
2164 = Is_Packed_Array_Type (gnat_entity);
2166 /* If our size depends on a placeholder and the maximum size doesn't
2167 overflow, use it. */
2168 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
2169 && !(TREE_CODE (gnu_max_size) == INTEGER_CST
2170 && TREE_OVERFLOW (gnu_max_size))
2171 && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2172 && TREE_OVERFLOW (gnu_max_size_unit))
2173 && !max_overflow)
2175 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2176 TYPE_SIZE (gnu_type));
2177 TYPE_SIZE_UNIT (gnu_type)
2178 = size_binop (MIN_EXPR, gnu_max_size_unit,
2179 TYPE_SIZE_UNIT (gnu_type));
2182 /* Set our alias set to that of our base type. This gives all
2183 array subtypes the same alias set. */
2184 copy_alias_set (gnu_type, gnu_base_type);
2187 /* If this is a packed type, make this type the same as the packed
2188 array type, but do some adjusting in the type first. */
2190 if (Present (Packed_Array_Type (gnat_entity)))
2192 Entity_Id gnat_index;
2193 tree gnu_inner_type;
2195 /* First finish the type we had been making so that we output
2196 debugging information for it */
2197 gnu_type
2198 = build_qualified_type (gnu_type,
2199 (TYPE_QUALS (gnu_type)
2200 | (TYPE_QUAL_VOLATILE
2201 * Treat_As_Volatile (gnat_entity))));
2202 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2203 !Comes_From_Source (gnat_entity),
2204 debug_info_p, gnat_entity);
2205 if (!Comes_From_Source (gnat_entity))
2206 DECL_ARTIFICIAL (gnu_decl) = 1;
2208 /* Save it as our equivalent in case the call below elaborates
2209 this type again. */
2210 save_gnu_tree (gnat_entity, gnu_decl, false);
2212 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2213 NULL_TREE, 0);
2214 this_made_decl = true;
2215 gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
2216 save_gnu_tree (gnat_entity, NULL_TREE, false);
2218 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2219 && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
2220 || TYPE_IS_PADDING_P (gnu_inner_type)))
2221 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2223 /* We need to point the type we just made to our index type so
2224 the actual bounds can be put into a template. */
2226 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2227 && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
2228 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2229 && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2231 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2233 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2234 If it is, we need to make another type. */
2235 if (TYPE_MODULAR_P (gnu_inner_type))
2237 tree gnu_subtype;
2239 gnu_subtype = make_node (INTEGER_TYPE);
2241 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2242 TYPE_MIN_VALUE (gnu_subtype)
2243 = TYPE_MIN_VALUE (gnu_inner_type);
2244 TYPE_MAX_VALUE (gnu_subtype)
2245 = TYPE_MAX_VALUE (gnu_inner_type);
2246 TYPE_PRECISION (gnu_subtype)
2247 = TYPE_PRECISION (gnu_inner_type);
2248 TYPE_UNSIGNED (gnu_subtype)
2249 = TYPE_UNSIGNED (gnu_inner_type);
2250 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2251 layout_type (gnu_subtype);
2253 gnu_inner_type = gnu_subtype;
2256 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2259 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2261 for (gnat_index = First_Index (gnat_entity);
2262 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2263 SET_TYPE_ACTUAL_BOUNDS
2264 (gnu_inner_type,
2265 tree_cons (NULL_TREE,
2266 get_unpadded_type (Etype (gnat_index)),
2267 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2269 if (Convention (gnat_entity) != Convention_Fortran)
2270 SET_TYPE_ACTUAL_BOUNDS
2271 (gnu_inner_type,
2272 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2274 if (TREE_CODE (gnu_type) == RECORD_TYPE
2275 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2276 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2280 /* Abort if packed array with no packed array type field set. */
2281 else
2282 gcc_assert (!Is_Packed (gnat_entity));
2284 break;
2286 case E_String_Literal_Subtype:
2287 /* Create the type for a string literal. */
2289 Entity_Id gnat_full_type
2290 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2291 && Present (Full_View (Etype (gnat_entity)))
2292 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2293 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2294 tree gnu_string_array_type
2295 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2296 tree gnu_string_index_type
2297 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2298 (TYPE_DOMAIN (gnu_string_array_type))));
2299 tree gnu_lower_bound
2300 = convert (gnu_string_index_type,
2301 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2302 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2303 tree gnu_length = ssize_int (length - 1);
2304 tree gnu_upper_bound
2305 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2306 gnu_lower_bound,
2307 convert (gnu_string_index_type, gnu_length));
2308 tree gnu_range_type
2309 = build_range_type (gnu_string_index_type,
2310 gnu_lower_bound, gnu_upper_bound);
2311 tree gnu_index_type
2312 = create_index_type (convert (sizetype,
2313 TYPE_MIN_VALUE (gnu_range_type)),
2314 convert (sizetype,
2315 TYPE_MAX_VALUE (gnu_range_type)),
2316 gnu_range_type);
2318 gnu_type
2319 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2320 gnu_index_type);
2321 copy_alias_set (gnu_type, gnu_string_type);
2323 break;
2325 /* Record Types and Subtypes
2327 The following fields are defined on record types:
2329 Has_Discriminants True if the record has discriminants
2330 First_Discriminant Points to head of list of discriminants
2331 First_Entity Points to head of list of fields
2332 Is_Tagged_Type True if the record is tagged
2334 Implementation of Ada records and discriminated records:
2336 A record type definition is transformed into the equivalent of a C
2337 struct definition. The fields that are the discriminants which are
2338 found in the Full_Type_Declaration node and the elements of the
2339 Component_List found in the Record_Type_Definition node. The
2340 Component_List can be a recursive structure since each Variant of
2341 the Variant_Part of the Component_List has a Component_List.
2343 Processing of a record type definition comprises starting the list of
2344 field declarations here from the discriminants and the calling the
2345 function components_to_record to add the rest of the fields from the
2346 component list and return the gnu type node. The function
2347 components_to_record will call itself recursively as it traverses
2348 the tree. */
2350 case E_Record_Type:
2351 if (Has_Complex_Representation (gnat_entity))
2353 gnu_type
2354 = build_complex_type
2355 (get_unpadded_type
2356 (Etype (Defining_Entity
2357 (First (Component_Items
2358 (Component_List
2359 (Type_Definition
2360 (Declaration_Node (gnat_entity)))))))));
2362 break;
2366 Node_Id full_definition = Declaration_Node (gnat_entity);
2367 Node_Id record_definition = Type_Definition (full_definition);
2368 Entity_Id gnat_field;
2369 tree gnu_field;
2370 tree gnu_field_list = NULL_TREE;
2371 tree gnu_get_parent;
2372 int packed = (Is_Packed (gnat_entity) ? 1
2373 : (Component_Alignment (gnat_entity)
2374 == Calign_Storage_Unit) ? -1
2375 : 0);
2376 bool has_rep = Has_Specified_Layout (gnat_entity);
2377 bool all_rep = has_rep;
2378 bool is_extension
2379 = (Is_Tagged_Type (gnat_entity)
2380 && Nkind (record_definition) == N_Derived_Type_Definition);
2382 /* See if all fields have a rep clause. Stop when we find one
2383 that doesn't. */
2384 for (gnat_field = First_Entity (gnat_entity);
2385 Present (gnat_field) && all_rep;
2386 gnat_field = Next_Entity (gnat_field))
2387 if ((Ekind (gnat_field) == E_Component
2388 || Ekind (gnat_field) == E_Discriminant)
2389 && No (Component_Clause (gnat_field)))
2390 all_rep = false;
2392 /* If this is a record extension, go a level further to find the
2393 record definition. Also, verify we have a Parent_Subtype. */
2394 if (is_extension)
2396 if (!type_annotate_only
2397 || Present (Record_Extension_Part (record_definition)))
2398 record_definition = Record_Extension_Part (record_definition);
2400 gcc_assert (type_annotate_only
2401 || Present (Parent_Subtype (gnat_entity)));
2404 /* Make a node for the record. If we are not defining the record,
2405 suppress expanding incomplete types. */
2406 gnu_type = make_node (tree_code_for_record_type (gnat_entity));
2407 TYPE_NAME (gnu_type) = gnu_entity_id;
2408 /* ??? We should have create_type_decl like in the E_Record_Subtype
2409 case below. Unfortunately this would cause GNU_TYPE to be marked
2410 as visited, thus precluding the subtrees of the type that will be
2411 built below from being marked as visited when the real TYPE_DECL
2412 is eventually created. A solution could be to devise a special
2413 version of the function under the name create_type_stub_decl. */
2414 TYPE_STUB_DECL (gnu_type)
2415 = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
2416 TYPE_ALIGN (gnu_type) = 0;
2417 TYPE_PACKED (gnu_type) = packed || has_rep;
2419 if (!definition)
2420 defer_incomplete_level++, this_deferred = true;
2422 /* If both a size and rep clause was specified, put the size in
2423 the record type now so that it can get the proper mode. */
2424 if (has_rep && Known_Esize (gnat_entity))
2425 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2427 /* Always set the alignment here so that it can be used to
2428 set the mode, if it is making the alignment stricter. If
2429 it is invalid, it will be checked again below. If this is to
2430 be Atomic, choose a default alignment of a word unless we know
2431 the size and it's smaller. */
2432 if (Known_Alignment (gnat_entity))
2433 TYPE_ALIGN (gnu_type)
2434 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2435 else if (Is_Atomic (gnat_entity))
2436 TYPE_ALIGN (gnu_type)
2437 = (esize >= BITS_PER_WORD ? BITS_PER_WORD
2438 : 1 << (floor_log2 (esize - 1) + 1));
2440 /* If we have a Parent_Subtype, make a field for the parent. If
2441 this record has rep clauses, force the position to zero. */
2442 if (Present (Parent_Subtype (gnat_entity)))
2444 Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
2445 tree gnu_parent;
2447 /* A major complexity here is that the parent subtype will
2448 reference our discriminants in its Discriminant_Constraint
2449 list. But those must reference the parent component of this
2450 record which is of the parent subtype we have not built yet!
2451 To break the circle we first build a dummy COMPONENT_REF which
2452 represents the "get to the parent" operation and initialize
2453 each of those discriminants to a COMPONENT_REF of the above
2454 dummy parent referencing the corresponding discriminant of the
2455 base type of the parent subtype. */
2456 gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
2457 build0 (PLACEHOLDER_EXPR, gnu_type),
2458 build_decl (FIELD_DECL, NULL_TREE,
2459 NULL_TREE),
2460 NULL_TREE);
2462 if (Has_Discriminants (gnat_entity))
2463 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2464 Present (gnat_field);
2465 gnat_field = Next_Stored_Discriminant (gnat_field))
2466 if (Present (Corresponding_Discriminant (gnat_field)))
2467 save_gnu_tree
2468 (gnat_field,
2469 build3 (COMPONENT_REF,
2470 get_unpadded_type (Etype (gnat_field)),
2471 gnu_get_parent,
2472 gnat_to_gnu_field_decl (Corresponding_Discriminant
2473 (gnat_field)),
2474 NULL_TREE),
2475 true);
2477 /* Then we build the parent subtype. */
2478 gnu_parent = gnat_to_gnu_type (gnat_parent);
2480 /* Finally we fix up both kinds of twisted COMPONENT_REF we have
2481 initially built. The discriminants must reference the fields
2482 of the parent subtype and not those of its base type for the
2483 placeholder machinery to properly work. */
2484 if (Has_Discriminants (gnat_entity))
2485 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2486 Present (gnat_field);
2487 gnat_field = Next_Stored_Discriminant (gnat_field))
2488 if (Present (Corresponding_Discriminant (gnat_field)))
2490 Entity_Id field = Empty;
2491 for (field = First_Stored_Discriminant (gnat_parent);
2492 Present (field);
2493 field = Next_Stored_Discriminant (field))
2494 if (same_discriminant_p (gnat_field, field))
2495 break;
2496 gcc_assert (Present (field));
2497 TREE_OPERAND (get_gnu_tree (gnat_field), 1)
2498 = gnat_to_gnu_field_decl (field);
2501 /* The "get to the parent" COMPONENT_REF must be given its
2502 proper type... */
2503 TREE_TYPE (gnu_get_parent) = gnu_parent;
2505 /* ...and reference the _parent field of this record. */
2506 gnu_field_list
2507 = create_field_decl (get_identifier
2508 (Get_Name_String (Name_uParent)),
2509 gnu_parent, gnu_type, 0,
2510 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2511 has_rep ? bitsize_zero_node : 0, 1);
2512 DECL_INTERNAL_P (gnu_field_list) = 1;
2513 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2516 /* Make the fields for the discriminants and put them into the record
2517 unless it's an Unchecked_Union. */
2518 if (Has_Discriminants (gnat_entity))
2519 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2520 Present (gnat_field);
2521 gnat_field = Next_Stored_Discriminant (gnat_field))
2523 /* If this is a record extension and this discriminant
2524 is the renaming of another discriminant, we've already
2525 handled the discriminant above. */
2526 if (Present (Parent_Subtype (gnat_entity))
2527 && Present (Corresponding_Discriminant (gnat_field)))
2528 continue;
2530 gnu_field
2531 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2533 /* Make an expression using a PLACEHOLDER_EXPR from the
2534 FIELD_DECL node just created and link that with the
2535 corresponding GNAT defining identifier. Then add to the
2536 list of fields. */
2537 save_gnu_tree (gnat_field,
2538 build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
2539 build0 (PLACEHOLDER_EXPR,
2540 DECL_CONTEXT (gnu_field)),
2541 gnu_field, NULL_TREE),
2542 true);
2544 if (!Is_Unchecked_Union (gnat_entity))
2546 TREE_CHAIN (gnu_field) = gnu_field_list;
2547 gnu_field_list = gnu_field;
2551 /* Put the discriminants into the record (backwards), so we can
2552 know the appropriate discriminant to use for the names of the
2553 variants. */
2554 TYPE_FIELDS (gnu_type) = gnu_field_list;
2556 /* Add the listed fields into the record and finish up. */
2557 components_to_record (gnu_type, Component_List (record_definition),
2558 gnu_field_list, packed, definition, NULL,
2559 false, all_rep, this_deferred,
2560 Is_Unchecked_Union (gnat_entity));
2562 if (this_deferred)
2564 debug_deferred = true;
2565 defer_debug_level++;
2567 defer_debug_incomplete_list
2568 = tree_cons (NULL_TREE, gnu_type,
2569 defer_debug_incomplete_list);
2572 /* We used to remove the associations of the discriminants and
2573 _Parent for validity checking, but we may need them if there's
2574 Freeze_Node for a subtype used in this record. */
2576 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2577 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2579 /* If it is a tagged record force the type to BLKmode to insure
2580 that these objects will always be placed in memory. Do the
2581 same thing for limited record types. */
2582 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2583 TYPE_MODE (gnu_type) = BLKmode;
2585 /* If this is a derived type, we must make the alias set of this type
2586 the same as that of the type we are derived from. We assume here
2587 that the other type is already frozen. */
2588 if (Etype (gnat_entity) != gnat_entity
2589 && !(Is_Private_Type (Etype (gnat_entity))
2590 && Full_View (Etype (gnat_entity)) == gnat_entity))
2591 copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
2593 /* Fill in locations of fields. */
2594 annotate_rep (gnat_entity, gnu_type);
2596 /* If there are any entities in the chain corresponding to
2597 components that we did not elaborate, ensure we elaborate their
2598 types if they are Itypes. */
2599 for (gnat_temp = First_Entity (gnat_entity);
2600 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2601 if ((Ekind (gnat_temp) == E_Component
2602 || Ekind (gnat_temp) == E_Discriminant)
2603 && Is_Itype (Etype (gnat_temp))
2604 && !present_gnu_tree (gnat_temp))
2605 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2607 break;
2609 case E_Class_Wide_Subtype:
2610 /* If an equivalent type is present, that is what we should use.
2611 Otherwise, fall through to handle this like a record subtype
2612 since it may have constraints. */
2614 if (Present (Equivalent_Type (gnat_entity)))
2616 gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
2617 NULL_TREE, 0);
2618 maybe_present = true;
2619 break;
2622 /* ... fall through ... */
2624 case E_Record_Subtype:
2626 /* If Cloned_Subtype is Present it means this record subtype has
2627 identical layout to that type or subtype and we should use
2628 that GCC type for this one. The front end guarantees that
2629 the component list is shared. */
2630 if (Present (Cloned_Subtype (gnat_entity)))
2632 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2633 NULL_TREE, 0);
2634 maybe_present = true;
2637 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2638 changing the type, make a new type with each field having the
2639 type of the field in the new subtype but having the position
2640 computed by transforming every discriminant reference according
2641 to the constraints. We don't see any difference between
2642 private and nonprivate type here since derivations from types should
2643 have been deferred until the completion of the private type. */
2644 else
2646 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2647 tree gnu_base_type;
2648 tree gnu_orig_type;
2650 if (!definition)
2651 defer_incomplete_level++, this_deferred = true;
2653 /* Get the base type initially for its alignment and sizes. But
2654 if it is a padded type, we do all the other work with the
2655 unpadded type. */
2656 gnu_type = gnu_orig_type = gnu_base_type
2657 = gnat_to_gnu_type (gnat_base_type);
2659 if (TREE_CODE (gnu_type) == RECORD_TYPE
2660 && TYPE_IS_PADDING_P (gnu_type))
2661 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2663 if (present_gnu_tree (gnat_entity))
2665 maybe_present = true;
2666 break;
2669 /* When the type has discriminants, and these discriminants
2670 affect the shape of what it built, factor them in.
2672 If we are making a subtype of an Unchecked_Union (must be an
2673 Itype), just return the type.
2675 We can't just use Is_Constrained because private subtypes without
2676 discriminants of full types with discriminants with default
2677 expressions are Is_Constrained but aren't constrained! */
2679 if (IN (Ekind (gnat_base_type), Record_Kind)
2680 && !Is_For_Access_Subtype (gnat_entity)
2681 && !Is_Unchecked_Union (gnat_base_type)
2682 && Is_Constrained (gnat_entity)
2683 && Stored_Constraint (gnat_entity) != No_Elist
2684 && Present (Discriminant_Constraint (gnat_entity)))
2686 Entity_Id gnat_field;
2687 tree gnu_field_list = 0;
2688 tree gnu_pos_list
2689 = compute_field_positions (gnu_orig_type, NULL_TREE,
2690 size_zero_node, bitsize_zero_node,
2691 BIGGEST_ALIGNMENT);
2692 tree gnu_subst_list
2693 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2694 definition);
2695 tree gnu_temp;
2697 gnu_type = make_node (RECORD_TYPE);
2698 TYPE_NAME (gnu_type) = gnu_entity_id;
2699 TYPE_STUB_DECL (gnu_type)
2700 = create_type_decl (NULL_TREE, gnu_type, NULL, false, false,
2701 gnat_entity);
2702 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2704 for (gnat_field = First_Entity (gnat_entity);
2705 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2706 if ((Ekind (gnat_field) == E_Component
2707 || Ekind (gnat_field) == E_Discriminant)
2708 && (Underlying_Type (Scope (Original_Record_Component
2709 (gnat_field)))
2710 == gnat_base_type)
2711 && (No (Corresponding_Discriminant (gnat_field))
2712 || !Is_Tagged_Type (gnat_base_type)))
2714 tree gnu_old_field
2715 = gnat_to_gnu_field_decl (Original_Record_Component
2716 (gnat_field));
2717 tree gnu_offset
2718 = TREE_VALUE (purpose_member (gnu_old_field,
2719 gnu_pos_list));
2720 tree gnu_pos = TREE_PURPOSE (gnu_offset);
2721 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
2722 tree gnu_field_type
2723 = gnat_to_gnu_type (Etype (gnat_field));
2724 tree gnu_size = TYPE_SIZE (gnu_field_type);
2725 tree gnu_new_pos = 0;
2726 unsigned int offset_align
2727 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
2729 tree gnu_field;
2731 /* If there was a component clause, the field types must be
2732 the same for the type and subtype, so copy the data from
2733 the old field to avoid recomputation here. Also if the
2734 field is justified modular and the optimization in
2735 gnat_to_gnu_field was applied. */
2736 if (Present (Component_Clause
2737 (Original_Record_Component (gnat_field)))
2738 || (TREE_CODE (gnu_field_type) == RECORD_TYPE
2739 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
2740 && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
2741 == TREE_TYPE (gnu_old_field)))
2743 gnu_size = DECL_SIZE (gnu_old_field);
2744 gnu_field_type = TREE_TYPE (gnu_old_field);
2747 /* If this was a bitfield, get the size from the old field.
2748 Also ensure the type can be placed into a bitfield. */
2749 else if (DECL_BIT_FIELD (gnu_old_field))
2751 gnu_size = DECL_SIZE (gnu_old_field);
2752 if (TYPE_MODE (gnu_field_type) == BLKmode
2753 && TREE_CODE (gnu_field_type) == RECORD_TYPE
2754 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
2755 gnu_field_type = make_packable_type (gnu_field_type);
2758 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
2759 for (gnu_temp = gnu_subst_list;
2760 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2761 gnu_pos = substitute_in_expr (gnu_pos,
2762 TREE_PURPOSE (gnu_temp),
2763 TREE_VALUE (gnu_temp));
2765 /* If the size is now a constant, we can set it as the
2766 size of the field when we make it. Otherwise, we need
2767 to deal with it specially. */
2768 if (TREE_CONSTANT (gnu_pos))
2769 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
2771 gnu_field
2772 = create_field_decl
2773 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
2774 0, gnu_size, gnu_new_pos,
2775 !DECL_NONADDRESSABLE_P (gnu_old_field));
2777 if (!TREE_CONSTANT (gnu_pos))
2779 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
2780 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
2781 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
2782 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
2783 DECL_SIZE (gnu_field) = gnu_size;
2784 DECL_SIZE_UNIT (gnu_field)
2785 = convert (sizetype,
2786 size_binop (CEIL_DIV_EXPR, gnu_size,
2787 bitsize_unit_node));
2788 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
2791 DECL_INTERNAL_P (gnu_field)
2792 = DECL_INTERNAL_P (gnu_old_field);
2793 SET_DECL_ORIGINAL_FIELD
2794 (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
2795 ? DECL_ORIGINAL_FIELD (gnu_old_field)
2796 : gnu_old_field));
2797 DECL_DISCRIMINANT_NUMBER (gnu_field)
2798 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
2799 TREE_THIS_VOLATILE (gnu_field)
2800 = TREE_THIS_VOLATILE (gnu_old_field);
2801 TREE_CHAIN (gnu_field) = gnu_field_list;
2802 gnu_field_list = gnu_field;
2803 save_gnu_tree (gnat_field, gnu_field, false);
2806 /* Now go through the entities again looking for Itypes that
2807 we have not elaborated but should (e.g., Etypes of fields
2808 that have Original_Components). */
2809 for (gnat_field = First_Entity (gnat_entity);
2810 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2811 if ((Ekind (gnat_field) == E_Discriminant
2812 || Ekind (gnat_field) == E_Component)
2813 && !present_gnu_tree (Etype (gnat_field)))
2814 gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
2816 finish_record_type (gnu_type, nreverse (gnu_field_list),
2817 true, false);
2819 /* Now set the size, alignment and alias set of the new type to
2820 match that of the old one, doing any substitutions, as
2821 above. */
2822 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2823 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2824 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2825 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2826 copy_alias_set (gnu_type, gnu_base_type);
2828 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2829 for (gnu_temp = gnu_subst_list;
2830 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2831 TYPE_SIZE (gnu_type)
2832 = substitute_in_expr (TYPE_SIZE (gnu_type),
2833 TREE_PURPOSE (gnu_temp),
2834 TREE_VALUE (gnu_temp));
2836 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2837 for (gnu_temp = gnu_subst_list;
2838 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2839 TYPE_SIZE_UNIT (gnu_type)
2840 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2841 TREE_PURPOSE (gnu_temp),
2842 TREE_VALUE (gnu_temp));
2844 if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2845 for (gnu_temp = gnu_subst_list;
2846 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2847 SET_TYPE_ADA_SIZE
2848 (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2849 TREE_PURPOSE (gnu_temp),
2850 TREE_VALUE (gnu_temp)));
2852 /* Recompute the mode of this record type now that we know its
2853 actual size. */
2854 compute_record_mode (gnu_type);
2856 /* Fill in locations of fields. */
2857 annotate_rep (gnat_entity, gnu_type);
2860 /* If we've made a new type, record it and make an XVS type to show
2861 what this is a subtype of. Some debuggers require the XVS
2862 type to be output first, so do it in that order. */
2863 if (gnu_type != gnu_orig_type)
2865 if (debug_info_p)
2867 tree gnu_subtype_marker = make_node (RECORD_TYPE);
2868 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
2870 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
2871 gnu_orig_name = DECL_NAME (gnu_orig_name);
2873 TYPE_NAME (gnu_subtype_marker)
2874 = create_concat_name (gnat_entity, "XVS");
2875 finish_record_type (gnu_subtype_marker,
2876 create_field_decl (gnu_orig_name,
2877 integer_type_node,
2878 gnu_subtype_marker,
2879 0, NULL_TREE,
2880 NULL_TREE, 0),
2881 false, false);
2884 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2885 TYPE_NAME (gnu_type) = gnu_entity_id;
2886 TYPE_STUB_DECL (gnu_type)
2887 = create_type_decl (TYPE_NAME (gnu_type), gnu_type,
2888 NULL, true, debug_info_p, gnat_entity);
2891 /* Otherwise, go down all the components in the new type and
2892 make them equivalent to those in the base type. */
2893 else
2894 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
2895 gnat_temp = Next_Entity (gnat_temp))
2896 if ((Ekind (gnat_temp) == E_Discriminant
2897 && !Is_Unchecked_Union (gnat_base_type))
2898 || Ekind (gnat_temp) == E_Component)
2899 save_gnu_tree (gnat_temp,
2900 gnat_to_gnu_field_decl
2901 (Original_Record_Component (gnat_temp)), false);
2903 break;
2905 case E_Access_Subprogram_Type:
2906 case E_Anonymous_Access_Subprogram_Type:
2907 /* If we are not defining this entity, and we have incomplete
2908 entities being processed above us, make a dummy type and
2909 fill it in later. */
2910 if (!definition && defer_incomplete_level != 0)
2912 struct incomplete *p
2913 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
2915 gnu_type
2916 = build_pointer_type
2917 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
2918 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2919 !Comes_From_Source (gnat_entity),
2920 debug_info_p, gnat_entity);
2921 save_gnu_tree (gnat_entity, gnu_decl, false);
2922 this_made_decl = saved = true;
2924 p->old_type = TREE_TYPE (gnu_type);
2925 p->full_type = Directly_Designated_Type (gnat_entity);
2926 p->next = defer_incomplete_list;
2927 defer_incomplete_list = p;
2928 break;
2931 /* ... fall through ... */
2933 case E_Allocator_Type:
2934 case E_Access_Type:
2935 case E_Access_Attribute_Type:
2936 case E_Anonymous_Access_Type:
2937 case E_General_Access_Type:
2939 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
2940 /* Get the "full view" of this entity. If this is an incomplete
2941 entity from a limited with, treat its non-limited view as the
2942 full view. Otherwise, if this is an incomplete or private
2943 type, use the full view. */
2944 Entity_Id gnat_desig_full
2945 = (IN (Ekind (gnat_desig_type), Incomplete_Kind)
2946 && From_With_Type (gnat_desig_type))
2947 ? Non_Limited_View (gnat_desig_type)
2948 : IN (Ekind (gnat_desig_type), Incomplete_Or_Private_Kind)
2949 ? Full_View (gnat_desig_type)
2950 : Empty;
2951 /* We want to know if we'll be seeing the freeze node for any
2952 incomplete type we may be pointing to. */
2953 bool in_main_unit
2954 = (Present (gnat_desig_full)
2955 ? In_Extended_Main_Code_Unit (gnat_desig_full)
2956 : In_Extended_Main_Code_Unit (gnat_desig_type));
2957 bool got_fat_p = false;
2958 bool made_dummy = false;
2959 tree gnu_desig_type = NULL_TREE;
2960 enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
2962 if (!targetm.valid_pointer_mode (p_mode))
2963 p_mode = ptr_mode;
2965 if (No (gnat_desig_full)
2966 && (Ekind (gnat_desig_type) == E_Class_Wide_Type
2967 || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype
2968 && Present (Equivalent_Type (gnat_desig_type)))))
2970 if (Present (Equivalent_Type (gnat_desig_type)))
2972 gnat_desig_full = Equivalent_Type (gnat_desig_type);
2973 if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind))
2974 gnat_desig_full = Full_View (gnat_desig_full);
2976 else if (IN (Ekind (Root_Type (gnat_desig_type)),
2977 Incomplete_Or_Private_Kind))
2978 gnat_desig_full = Full_View (Root_Type (gnat_desig_type));
2981 if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full))
2982 gnat_desig_full = Corresponding_Record_Type (gnat_desig_full);
2984 /* If either the designated type or its full view is an
2985 unconstrained array subtype, replace it with the type it's a
2986 subtype of. This avoids problems with multiple copies of
2987 unconstrained array types. */
2988 if (Ekind (gnat_desig_type) == E_Array_Subtype
2989 && !Is_Constrained (gnat_desig_type))
2990 gnat_desig_type = Etype (gnat_desig_type);
2991 if (Present (gnat_desig_full)
2992 && Ekind (gnat_desig_full) == E_Array_Subtype
2993 && !Is_Constrained (gnat_desig_full))
2994 gnat_desig_full = Etype (gnat_desig_full);
2996 /* If the designated type is a subtype of an incomplete record type,
2997 use the parent type to avoid order of elaboration issues. This
2998 can lose some code efficiency, but there is no alternative. */
2999 if (Present (gnat_desig_full)
3000 && Ekind (gnat_desig_full) == E_Record_Subtype
3001 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)
3002 gnat_desig_full = Etype (gnat_desig_full);
3004 /* If we are pointing to an incomplete type whose completion is an
3005 unconstrained array, make a fat pointer type instead of a pointer
3006 to VOID. The two types in our fields will be pointers to VOID and
3007 will be replaced in update_pointer_to. Similarly, if the type
3008 itself is a dummy type or an unconstrained array. Also make
3009 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
3010 pointers to it. */
3012 if ((Present (gnat_desig_full)
3013 && Is_Array_Type (gnat_desig_full)
3014 && !Is_Constrained (gnat_desig_full))
3015 || (present_gnu_tree (gnat_desig_type)
3016 && TYPE_IS_DUMMY_P (TREE_TYPE
3017 (get_gnu_tree (gnat_desig_type)))
3018 && Is_Array_Type (gnat_desig_type)
3019 && !Is_Constrained (gnat_desig_type))
3020 || (present_gnu_tree (gnat_desig_type)
3021 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type)))
3022 == UNCONSTRAINED_ARRAY_TYPE)
3023 && !(TYPE_POINTER_TO (TREE_TYPE
3024 (get_gnu_tree (gnat_desig_type)))))
3025 || (No (gnat_desig_full) && !in_main_unit
3026 && defer_incomplete_level
3027 && !present_gnu_tree (gnat_desig_type)
3028 && Is_Array_Type (gnat_desig_type)
3029 && ! Is_Constrained (gnat_desig_type))
3030 || (in_main_unit && From_With_Type (gnat_entity)
3031 && (Present (gnat_desig_full)
3032 ? Present (Freeze_Node (gnat_desig_full))
3033 : Present (Freeze_Node (gnat_desig_type)))
3034 && Is_Array_Type (gnat_desig_type)
3035 && !Is_Constrained (gnat_desig_type)))
3037 tree gnu_old
3038 = (present_gnu_tree (gnat_desig_type)
3039 ? gnat_to_gnu_type (gnat_desig_type)
3040 : make_dummy_type (gnat_desig_type));
3041 tree fields;
3043 /* Show the dummy we get will be a fat pointer. */
3044 got_fat_p = made_dummy = true;
3046 /* If the call above got something that has a pointer, that
3047 pointer is our type. This could have happened either
3048 because the type was elaborated or because somebody
3049 else executed the code below. */
3050 gnu_type = TYPE_POINTER_TO (gnu_old);
3051 if (!gnu_type)
3053 gnu_type = make_node (RECORD_TYPE);
3054 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
3055 TYPE_POINTER_TO (gnu_old) = gnu_type;
3057 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3058 fields
3059 = chainon (chainon (NULL_TREE,
3060 create_field_decl
3061 (get_identifier ("P_ARRAY"),
3062 ptr_void_type_node, gnu_type,
3063 0, 0, 0, 0)),
3064 create_field_decl (get_identifier ("P_BOUNDS"),
3065 ptr_void_type_node,
3066 gnu_type, 0, 0, 0, 0));
3068 /* Make sure we can place this into a register. */
3069 TYPE_ALIGN (gnu_type)
3070 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
3071 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
3072 finish_record_type (gnu_type, fields, false, true);
3074 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
3075 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
3076 = concat_id_with_name (get_entity_name (gnat_desig_type),
3077 "XUT");
3078 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
3082 /* If we already know what the full type is, use it. */
3083 else if (Present (gnat_desig_full)
3084 && present_gnu_tree (gnat_desig_full))
3085 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
3087 /* Get the type of the thing we are to point to and build a pointer
3088 to it. If it is a reference to an incomplete or private type with a
3089 full view that is a record, make a dummy type node and get the
3090 actual type later when we have verified it is safe. */
3091 else if (!in_main_unit
3092 && !present_gnu_tree (gnat_desig_type)
3093 && Present (gnat_desig_full)
3094 && !present_gnu_tree (gnat_desig_full)
3095 && Is_Record_Type (gnat_desig_full))
3097 gnu_desig_type = make_dummy_type (gnat_desig_type);
3098 made_dummy = true;
3101 /* Likewise if we are pointing to a record or array and we are to defer
3102 elaborating incomplete types. We do this since this access type
3103 may be the full view of some private type. Note that the
3104 unconstrained array case is handled above. */
3105 else if ((!in_main_unit || imported_p) && defer_incomplete_level != 0
3106 && !present_gnu_tree (gnat_desig_type)
3107 && ((Is_Record_Type (gnat_desig_type)
3108 || Is_Array_Type (gnat_desig_type))
3109 || (Present (gnat_desig_full)
3110 && (Is_Record_Type (gnat_desig_full)
3111 || Is_Array_Type (gnat_desig_full)))))
3113 gnu_desig_type = make_dummy_type (gnat_desig_type);
3114 made_dummy = true;
3117 /* If this is a reference from a limited_with type back to our
3118 main unit and there's a Freeze_Node for it, either we have
3119 already processed the declaration and made the dummy type,
3120 in which case we just reuse the latter, or we have not yet,
3121 in which case we make the dummy type and it will be reused
3122 when the declaration is processed. In both cases, the pointer
3123 eventually created below will be automatically adjusted when
3124 the Freeze_Node is processed. Note that the unconstrained
3125 array case is handled above. */
3126 else if (in_main_unit && From_With_Type (gnat_entity)
3127 && (Present (gnat_desig_full)
3128 ? Present (Freeze_Node (gnat_desig_full))
3129 : Present (Freeze_Node (gnat_desig_type))))
3131 gnu_desig_type = make_dummy_type (gnat_desig_type);
3132 made_dummy = true;
3135 else if (gnat_desig_type == gnat_entity)
3137 gnu_type
3138 = build_pointer_type_for_mode (make_node (VOID_TYPE),
3139 p_mode,
3140 No_Strict_Aliasing (gnat_entity));
3141 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
3144 else
3145 gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
3147 /* It is possible that the above call to gnat_to_gnu_type resolved our
3148 type. If so, just return it. */
3149 if (present_gnu_tree (gnat_entity))
3151 maybe_present = true;
3152 break;
3155 /* If we have a GCC type for the designated type, possibly modify it
3156 if we are pointing only to constant objects and then make a pointer
3157 to it. Don't do this for unconstrained arrays. */
3158 if (!gnu_type && gnu_desig_type)
3160 if (Is_Access_Constant (gnat_entity)
3161 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
3163 gnu_desig_type
3164 = build_qualified_type
3165 (gnu_desig_type,
3166 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
3168 /* Some extra processing is required if we are building a
3169 pointer to an incomplete type (in the GCC sense). We might
3170 have such a type if we just made a dummy, or directly out
3171 of the call to gnat_to_gnu_type above if we are processing
3172 an access type for a record component designating the
3173 record type itself. */
3174 if (TYPE_MODE (gnu_desig_type) == VOIDmode)
3176 /* We must ensure that the pointer to variant we make will
3177 be processed by update_pointer_to when the initial type
3178 is completed. Pretend we made a dummy and let further
3179 processing act as usual. */
3180 made_dummy = true;
3182 /* We must ensure that update_pointer_to will not retrieve
3183 the dummy variant when building a properly qualified
3184 version of the complete type. We take advantage of the
3185 fact that get_qualified_type is requiring TYPE_NAMEs to
3186 match to influence build_qualified_type and then also
3187 update_pointer_to here. */
3188 TYPE_NAME (gnu_desig_type)
3189 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
3193 gnu_type
3194 = build_pointer_type_for_mode (gnu_desig_type, p_mode,
3195 No_Strict_Aliasing (gnat_entity));
3198 /* If we are not defining this object and we made a dummy pointer,
3199 save our current definition, evaluate the actual type, and replace
3200 the tentative type we made with the actual one. If we are to defer
3201 actually looking up the actual type, make an entry in the
3202 deferred list. */
3204 if (!in_main_unit && made_dummy)
3206 tree gnu_old_type
3207 = TYPE_FAT_POINTER_P (gnu_type)
3208 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
3210 if (esize == POINTER_SIZE
3211 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
3212 gnu_type
3213 = build_pointer_type
3214 (TYPE_OBJECT_RECORD_TYPE
3215 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3217 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3218 !Comes_From_Source (gnat_entity),
3219 debug_info_p, gnat_entity);
3220 save_gnu_tree (gnat_entity, gnu_decl, false);
3221 this_made_decl = saved = true;
3223 if (defer_incomplete_level == 0)
3224 /* Note that the call to gnat_to_gnu_type here might have
3225 updated gnu_old_type directly, in which case it is not a
3226 dummy type any more when we get into update_pointer_to.
3228 This may happen for instance when the designated type is a
3229 record type, because their elaboration starts with an
3230 initial node from make_dummy_type, which may yield the same
3231 node as the one we got.
3233 Besides, variants of this non-dummy type might have been
3234 created along the way. update_pointer_to is expected to
3235 properly take care of those situations. */
3236 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3237 gnat_to_gnu_type (gnat_desig_type));
3238 else
3240 struct incomplete *p
3241 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3243 p->old_type = gnu_old_type;
3244 p->full_type = gnat_desig_type;
3245 p->next = defer_incomplete_list;
3246 defer_incomplete_list = p;
3250 break;
3252 case E_Access_Protected_Subprogram_Type:
3253 case E_Anonymous_Access_Protected_Subprogram_Type:
3254 if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
3255 gnu_type = build_pointer_type (void_type_node);
3256 else
3258 /* The runtime representation is the equivalent type. */
3259 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3260 maybe_present = 1;
3263 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3264 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3265 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3266 && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3267 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3268 NULL_TREE, 0);
3270 break;
3272 case E_Access_Subtype:
3274 /* We treat this as identical to its base type; any constraint is
3275 meaningful only to the front end.
3277 The designated type must be elaborated as well, if it does
3278 not have its own freeze node. Designated (sub)types created
3279 for constrained components of records with discriminants are
3280 not frozen by the front end and thus not elaborated by gigi,
3281 because their use may appear before the base type is frozen,
3282 and because it is not clear that they are needed anywhere in
3283 Gigi. With the current model, there is no correct place where
3284 they could be elaborated. */
3286 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3287 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3288 && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
3289 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3290 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3292 /* If we are not defining this entity, and we have incomplete
3293 entities being processed above us, make a dummy type and
3294 elaborate it later. */
3295 if (!definition && defer_incomplete_level != 0)
3297 struct incomplete *p
3298 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3299 tree gnu_ptr_type
3300 = build_pointer_type
3301 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3303 p->old_type = TREE_TYPE (gnu_ptr_type);
3304 p->full_type = Directly_Designated_Type (gnat_entity);
3305 p->next = defer_incomplete_list;
3306 defer_incomplete_list = p;
3308 else if (IN (Ekind (Base_Type
3309 (Directly_Designated_Type (gnat_entity))),
3310 Incomplete_Or_Private_Kind))
3312 else
3313 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3314 NULL_TREE, 0);
3317 maybe_present = true;
3318 break;
3320 /* Subprogram Entities
3322 The following access functions are defined for subprograms (functions
3323 or procedures):
3325 First_Formal The first formal parameter.
3326 Is_Imported Indicates that the subprogram has appeared in
3327 an INTERFACE or IMPORT pragma. For now we
3328 assume that the external language is C.
3329 Is_Inlined True if the subprogram is to be inlined.
3331 In addition for function subprograms we have:
3333 Etype Return type of the function.
3335 Each parameter is first checked by calling must_pass_by_ref on its
3336 type to determine if it is passed by reference. For parameters which
3337 are copied in, if they are Ada IN OUT or OUT parameters, their return
3338 value becomes part of a record which becomes the return type of the
3339 function (C function - note that this applies only to Ada procedures
3340 so there is no Ada return type). Additional code to store back the
3341 parameters will be generated on the caller side. This transformation
3342 is done here, not in the front-end.
3344 The intended result of the transformation can be seen from the
3345 equivalent source rewritings that follow:
3347 struct temp {int a,b};
3348 procedure P (A,B: IN OUT ...) is temp P (int A,B) {
3349 .. ..
3350 end P; return {A,B};
3352 procedure call
3355 temp t;
3356 P(X,Y); t = P(X,Y);
3357 X = t.a , Y = t.b;
3360 For subprogram types we need to perform mainly the same conversions to
3361 GCC form that are needed for procedures and function declarations. The
3362 only difference is that at the end, we make a type declaration instead
3363 of a function declaration. */
3365 case E_Subprogram_Type:
3366 case E_Function:
3367 case E_Procedure:
3369 /* The first GCC parameter declaration (a PARM_DECL node). The
3370 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3371 actually is the head of this parameter list. */
3372 tree gnu_param_list = NULL_TREE;
3373 /* The type returned by a function. If the subprogram is a procedure
3374 this type should be void_type_node. */
3375 tree gnu_return_type = void_type_node;
3376 /* List of fields in return type of procedure with copy in copy out
3377 parameters. */
3378 tree gnu_field_list = NULL_TREE;
3379 /* Non-null for subprograms containing parameters passed by copy in
3380 copy out (Ada IN OUT or OUT parameters not passed by reference),
3381 in which case it is the list of nodes used to specify the values of
3382 the in out/out parameters that are returned as a record upon
3383 procedure return. The TREE_PURPOSE of an element of this list is
3384 a field of the record and the TREE_VALUE is the PARM_DECL
3385 corresponding to that field. This list will be saved in the
3386 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3387 tree gnu_return_list = NULL_TREE;
3388 /* If an import pragma asks to map this subprogram to a GCC builtin,
3389 this is the builtin DECL node. */
3390 tree gnu_builtin_decl = NULL_TREE;
3391 Entity_Id gnat_param;
3392 bool inline_flag = Is_Inlined (gnat_entity);
3393 bool public_flag = Is_Public (gnat_entity);
3394 bool extern_flag
3395 = (Is_Public (gnat_entity) && !definition) || imported_p;
3396 bool pure_flag = Is_Pure (gnat_entity);
3397 bool volatile_flag = No_Return (gnat_entity);
3398 bool returns_by_ref = false;
3399 bool returns_unconstrained = false;
3400 bool returns_by_target_ptr = false;
3401 tree gnu_ext_name = create_concat_name (gnat_entity, 0);
3402 bool has_copy_in_out = false;
3403 int parmnum;
3405 if (kind == E_Subprogram_Type && !definition)
3406 /* A parameter may refer to this type, so defer completion
3407 of any incomplete types. */
3408 defer_incomplete_level++, this_deferred = true;
3410 /* If the subprogram has an alias, it is probably inherited, so
3411 we can use the original one. If the original "subprogram"
3412 is actually an enumeration literal, it may be the first use
3413 of its type, so we must elaborate that type now. */
3414 if (Present (Alias (gnat_entity)))
3416 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3417 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3419 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3420 gnu_expr, 0);
3422 /* Elaborate any Itypes in the parameters of this entity. */
3423 for (gnat_temp = First_Formal_With_Extras (gnat_entity);
3424 Present (gnat_temp);
3425 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3426 if (Is_Itype (Etype (gnat_temp)))
3427 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3429 break;
3432 /* If this subprogram is expectedly bound to a GCC builtin, fetch the
3433 corresponding DECL node.
3435 We still want the parameter associations to take place because the
3436 proper generation of calls depends on it (a GNAT parameter without
3437 a corresponding GCC tree has a very specific meaning), so we don't
3438 just break here. */
3439 if (Convention (gnat_entity) == Convention_Intrinsic)
3440 gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
3442 /* ??? What if we don't find the builtin node above ? warn ? err ?
3443 In the current state we neither warn nor err, and calls will just
3444 be handled as for regular subprograms. */
3446 if (kind == E_Function || kind == E_Subprogram_Type)
3447 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3449 /* If this function returns by reference, make the actual
3450 return type of this function the pointer and mark the decl. */
3451 if (Returns_By_Ref (gnat_entity))
3453 returns_by_ref = true;
3454 gnu_return_type = build_pointer_type (gnu_return_type);
3457 /* If the Mechanism is By_Reference, ensure the return type uses
3458 the machine's by-reference mechanism, which may not the same
3459 as above (e.g., it might be by passing a fake parameter). */
3460 else if (kind == E_Function
3461 && Mechanism (gnat_entity) == By_Reference)
3463 TREE_ADDRESSABLE (gnu_return_type) = 1;
3465 /* We expect this bit to be reset by gigi shortly, so can avoid a
3466 type node copy here. This actually also prevents troubles with
3467 the generation of debug information for the function, because
3468 we might have issued such info for this type already, and would
3469 be attaching a distinct type node to the function if we made a
3470 copy here. */
3473 /* If we are supposed to return an unconstrained array,
3474 actually return a fat pointer and make a note of that. Return
3475 a pointer to an unconstrained record of variable size. */
3476 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3478 gnu_return_type = TREE_TYPE (gnu_return_type);
3479 returns_unconstrained = true;
3482 /* If the type requires a transient scope, the result is allocated
3483 on the secondary stack, so the result type of the function is
3484 just a pointer. */
3485 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3487 gnu_return_type = build_pointer_type (gnu_return_type);
3488 returns_unconstrained = true;
3491 /* If the type is a padded type and the underlying type would not
3492 be passed by reference or this function has a foreign convention,
3493 return the underlying type. */
3494 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3495 && TYPE_IS_PADDING_P (gnu_return_type)
3496 && (!default_pass_by_ref (TREE_TYPE
3497 (TYPE_FIELDS (gnu_return_type)))
3498 || Has_Foreign_Convention (gnat_entity)))
3499 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3501 /* If the return type is unconstrained, that means it must have a
3502 maximum size. We convert the function into a procedure and its
3503 caller will pass a pointer to an object of that maximum size as the
3504 first parameter when we call the function. */
3505 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
3507 returns_by_target_ptr = true;
3508 gnu_param_list
3509 = create_param_decl (get_identifier ("TARGET"),
3510 build_reference_type (gnu_return_type),
3511 true);
3512 gnu_return_type = void_type_node;
3515 /* If the return type has a size that overflows, we cannot have
3516 a function that returns that type. This usage doesn't make
3517 sense anyway, so give an error here. */
3518 if (TYPE_SIZE_UNIT (gnu_return_type)
3519 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
3520 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3522 post_error ("cannot return type whose size overflows",
3523 gnat_entity);
3524 gnu_return_type = copy_node (gnu_return_type);
3525 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3526 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3527 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3528 TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
3531 /* Look at all our parameters and get the type of
3532 each. While doing this, build a copy-out structure if
3533 we need one. */
3535 for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
3536 Present (gnat_param);
3537 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3539 tree gnu_param_name = get_entity_name (gnat_param);
3540 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3541 tree gnu_param, gnu_field;
3542 bool by_ref_p = false;
3543 bool by_descr_p = false;
3544 bool by_component_ptr_p = false;
3545 bool copy_in_copy_out_flag = false;
3546 bool req_by_copy = false, req_by_ref = false;
3548 /* Builtins are expanded inline and there is no real call sequence
3549 involved. so the type expected by the underlying expander is
3550 always the type of each argument "as is". */
3551 if (gnu_builtin_decl)
3552 req_by_copy = 1;
3554 /* Otherwise, see if a Mechanism was supplied that forced this
3555 parameter to be passed one way or another. */
3556 else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3557 req_by_copy = true;
3558 else if (Mechanism (gnat_param) == Default)
3560 else if (Mechanism (gnat_param) == By_Copy)
3561 req_by_copy = true;
3562 else if (Mechanism (gnat_param) == By_Reference)
3563 req_by_ref = true;
3564 else if (Mechanism (gnat_param) <= By_Descriptor)
3565 by_descr_p = true;
3566 else if (Mechanism (gnat_param) > 0)
3568 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3569 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3570 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3571 Mechanism (gnat_param)))
3572 req_by_ref = true;
3573 else
3574 req_by_copy = true;
3576 else
3577 post_error ("unsupported mechanism for&", gnat_param);
3579 /* If this is either a foreign function or if the
3580 underlying type won't be passed by reference, strip off
3581 possible padding type. */
3582 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
3583 && TYPE_IS_PADDING_P (gnu_param_type)
3584 && (req_by_ref || Has_Foreign_Convention (gnat_entity)
3585 || (!must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
3586 (gnu_param_type)))
3587 && (req_by_copy
3588 || !default_pass_by_ref (TREE_TYPE
3589 (TYPE_FIELDS
3590 (gnu_param_type)))))))
3591 gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
3593 /* If this is an IN parameter it is read-only, so make a variant
3594 of the type that is read-only.
3596 ??? However, if this is an unconstrained array, that type can
3597 be very complex. So skip it for now. Likewise for any other
3598 self-referential type. */
3599 if (Ekind (gnat_param) == E_In_Parameter
3600 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
3601 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
3602 gnu_param_type
3603 = build_qualified_type (gnu_param_type,
3604 (TYPE_QUALS (gnu_param_type)
3605 | TYPE_QUAL_CONST));
3607 /* For foreign conventions, pass arrays as a pointer to the
3608 underlying type. First check for unconstrained array and get
3609 the underlying array. Then get the component type and build
3610 a pointer to it. */
3611 if (Has_Foreign_Convention (gnat_entity)
3612 && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
3613 gnu_param_type
3614 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3615 (TREE_TYPE (gnu_param_type))));
3617 if (by_descr_p)
3618 gnu_param_type
3619 = build_pointer_type
3620 (build_vms_descriptor (gnu_param_type,
3621 Mechanism (gnat_param), gnat_entity));
3623 else if (Has_Foreign_Convention (gnat_entity)
3624 && !req_by_copy
3625 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
3627 /* Strip off any multi-dimensional entries, then strip
3628 off the last array to get the component type. */
3629 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
3630 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
3631 gnu_param_type = TREE_TYPE (gnu_param_type);
3633 by_component_ptr_p = true;
3634 gnu_param_type = TREE_TYPE (gnu_param_type);
3636 if (Ekind (gnat_param) == E_In_Parameter)
3637 gnu_param_type
3638 = build_qualified_type (gnu_param_type,
3639 (TYPE_QUALS (gnu_param_type)
3640 | TYPE_QUAL_CONST));
3642 gnu_param_type = build_pointer_type (gnu_param_type);
3645 /* Fat pointers are passed as thin pointers for foreign
3646 conventions. */
3647 else if (Has_Foreign_Convention (gnat_entity)
3648 && TYPE_FAT_POINTER_P (gnu_param_type))
3649 gnu_param_type
3650 = make_type_from_size (gnu_param_type,
3651 size_int (POINTER_SIZE), false);
3653 /* If we must pass or were requested to pass by reference, do so.
3654 If we were requested to pass by copy, do so.
3655 Otherwise, for foreign conventions, pass all in out parameters
3656 or aggregates by reference. For COBOL and Fortran, pass
3657 all integer and FP types that way too. For Convention Ada,
3658 use the standard Ada default. */
3659 else if (must_pass_by_ref (gnu_param_type) || req_by_ref
3660 || (!req_by_copy
3661 && ((Has_Foreign_Convention (gnat_entity)
3662 && (Ekind (gnat_param) != E_In_Parameter
3663 || AGGREGATE_TYPE_P (gnu_param_type)))
3664 || (((Convention (gnat_entity)
3665 == Convention_Fortran)
3666 || (Convention (gnat_entity)
3667 == Convention_COBOL))
3668 && (INTEGRAL_TYPE_P (gnu_param_type)
3669 || FLOAT_TYPE_P (gnu_param_type)))
3670 /* For convention Ada, see if we pass by reference
3671 by default. */
3672 || (!Has_Foreign_Convention (gnat_entity)
3673 && default_pass_by_ref (gnu_param_type)))))
3675 gnu_param_type = build_reference_type (gnu_param_type);
3676 by_ref_p = true;
3679 else if (Ekind (gnat_param) != E_In_Parameter)
3680 copy_in_copy_out_flag = true;
3682 if (req_by_copy && (by_ref_p || by_component_ptr_p))
3683 post_error ("?cannot pass & by copy", gnat_param);
3685 /* If this is an OUT parameter that isn't passed by reference
3686 and isn't a pointer or aggregate, we don't make a PARM_DECL
3687 for it. Instead, it will be a VAR_DECL created when we process
3688 the procedure. For the special parameter of Valued_Procedure,
3689 never pass it in.
3691 An exception is made to cover the RM-6.4.1 rule requiring "by
3692 copy" out parameters with discriminants or implicit initial
3693 values to be handled like in out parameters. These type are
3694 normally built as aggregates, and hence passed by reference,
3695 except for some packed arrays which end up encoded in special
3696 integer types.
3698 The exception we need to make is then for packed arrays of
3699 records with discriminants or implicit initial values. We have
3700 no light/easy way to check for the latter case, so we merely
3701 check for packed arrays of records. This may lead to useless
3702 copy-in operations, but in very rare cases only, as these would
3703 be exceptions in a set of already exceptional situations. */
3704 if (Ekind (gnat_param) == E_Out_Parameter && !by_ref_p
3705 && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3706 || (!by_descr_p
3707 && !POINTER_TYPE_P (gnu_param_type)
3708 && !AGGREGATE_TYPE_P (gnu_param_type)))
3709 && !(Is_Array_Type (Etype (gnat_param))
3710 && Is_Packed (Etype (gnat_param))
3711 && Is_Composite_Type (Component_Type
3712 (Etype (gnat_param)))))
3713 gnu_param = NULL_TREE;
3714 else
3716 gnu_param
3717 = create_param_decl
3718 (gnu_param_name, gnu_param_type,
3719 by_ref_p || by_component_ptr_p
3720 || Ekind (gnat_param) == E_In_Parameter);
3722 DECL_BY_REF_P (gnu_param) = by_ref_p;
3723 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p;
3724 DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p;
3725 DECL_POINTS_TO_READONLY_P (gnu_param)
3726 = (Ekind (gnat_param) == E_In_Parameter
3727 && (by_ref_p || by_component_ptr_p));
3728 Sloc_to_locus (Sloc (gnat_param),
3729 &DECL_SOURCE_LOCATION (gnu_param));
3730 save_gnu_tree (gnat_param, gnu_param, false);
3731 gnu_param_list = chainon (gnu_param, gnu_param_list);
3733 /* If a parameter is a pointer, this function may modify
3734 memory through it and thus shouldn't be considered
3735 a pure function. Also, the memory may be modified
3736 between two calls, so they can't be CSE'ed. The latter
3737 case also handles by-ref parameters. */
3738 if (POINTER_TYPE_P (gnu_param_type)
3739 || TYPE_FAT_POINTER_P (gnu_param_type))
3740 pure_flag = false;
3743 if (copy_in_copy_out_flag)
3745 if (!has_copy_in_out)
3747 gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
3748 gnu_return_type = make_node (RECORD_TYPE);
3749 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3750 has_copy_in_out = true;
3753 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3754 gnu_return_type, 0, 0, 0, 0);
3755 Sloc_to_locus (Sloc (gnat_param),
3756 &DECL_SOURCE_LOCATION (gnu_field));
3757 TREE_CHAIN (gnu_field) = gnu_field_list;
3758 gnu_field_list = gnu_field;
3759 gnu_return_list = tree_cons (gnu_field, gnu_param,
3760 gnu_return_list);
3764 /* Do not compute record for out parameters if subprogram is
3765 stubbed since structures are incomplete for the back-end. */
3766 if (gnu_field_list
3767 && Convention (gnat_entity) != Convention_Stubbed)
3769 /* If all types are not complete, defer emission of debug
3770 information for this record types. Otherwise, we risk emitting
3771 debug information for a dummy type contained in the fields
3772 for that record. */
3773 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3774 false, defer_incomplete_level);
3776 if (defer_incomplete_level)
3778 debug_deferred = true;
3779 defer_debug_level++;
3781 defer_debug_incomplete_list
3782 = tree_cons (NULL_TREE, gnu_return_type,
3783 defer_debug_incomplete_list);
3787 /* If we have a CICO list but it has only one entry, we convert
3788 this function into a function that simply returns that one
3789 object. */
3790 if (list_length (gnu_return_list) == 1)
3791 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3793 if (Has_Stdcall_Convention (gnat_entity))
3795 struct attrib *attr
3796 = (struct attrib *) xmalloc (sizeof (struct attrib));
3798 attr->next = attr_list;
3799 attr->type = ATTR_MACHINE_ATTRIBUTE;
3800 attr->name = get_identifier ("stdcall");
3801 attr->args = NULL_TREE;
3802 attr->error_point = gnat_entity;
3803 attr_list = attr;
3806 /* Both lists ware built in reverse. */
3807 gnu_param_list = nreverse (gnu_param_list);
3808 gnu_return_list = nreverse (gnu_return_list);
3810 gnu_type
3811 = create_subprog_type (gnu_return_type, gnu_param_list,
3812 gnu_return_list, returns_unconstrained,
3813 returns_by_ref,
3814 Function_Returns_With_DSP (gnat_entity),
3815 returns_by_target_ptr);
3817 /* A subprogram (something that doesn't return anything) shouldn't
3818 be considered Pure since there would be no reason for such a
3819 subprogram. Note that procedures with Out (or In Out) parameters
3820 have already been converted into a function with a return type. */
3821 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
3822 pure_flag = false;
3824 /* The semantics of "pure" in Ada essentially matches that of "const"
3825 in the back-end. In particular, both properties are orthogonal to
3826 the "nothrow" property. But this is true only if the EH circuitry
3827 is explicit in the internal representation of the back-end. If we
3828 are to completely hide the EH circuitry from it, we need to declare
3829 that calls to pure Ada subprograms that can throw have side effects
3830 since they can trigger an "abnormal" transfer of control flow; thus
3831 they can be neither "const" nor "pure" in the back-end sense. */
3832 gnu_type
3833 = build_qualified_type (gnu_type,
3834 TYPE_QUALS (gnu_type)
3835 | (Exception_Mechanism == Back_End_Exceptions
3836 ? TYPE_QUAL_CONST * pure_flag : 0)
3837 | (TYPE_QUAL_VOLATILE * volatile_flag));
3839 Sloc_to_locus (Sloc (gnat_entity), &input_location);
3841 /* If we have a builtin decl for that function, check the signatures
3842 compatibilities. If the signatures are compatible, use the builtin
3843 decl. If they are not, we expect the checker predicate to have
3844 posted the appropriate errors, and just continue with what we have
3845 so far. */
3846 if (gnu_builtin_decl)
3848 tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
3850 if (compatible_signatures_p (gnu_type, gnu_builtin_type))
3852 gnu_decl = gnu_builtin_decl;
3853 gnu_type = gnu_builtin_type;
3854 break;
3858 /* If there was no specified Interface_Name and the external and
3859 internal names of the subprogram are the same, only use the
3860 internal name to allow disambiguation of nested subprograms. */
3861 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
3862 gnu_ext_name = NULL_TREE;
3864 /* If we are defining the subprogram and it has an Address clause
3865 we must get the address expression from the saved GCC tree for the
3866 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3867 the address expression here since the front-end has guaranteed
3868 in that case that the elaboration has no effects. If there is
3869 an Address clause and we are not defining the object, just
3870 make it a constant. */
3871 if (Present (Address_Clause (gnat_entity)))
3873 tree gnu_address = NULL_TREE;
3875 if (definition)
3876 gnu_address
3877 = (present_gnu_tree (gnat_entity)
3878 ? get_gnu_tree (gnat_entity)
3879 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
3881 save_gnu_tree (gnat_entity, NULL_TREE, false);
3883 gnu_type = build_reference_type (gnu_type);
3884 if (gnu_address)
3885 gnu_address = convert (gnu_type, gnu_address);
3887 gnu_decl
3888 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
3889 gnu_address, false, Is_Public (gnat_entity),
3890 extern_flag, false, NULL, gnat_entity);
3891 DECL_BY_REF_P (gnu_decl) = 1;
3894 else if (kind == E_Subprogram_Type)
3895 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3896 !Comes_From_Source (gnat_entity),
3897 debug_info_p && !defer_incomplete_level,
3898 gnat_entity);
3899 else
3901 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
3902 gnu_type, gnu_param_list,
3903 inline_flag, public_flag,
3904 extern_flag, attr_list,
3905 gnat_entity);
3907 DECL_STUBBED_P (gnu_decl)
3908 = Convention (gnat_entity) == Convention_Stubbed;
3911 break;
3913 case E_Incomplete_Type:
3914 case E_Incomplete_Subtype:
3915 case E_Private_Type:
3916 case E_Private_Subtype:
3917 case E_Limited_Private_Type:
3918 case E_Limited_Private_Subtype:
3919 case E_Record_Type_With_Private:
3920 case E_Record_Subtype_With_Private:
3922 /* Get the "full view" of this entity. If this is an incomplete
3923 entity from a limited with, treat its non-limited view as the
3924 full view. Otherwise, use either the full view or the underlying
3925 full view, whichever is present. This is used in all the tests
3926 below. */
3927 Entity_Id full_view
3928 = (IN (Ekind (gnat_entity), Incomplete_Kind)
3929 && From_With_Type (gnat_entity))
3930 ? Non_Limited_View (gnat_entity)
3931 : Present (Full_View (gnat_entity))
3932 ? Full_View (gnat_entity)
3933 : Underlying_Full_View (gnat_entity);
3935 /* If this is an incomplete type with no full view, it must be a Taft
3936 Amendment type, in which case we return a dummy type. Otherwise,
3937 just get the type from its Etype. */
3938 if (No (full_view))
3940 if (kind == E_Incomplete_Type)
3941 gnu_type = make_dummy_type (gnat_entity);
3942 else
3944 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
3945 NULL_TREE, 0);
3946 maybe_present = true;
3948 break;
3951 /* If we already made a type for the full view, reuse it. */
3952 else if (present_gnu_tree (full_view))
3954 gnu_decl = get_gnu_tree (full_view);
3955 break;
3958 /* Otherwise, if we are not defining the type now, get the type
3959 from the full view. But always get the type from the full view
3960 for define on use types, since otherwise we won't see them! */
3961 else if (!definition
3962 || (Is_Itype (full_view)
3963 && No (Freeze_Node (gnat_entity)))
3964 || (Is_Itype (gnat_entity)
3965 && No (Freeze_Node (full_view))))
3967 gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
3968 maybe_present = true;
3969 break;
3972 /* For incomplete types, make a dummy type entry which will be
3973 replaced later. */
3974 gnu_type = make_dummy_type (gnat_entity);
3976 /* Save this type as the full declaration's type so we can do any
3977 needed updates when we see it. */
3978 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3979 !Comes_From_Source (gnat_entity),
3980 debug_info_p, gnat_entity);
3981 save_gnu_tree (full_view, gnu_decl, 0);
3982 break;
3985 /* Simple class_wide types are always viewed as their root_type
3986 by Gigi unless an Equivalent_Type is specified. */
3987 case E_Class_Wide_Type:
3988 if (Present (Equivalent_Type (gnat_entity)))
3989 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3990 else
3991 gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity));
3993 maybe_present = true;
3994 break;
3996 case E_Task_Type:
3997 case E_Task_Subtype:
3998 case E_Protected_Type:
3999 case E_Protected_Subtype:
4000 if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity)))
4001 gnu_type = void_type_node;
4002 else
4003 gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity));
4005 maybe_present = true;
4006 break;
4008 case E_Label:
4009 gnu_decl = create_label_decl (gnu_entity_id);
4010 break;
4012 case E_Block:
4013 case E_Loop:
4014 /* Nothing at all to do here, so just return an ERROR_MARK and claim
4015 we've already saved it, so we don't try to. */
4016 gnu_decl = error_mark_node;
4017 saved = true;
4018 break;
4020 default:
4021 gcc_unreachable ();
4024 /* If we had a case where we evaluated another type and it might have
4025 defined this one, handle it here. */
4026 if (maybe_present && present_gnu_tree (gnat_entity))
4028 gnu_decl = get_gnu_tree (gnat_entity);
4029 saved = true;
4032 /* If we are processing a type and there is either no decl for it or
4033 we just made one, do some common processing for the type, such as
4034 handling alignment and possible padding. */
4036 if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
4038 if (Is_Tagged_Type (gnat_entity)
4039 || Is_Class_Wide_Equivalent_Type (gnat_entity))
4040 TYPE_ALIGN_OK (gnu_type) = 1;
4042 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
4043 TYPE_BY_REFERENCE_P (gnu_type) = 1;
4045 /* ??? Don't set the size for a String_Literal since it is either
4046 confirming or we don't handle it properly (if the low bound is
4047 non-constant). */
4048 if (!gnu_size && kind != E_String_Literal_Subtype)
4049 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
4050 TYPE_DECL, false,
4051 Has_Size_Clause (gnat_entity));
4053 /* If a size was specified, see if we can make a new type of that size
4054 by rearranging the type, for example from a fat to a thin pointer. */
4055 if (gnu_size)
4057 gnu_type
4058 = make_type_from_size (gnu_type, gnu_size,
4059 Has_Biased_Representation (gnat_entity));
4061 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
4062 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
4063 gnu_size = 0;
4066 /* If the alignment hasn't already been processed and this is
4067 not an unconstrained array, see if an alignment is specified.
4068 If not, we pick a default alignment for atomic objects. */
4069 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
4071 else if (Known_Alignment (gnat_entity))
4072 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
4073 TYPE_ALIGN (gnu_type));
4074 else if (Is_Atomic (gnat_entity) && !gnu_size
4075 && host_integerp (TYPE_SIZE (gnu_type), 1)
4076 && integer_pow2p (TYPE_SIZE (gnu_type)))
4077 align = MIN (BIGGEST_ALIGNMENT,
4078 tree_low_cst (TYPE_SIZE (gnu_type), 1));
4079 else if (Is_Atomic (gnat_entity) && gnu_size
4080 && host_integerp (gnu_size, 1)
4081 && integer_pow2p (gnu_size))
4082 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
4084 /* See if we need to pad the type. If we did, and made a record,
4085 the name of the new type may be changed. So get it back for
4086 us when we make the new TYPE_DECL below. */
4087 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity, "PAD",
4088 true, definition, false);
4089 if (TREE_CODE (gnu_type) == RECORD_TYPE
4090 && TYPE_IS_PADDING_P (gnu_type))
4092 gnu_entity_id = TYPE_NAME (gnu_type);
4093 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
4094 gnu_entity_id = DECL_NAME (gnu_entity_id);
4097 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
4099 /* If we are at global level, GCC will have applied variable_size to
4100 the type, but that won't have done anything. So, if it's not
4101 a constant or self-referential, call elaborate_expression_1 to
4102 make a variable for the size rather than calculating it each time.
4103 Handle both the RM size and the actual size. */
4104 if (global_bindings_p ()
4105 && TYPE_SIZE (gnu_type)
4106 && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
4107 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
4109 if (TREE_CODE (gnu_type) == RECORD_TYPE
4110 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
4111 TYPE_SIZE (gnu_type), 0))
4113 TYPE_SIZE (gnu_type)
4114 = elaborate_expression_1 (gnat_entity, gnat_entity,
4115 TYPE_SIZE (gnu_type),
4116 get_identifier ("SIZE"),
4117 definition, 0);
4118 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
4120 else
4122 TYPE_SIZE (gnu_type)
4123 = elaborate_expression_1 (gnat_entity, gnat_entity,
4124 TYPE_SIZE (gnu_type),
4125 get_identifier ("SIZE"),
4126 definition, 0);
4128 /* ??? For now, store the size as a multiple of the alignment
4129 in bytes so that we can see the alignment from the tree. */
4130 TYPE_SIZE_UNIT (gnu_type)
4131 = build_binary_op
4132 (MULT_EXPR, sizetype,
4133 elaborate_expression_1
4134 (gnat_entity, gnat_entity,
4135 build_binary_op (EXACT_DIV_EXPR, sizetype,
4136 TYPE_SIZE_UNIT (gnu_type),
4137 size_int (TYPE_ALIGN (gnu_type)
4138 / BITS_PER_UNIT)),
4139 get_identifier ("SIZE_A_UNIT"),
4140 definition, 0),
4141 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4143 if (TREE_CODE (gnu_type) == RECORD_TYPE)
4144 SET_TYPE_ADA_SIZE
4145 (gnu_type,
4146 elaborate_expression_1 (gnat_entity,
4147 gnat_entity,
4148 TYPE_ADA_SIZE (gnu_type),
4149 get_identifier ("RM_SIZE"),
4150 definition, 0));
4154 /* If this is a record type or subtype, call elaborate_expression_1 on
4155 any field position. Do this for both global and local types.
4156 Skip any fields that we haven't made trees for to avoid problems with
4157 class wide types. */
4158 if (IN (kind, Record_Kind))
4159 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
4160 gnat_temp = Next_Entity (gnat_temp))
4161 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
4163 tree gnu_field = get_gnu_tree (gnat_temp);
4165 /* ??? Unfortunately, GCC needs to be able to prove the
4166 alignment of this offset and if it's a variable, it can't.
4167 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
4168 right now, we have to put in an explicit multiply and
4169 divide by that value. */
4170 if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
4171 DECL_FIELD_OFFSET (gnu_field)
4172 = build_binary_op
4173 (MULT_EXPR, sizetype,
4174 elaborate_expression_1
4175 (gnat_temp, gnat_temp,
4176 build_binary_op (EXACT_DIV_EXPR, sizetype,
4177 DECL_FIELD_OFFSET (gnu_field),
4178 size_int (DECL_OFFSET_ALIGN (gnu_field)
4179 / BITS_PER_UNIT)),
4180 get_identifier ("OFFSET"),
4181 definition, 0),
4182 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
4185 gnu_type = build_qualified_type (gnu_type,
4186 (TYPE_QUALS (gnu_type)
4187 | (TYPE_QUAL_VOLATILE
4188 * Treat_As_Volatile (gnat_entity))));
4190 if (Is_Atomic (gnat_entity))
4191 check_ok_for_atomic (gnu_type, gnat_entity, false);
4193 if (Known_Alignment (gnat_entity))
4194 TYPE_USER_ALIGN (gnu_type) = 1;
4196 if (!gnu_decl)
4197 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
4198 !Comes_From_Source (gnat_entity),
4199 debug_info_p, gnat_entity);
4200 else
4201 TREE_TYPE (gnu_decl) = gnu_type;
4204 if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
4206 gnu_type = TREE_TYPE (gnu_decl);
4208 /* Back-annotate the Alignment of the type if not already in the
4209 tree. Likewise for sizes. */
4210 if (Unknown_Alignment (gnat_entity))
4211 Set_Alignment (gnat_entity,
4212 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
4214 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
4216 /* If the size is self-referential, we annotate the maximum
4217 value of that size. */
4218 tree gnu_size = TYPE_SIZE (gnu_type);
4220 if (CONTAINS_PLACEHOLDER_P (gnu_size))
4221 gnu_size = max_size (gnu_size, true);
4223 Set_Esize (gnat_entity, annotate_value (gnu_size));
4225 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
4227 /* In this mode the tag and the parent components are not
4228 generated by the front-end, so the sizes must be adjusted
4229 explicitly now. */
4231 int size_offset;
4232 int new_size;
4234 if (Is_Derived_Type (gnat_entity))
4236 size_offset
4237 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
4238 Set_Alignment (gnat_entity,
4239 Alignment (Etype (Base_Type (gnat_entity))));
4241 else
4242 size_offset = POINTER_SIZE;
4244 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
4245 Set_Esize (gnat_entity,
4246 UI_From_Int (((new_size + (POINTER_SIZE - 1))
4247 / POINTER_SIZE) * POINTER_SIZE));
4248 Set_RM_Size (gnat_entity, Esize (gnat_entity));
4252 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
4253 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
4256 if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
4257 DECL_ARTIFICIAL (gnu_decl) = 1;
4259 if (!debug_info_p && DECL_P (gnu_decl)
4260 && TREE_CODE (gnu_decl) != FUNCTION_DECL
4261 && No (Renamed_Object (gnat_entity)))
4262 DECL_IGNORED_P (gnu_decl) = 1;
4264 /* If we haven't already, associate the ..._DECL node that we just made with
4265 the input GNAT entity node. */
4266 if (!saved)
4267 save_gnu_tree (gnat_entity, gnu_decl, false);
4269 /* If this is an enumeral or floating-point type, we were not able to set
4270 the bounds since they refer to the type. These bounds are always static.
4272 For enumeration types, also write debugging information and declare the
4273 enumeration literal table, if needed. */
4275 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
4276 || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
4278 tree gnu_scalar_type = gnu_type;
4280 /* If this is a padded type, we need to use the underlying type. */
4281 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
4282 && TYPE_IS_PADDING_P (gnu_scalar_type))
4283 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
4285 /* If this is a floating point type and we haven't set a floating
4286 point type yet, use this in the evaluation of the bounds. */
4287 if (!longest_float_type_node && kind == E_Floating_Point_Type)
4288 longest_float_type_node = gnu_type;
4290 TYPE_MIN_VALUE (gnu_scalar_type)
4291 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
4292 TYPE_MAX_VALUE (gnu_scalar_type)
4293 = gnat_to_gnu (Type_High_Bound (gnat_entity));
4295 if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
4297 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
4299 /* Since this has both a typedef and a tag, avoid outputting
4300 the name twice. */
4301 DECL_ARTIFICIAL (gnu_decl) = 1;
4302 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
4306 /* If we deferred processing of incomplete types, re-enable it. If there
4307 were no other disables and we have some to process, do so. */
4308 if (this_deferred && --defer_incomplete_level == 0 && defer_incomplete_list)
4310 struct incomplete *incp = defer_incomplete_list;
4311 struct incomplete *next;
4313 defer_incomplete_list = NULL;
4314 for (; incp; incp = next)
4316 next = incp->next;
4318 if (incp->old_type)
4319 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4320 gnat_to_gnu_type (incp->full_type));
4321 free (incp);
4325 /* If we are not defining this type, see if it's in the incomplete list.
4326 If so, handle that list entry now. */
4327 else if (!definition)
4329 struct incomplete *incp;
4331 for (incp = defer_incomplete_list; incp; incp = incp->next)
4332 if (incp->old_type && incp->full_type == gnat_entity)
4334 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4335 TREE_TYPE (gnu_decl));
4336 incp->old_type = NULL_TREE;
4340 /* If there are no incomplete types and we have deferred emission
4341 of debug information, check whether we have finished defining
4342 all nested records.
4343 If so, handle the list now. */
4345 if (debug_deferred)
4346 defer_debug_level--;
4348 if (defer_debug_incomplete_list
4349 && !defer_incomplete_level
4350 && !defer_debug_level)
4352 tree c, n;
4354 defer_debug_incomplete_list = nreverse (defer_debug_incomplete_list);
4356 for (c = defer_debug_incomplete_list; c; c = n)
4358 n = TREE_CHAIN (c);
4359 write_record_type_debug_info (TREE_VALUE (c));
4362 defer_debug_incomplete_list = 0;
4365 if (this_global)
4366 force_global--;
4368 if (Is_Packed_Array_Type (gnat_entity)
4369 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4370 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4371 && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4372 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4374 return gnu_decl;
4377 /* Similar, but if the returned value is a COMPONENT_REF, return the
4378 FIELD_DECL. */
4380 tree
4381 gnat_to_gnu_field_decl (Entity_Id gnat_entity)
4383 tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4385 if (TREE_CODE (gnu_field) == COMPONENT_REF)
4386 gnu_field = TREE_OPERAND (gnu_field, 1);
4388 return gnu_field;
4391 /* Return true if DISCR1 and DISCR2 represent the same discriminant. */
4393 static
4394 bool same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
4396 while (Present (Corresponding_Discriminant (discr1)))
4397 discr1 = Corresponding_Discriminant (discr1);
4399 while (Present (Corresponding_Discriminant (discr2)))
4400 discr2 = Corresponding_Discriminant (discr2);
4402 return
4403 Original_Record_Component (discr1) == Original_Record_Component (discr2);
4406 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4407 be elaborated at the point of its definition, but do nothing else. */
4409 void
4410 elaborate_entity (Entity_Id gnat_entity)
4412 switch (Ekind (gnat_entity))
4414 case E_Signed_Integer_Subtype:
4415 case E_Modular_Integer_Subtype:
4416 case E_Enumeration_Subtype:
4417 case E_Ordinary_Fixed_Point_Subtype:
4418 case E_Decimal_Fixed_Point_Subtype:
4419 case E_Floating_Point_Subtype:
4421 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4422 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4424 /* ??? Tests for avoiding static constraint error expression
4425 is needed until the front stops generating bogus conversions
4426 on bounds of real types. */
4428 if (!Raises_Constraint_Error (gnat_lb))
4429 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4430 1, 0, Needs_Debug_Info (gnat_entity));
4431 if (!Raises_Constraint_Error (gnat_hb))
4432 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4433 1, 0, Needs_Debug_Info (gnat_entity));
4434 break;
4437 case E_Record_Type:
4439 Node_Id full_definition = Declaration_Node (gnat_entity);
4440 Node_Id record_definition = Type_Definition (full_definition);
4442 /* If this is a record extension, go a level further to find the
4443 record definition. */
4444 if (Nkind (record_definition) == N_Derived_Type_Definition)
4445 record_definition = Record_Extension_Part (record_definition);
4447 break;
4449 case E_Record_Subtype:
4450 case E_Private_Subtype:
4451 case E_Limited_Private_Subtype:
4452 case E_Record_Subtype_With_Private:
4453 if (Is_Constrained (gnat_entity)
4454 && Has_Discriminants (Base_Type (gnat_entity))
4455 && Present (Discriminant_Constraint (gnat_entity)))
4457 Node_Id gnat_discriminant_expr;
4458 Entity_Id gnat_field;
4460 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
4461 gnat_discriminant_expr
4462 = First_Elmt (Discriminant_Constraint (gnat_entity));
4463 Present (gnat_field);
4464 gnat_field = Next_Discriminant (gnat_field),
4465 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
4466 /* ??? For now, ignore access discriminants. */
4467 if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
4468 elaborate_expression (Node (gnat_discriminant_expr),
4469 gnat_entity,
4470 get_entity_name (gnat_field), 1, 0, 0);
4472 break;
4477 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4478 any entities on its entity chain similarly. */
4480 void
4481 mark_out_of_scope (Entity_Id gnat_entity)
4483 Entity_Id gnat_sub_entity;
4484 unsigned int kind = Ekind (gnat_entity);
4486 /* If this has an entity list, process all in the list. */
4487 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
4488 || IN (kind, Private_Kind)
4489 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
4490 || kind == E_Function || kind == E_Generic_Function
4491 || kind == E_Generic_Package || kind == E_Generic_Procedure
4492 || kind == E_Loop || kind == E_Operator || kind == E_Package
4493 || kind == E_Package_Body || kind == E_Procedure
4494 || kind == E_Record_Type || kind == E_Record_Subtype
4495 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
4496 for (gnat_sub_entity = First_Entity (gnat_entity);
4497 Present (gnat_sub_entity);
4498 gnat_sub_entity = Next_Entity (gnat_sub_entity))
4499 if (Scope (gnat_sub_entity) == gnat_entity
4500 && gnat_sub_entity != gnat_entity)
4501 mark_out_of_scope (gnat_sub_entity);
4503 /* Now clear this if it has been defined, but only do so if it isn't
4504 a subprogram or parameter. We could refine this, but it isn't
4505 worth it. If this is statically allocated, it is supposed to
4506 hang around out of cope. */
4507 if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
4508 && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
4510 save_gnu_tree (gnat_entity, NULL_TREE, true);
4511 save_gnu_tree (gnat_entity, error_mark_node, true);
4515 /* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
4516 is a multi-dimensional array type, do this recursively. */
4518 static void
4519 copy_alias_set (tree gnu_new_type, tree gnu_old_type)
4521 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
4522 of a one-dimensional array, since the padding has the same alias set
4523 as the field type, but if it's a multi-dimensional array, we need to
4524 see the inner types. */
4525 while (TREE_CODE (gnu_old_type) == RECORD_TYPE
4526 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
4527 || TYPE_IS_PADDING_P (gnu_old_type)))
4528 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
4530 /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
4531 array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
4532 so we need to go down to what does. */
4533 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
4534 gnu_old_type
4535 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
4537 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
4538 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
4539 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
4540 copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
4542 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
4543 record_component_aliases (gnu_new_type);
4546 /* Return a TREE_LIST describing the substitutions needed to reflect
4547 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4548 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4549 of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
4550 gives the tree for the discriminant and TREE_VALUES is the replacement
4551 value. They are in the form of operands to substitute_in_expr.
4552 DEFINITION is as in gnat_to_gnu_entity. */
4554 static tree
4555 substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
4556 tree gnu_list, bool definition)
4558 Entity_Id gnat_discrim;
4559 Node_Id gnat_value;
4561 if (No (gnat_type))
4562 gnat_type = Implementation_Base_Type (gnat_subtype);
4564 if (Has_Discriminants (gnat_type))
4565 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
4566 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
4567 Present (gnat_discrim);
4568 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
4569 gnat_value = Next_Elmt (gnat_value))
4570 /* Ignore access discriminants. */
4571 if (!Is_Access_Type (Etype (Node (gnat_value))))
4572 gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
4573 elaborate_expression
4574 (Node (gnat_value), gnat_subtype,
4575 get_entity_name (gnat_discrim), definition,
4576 1, 0),
4577 gnu_list);
4579 return gnu_list;
4582 /* Return true if the size represented by GNU_SIZE can be handled by an
4583 allocation. If STATIC_P is true, consider only what can be done with a
4584 static allocation. */
4586 static bool
4587 allocatable_size_p (tree gnu_size, bool static_p)
4589 HOST_WIDE_INT our_size;
4591 /* If this is not a static allocation, the only case we want to forbid
4592 is an overflowing size. That will be converted into a raise a
4593 Storage_Error. */
4594 if (!static_p)
4595 return !(TREE_CODE (gnu_size) == INTEGER_CST
4596 && TREE_OVERFLOW (gnu_size));
4598 /* Otherwise, we need to deal with both variable sizes and constant
4599 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4600 since assemblers may not like very large sizes. */
4601 if (!host_integerp (gnu_size, 1))
4602 return false;
4604 our_size = tree_low_cst (gnu_size, 1);
4605 return (int) our_size == our_size;
4608 /* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
4610 static void
4611 prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
4613 Node_Id gnat_temp;
4615 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
4616 gnat_temp = Next_Rep_Item (gnat_temp))
4617 if (Nkind (gnat_temp) == N_Pragma)
4619 struct attrib *attr;
4620 tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
4621 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
4622 enum attr_type etype;
4624 if (Present (gnat_assoc) && Present (First (gnat_assoc))
4625 && Present (Next (First (gnat_assoc)))
4626 && (Nkind (Expression (Next (First (gnat_assoc))))
4627 == N_String_Literal))
4629 gnu_arg0 = get_identifier (TREE_STRING_POINTER
4630 (gnat_to_gnu
4631 (Expression (Next
4632 (First (gnat_assoc))))));
4633 if (Present (Next (Next (First (gnat_assoc))))
4634 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
4635 == N_String_Literal))
4636 gnu_arg1 = get_identifier (TREE_STRING_POINTER
4637 (gnat_to_gnu
4638 (Expression
4639 (Next (Next
4640 (First (gnat_assoc)))))));
4643 switch (Get_Pragma_Id (Chars (gnat_temp)))
4645 case Pragma_Machine_Attribute:
4646 etype = ATTR_MACHINE_ATTRIBUTE;
4647 break;
4649 case Pragma_Linker_Alias:
4650 etype = ATTR_LINK_ALIAS;
4651 break;
4653 case Pragma_Linker_Section:
4654 etype = ATTR_LINK_SECTION;
4655 break;
4657 case Pragma_Linker_Constructor:
4658 etype = ATTR_LINK_CONSTRUCTOR;
4659 break;
4661 case Pragma_Linker_Destructor:
4662 etype = ATTR_LINK_DESTRUCTOR;
4663 break;
4665 case Pragma_Weak_External:
4666 etype = ATTR_WEAK_EXTERNAL;
4667 break;
4669 default:
4670 continue;
4673 attr = (struct attrib *) xmalloc (sizeof (struct attrib));
4674 attr->next = *attr_list;
4675 attr->type = etype;
4676 attr->name = gnu_arg0;
4678 /* If we have an argument specified together with an attribute name,
4679 make it a single TREE_VALUE entry in a list of arguments, as GCC
4680 expects it. */
4681 if (gnu_arg1 != NULL_TREE)
4682 attr->args = build_tree_list (NULL_TREE, gnu_arg1);
4683 else
4684 attr->args = NULL_TREE;
4686 attr->error_point
4687 = Present (Next (First (gnat_assoc)))
4688 ? Expression (Next (First (gnat_assoc))) : gnat_temp;
4689 *attr_list = attr;
4693 /* Get the unpadded version of a GNAT type. */
4695 tree
4696 get_unpadded_type (Entity_Id gnat_entity)
4698 tree type = gnat_to_gnu_type (gnat_entity);
4700 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4701 type = TREE_TYPE (TYPE_FIELDS (type));
4703 return type;
4706 /* Called when we need to protect a variable object using a save_expr. */
4708 tree
4709 maybe_variable (tree gnu_operand)
4711 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
4712 || TREE_CODE (gnu_operand) == SAVE_EXPR
4713 || TREE_CODE (gnu_operand) == NULL_EXPR)
4714 return gnu_operand;
4716 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
4718 tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
4719 TREE_TYPE (gnu_operand),
4720 variable_size (TREE_OPERAND (gnu_operand, 0)));
4722 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
4723 = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
4724 return gnu_result;
4726 else
4727 return variable_size (gnu_operand);
4730 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4731 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4732 return the GCC tree to use for that expression. GNU_NAME is the
4733 qualification to use if an external name is appropriate and DEFINITION is
4734 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4735 we need a result. Otherwise, we are just elaborating this for
4736 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4737 purposes even if it isn't needed for code generation. */
4739 static tree
4740 elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
4741 tree gnu_name, bool definition, bool need_value,
4742 bool need_debug)
4744 tree gnu_expr;
4746 /* If we already elaborated this expression (e.g., it was involved
4747 in the definition of a private type), use the old value. */
4748 if (present_gnu_tree (gnat_expr))
4749 return get_gnu_tree (gnat_expr);
4751 /* If we don't need a value and this is static or a discriminant, we
4752 don't need to do anything. */
4753 else if (!need_value
4754 && (Is_OK_Static_Expression (gnat_expr)
4755 || (Nkind (gnat_expr) == N_Identifier
4756 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
4757 return 0;
4759 /* Otherwise, convert this tree to its GCC equivalent. */
4760 gnu_expr
4761 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
4762 gnu_name, definition, need_debug);
4764 /* Save the expression in case we try to elaborate this entity again. Since
4765 this is not a DECL, don't check it. Don't save if it's a discriminant. */
4766 if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
4767 save_gnu_tree (gnat_expr, gnu_expr, true);
4769 return need_value ? gnu_expr : error_mark_node;
4772 /* Similar, but take a GNU expression. */
4774 static tree
4775 elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
4776 tree gnu_expr, tree gnu_name, bool definition,
4777 bool need_debug)
4779 tree gnu_decl = NULL_TREE;
4780 /* Strip any conversions to see if the expression is a readonly variable.
4781 ??? This really should remain readonly, but we have to think about
4782 the typing of the tree here. */
4783 tree gnu_inner_expr = remove_conversions (gnu_expr, true);
4784 bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
4785 bool expr_variable;
4787 /* In most cases, we won't see a naked FIELD_DECL here because a
4788 discriminant reference will have been replaced with a COMPONENT_REF
4789 when the type is being elaborated. However, there are some cases
4790 involving child types where we will. So convert it to a COMPONENT_REF
4791 here. We have to hope it will be at the highest level of the
4792 expression in these cases. */
4793 if (TREE_CODE (gnu_expr) == FIELD_DECL)
4794 gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
4795 build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
4796 gnu_expr, NULL_TREE);
4798 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
4799 that is a constant, make a variable that is initialized to contain the
4800 bound when the package containing the definition is elaborated. If
4801 this entity is defined at top level and a bound or discriminant value
4802 isn't a constant or a reference to a discriminant, replace the bound
4803 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
4804 rely here on the fact that an expression cannot contain both the
4805 discriminant and some other variable. */
4807 expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
4808 && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
4809 && (TREE_READONLY (gnu_inner_expr)
4810 || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
4811 && !CONTAINS_PLACEHOLDER_P (gnu_expr));
4813 /* If this is a static expression or contains a discriminant, we don't
4814 need the variable for debugging (and can't elaborate anyway if a
4815 discriminant). */
4816 if (need_debug
4817 && (Is_OK_Static_Expression (gnat_expr)
4818 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
4819 need_debug = false;
4821 /* Now create the variable if we need it. */
4822 if (need_debug || (expr_variable && expr_global))
4823 gnu_decl
4824 = create_var_decl (create_concat_name (gnat_entity,
4825 IDENTIFIER_POINTER (gnu_name)),
4826 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
4827 !need_debug, Is_Public (gnat_entity),
4828 !definition, false, NULL, gnat_entity);
4830 /* We only need to use this variable if we are in global context since GCC
4831 can do the right thing in the local case. */
4832 if (expr_global && expr_variable)
4833 return gnu_decl;
4834 else if (!expr_variable)
4835 return gnu_expr;
4836 else
4837 return maybe_variable (gnu_expr);
4840 /* Create a record type that contains a field of TYPE with a starting bit
4841 position so that it is aligned to ALIGN bits and is SIZE bytes long. */
4843 tree
4844 make_aligning_type (tree type, int align, tree size)
4846 tree record_type = make_node (RECORD_TYPE);
4847 tree place = build0 (PLACEHOLDER_EXPR, record_type);
4848 tree size_addr_place = convert (sizetype,
4849 build_unary_op (ADDR_EXPR, NULL_TREE,
4850 place));
4851 tree name = TYPE_NAME (type);
4852 tree pos, field;
4854 if (TREE_CODE (name) == TYPE_DECL)
4855 name = DECL_NAME (name);
4857 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
4859 /* The bit position is obtained by "and"ing the alignment minus 1
4860 with the two's complement of the address and multiplying
4861 by the number of bits per unit. Do all this in sizetype. */
4862 pos = size_binop (MULT_EXPR,
4863 convert (bitsizetype,
4864 size_binop (BIT_AND_EXPR,
4865 size_diffop (size_zero_node,
4866 size_addr_place),
4867 ssize_int ((align / BITS_PER_UNIT)
4868 - 1))),
4869 bitsize_unit_node);
4871 /* Create the field, with -1 as the 'addressable' indication to avoid the
4872 creation of a bitfield. We don't need one, it would have damaging
4873 consequences on the alignment computation, and create_field_decl would
4874 make one without this special argument, for instance because of the
4875 complex position expression. */
4876 field = create_field_decl (get_identifier ("F"), type, record_type, 1, size,
4877 pos, -1);
4879 finish_record_type (record_type, field, true, false);
4880 TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
4881 TYPE_SIZE (record_type)
4882 = size_binop (PLUS_EXPR,
4883 size_binop (MULT_EXPR, convert (bitsizetype, size),
4884 bitsize_unit_node),
4885 bitsize_int (align));
4886 TYPE_SIZE_UNIT (record_type)
4887 = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
4888 copy_alias_set (record_type, type);
4889 return record_type;
4892 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
4893 being used as the field type of a packed record. See if we can rewrite it
4894 as a record that has a non-BLKmode type, which we can pack tighter. If so,
4895 return the new type. If not, return the original type. */
4897 static tree
4898 make_packable_type (tree type)
4900 tree new_type = make_node (TREE_CODE (type));
4901 tree field_list = NULL_TREE;
4902 tree old_field;
4904 /* Copy the name and flags from the old type to that of the new and set
4905 the alignment to try for an integral type. For QUAL_UNION_TYPE,
4906 also copy the size. */
4907 TYPE_NAME (new_type) = TYPE_NAME (type);
4908 TYPE_JUSTIFIED_MODULAR_P (new_type)
4909 = TYPE_JUSTIFIED_MODULAR_P (type);
4910 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
4912 if (TREE_CODE (type) == RECORD_TYPE)
4913 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
4914 else if (TREE_CODE (type) == QUAL_UNION_TYPE)
4916 TYPE_SIZE (new_type) = TYPE_SIZE (type);
4917 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
4920 TYPE_ALIGN (new_type)
4921 = ((HOST_WIDE_INT) 1
4922 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
4924 /* Now copy the fields, keeping the position and size. */
4925 for (old_field = TYPE_FIELDS (type); old_field;
4926 old_field = TREE_CHAIN (old_field))
4928 tree new_field_type = TREE_TYPE (old_field);
4929 tree new_field;
4931 if (TYPE_MODE (new_field_type) == BLKmode
4932 && (TREE_CODE (new_field_type) == RECORD_TYPE
4933 || TREE_CODE (new_field_type) == UNION_TYPE
4934 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
4935 && host_integerp (TYPE_SIZE (new_field_type), 1))
4936 new_field_type = make_packable_type (new_field_type);
4938 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
4939 new_type, TYPE_PACKED (type),
4940 DECL_SIZE (old_field),
4941 bit_position (old_field),
4942 !DECL_NONADDRESSABLE_P (old_field));
4944 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
4945 SET_DECL_ORIGINAL_FIELD
4946 (new_field, (DECL_ORIGINAL_FIELD (old_field)
4947 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
4949 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
4950 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
4952 TREE_CHAIN (new_field) = field_list;
4953 field_list = new_field;
4956 finish_record_type (new_type, nreverse (field_list), true, true);
4957 copy_alias_set (new_type, type);
4958 return TYPE_MODE (new_type) == BLKmode ? type : new_type;
4961 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
4962 if needed. We have already verified that SIZE and TYPE are large enough.
4964 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
4965 to issue a warning.
4967 IS_USER_TYPE is true if we must be sure we complete the original type.
4969 DEFINITION is true if this type is being defined.
4971 SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
4972 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
4973 type. */
4975 tree
4976 maybe_pad_type (tree type, tree size, unsigned int align,
4977 Entity_Id gnat_entity, const char *name_trailer,
4978 bool is_user_type, bool definition, bool same_rm_size)
4980 tree orig_size = TYPE_SIZE (type);
4981 tree record;
4982 tree field;
4984 /* If TYPE is a padded type, see if it agrees with any size and alignment
4985 we were given. If so, return the original type. Otherwise, strip
4986 off the padding, since we will either be returning the inner type
4987 or repadding it. If no size or alignment is specified, use that of
4988 the original padded type. */
4990 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4992 if ((!size
4993 || operand_equal_p (round_up (size,
4994 MAX (align, TYPE_ALIGN (type))),
4995 round_up (TYPE_SIZE (type),
4996 MAX (align, TYPE_ALIGN (type))),
4998 && (align == 0 || align == TYPE_ALIGN (type)))
4999 return type;
5001 if (!size)
5002 size = TYPE_SIZE (type);
5003 if (align == 0)
5004 align = TYPE_ALIGN (type);
5006 type = TREE_TYPE (TYPE_FIELDS (type));
5007 orig_size = TYPE_SIZE (type);
5010 /* If the size is either not being changed or is being made smaller (which
5011 is not done here (and is only valid for bitfields anyway), show the size
5012 isn't changing. Likewise, clear the alignment if it isn't being
5013 changed. Then return if we aren't doing anything. */
5015 if (size
5016 && (operand_equal_p (size, orig_size, 0)
5017 || (TREE_CODE (orig_size) == INTEGER_CST
5018 && tree_int_cst_lt (size, orig_size))))
5019 size = NULL_TREE;
5021 if (align == TYPE_ALIGN (type))
5022 align = 0;
5024 if (align == 0 && !size)
5025 return type;
5027 /* We used to modify the record in place in some cases, but that could
5028 generate incorrect debugging information. So make a new record
5029 type and name. */
5030 record = make_node (RECORD_TYPE);
5032 if (Present (gnat_entity))
5033 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
5035 /* If we were making a type, complete the original type and give it a
5036 name. */
5037 if (is_user_type)
5038 create_type_decl (get_entity_name (gnat_entity), type,
5039 NULL, !Comes_From_Source (gnat_entity),
5040 !(TYPE_NAME (type)
5041 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
5042 && DECL_IGNORED_P (TYPE_NAME (type))),
5043 gnat_entity);
5045 /* If we are changing the alignment and the input type is a record with
5046 BLKmode and a small constant size, try to make a form that has an
5047 integral mode. That might allow this record to have an integral mode,
5048 which will be much more efficient. There is no point in doing this if a
5049 size is specified unless it is also smaller than the biggest alignment
5050 and it is incorrect to do this if the size of the original type is not a
5051 multiple of the alignment. */
5052 if (align != 0
5053 && TREE_CODE (type) == RECORD_TYPE
5054 && TYPE_MODE (type) == BLKmode
5055 && host_integerp (orig_size, 1)
5056 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
5057 && (!size
5058 || (TREE_CODE (size) == INTEGER_CST
5059 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
5060 && tree_low_cst (orig_size, 1) % align == 0)
5061 type = make_packable_type (type);
5063 field = create_field_decl (get_identifier ("F"), type, record, 0,
5064 NULL_TREE, bitsize_zero_node, 1);
5066 DECL_INTERNAL_P (field) = 1;
5067 TYPE_SIZE (record) = size ? size : orig_size;
5068 TYPE_SIZE_UNIT (record)
5069 = (size ? convert (sizetype,
5070 size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node))
5071 : TYPE_SIZE_UNIT (type));
5073 TYPE_ALIGN (record) = align;
5074 TYPE_IS_PADDING_P (record) = 1;
5075 TYPE_VOLATILE (record)
5076 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
5077 finish_record_type (record, field, true, false);
5079 /* Keep the RM_Size of the padded record as that of the old record
5080 if requested. */
5081 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
5083 /* Unless debugging information isn't being written for the input type,
5084 write a record that shows what we are a subtype of and also make a
5085 variable that indicates our size, if variable. */
5086 if (TYPE_NAME (record) && AGGREGATE_TYPE_P (type)
5087 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
5088 || !DECL_IGNORED_P (TYPE_NAME (type))))
5090 tree marker = make_node (RECORD_TYPE);
5091 tree name = (TREE_CODE (TYPE_NAME (record)) == TYPE_DECL
5092 ? DECL_NAME (TYPE_NAME (record))
5093 : TYPE_NAME (record));
5094 tree orig_name = TYPE_NAME (type);
5096 if (TREE_CODE (orig_name) == TYPE_DECL)
5097 orig_name = DECL_NAME (orig_name);
5099 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
5100 finish_record_type (marker,
5101 create_field_decl (orig_name, integer_type_node,
5102 marker, 0, NULL_TREE, NULL_TREE,
5104 false, false);
5106 if (size && TREE_CODE (size) != INTEGER_CST && definition)
5107 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
5108 bitsizetype, TYPE_SIZE (record), false, false, false,
5109 false, NULL, gnat_entity);
5112 type = record;
5114 if (CONTAINS_PLACEHOLDER_P (orig_size))
5115 orig_size = max_size (orig_size, true);
5117 /* If the size was widened explicitly, maybe give a warning. */
5118 if (size && Present (gnat_entity)
5119 && !operand_equal_p (size, orig_size, 0)
5120 && !(TREE_CODE (size) == INTEGER_CST
5121 && TREE_CODE (orig_size) == INTEGER_CST
5122 && tree_int_cst_lt (size, orig_size)))
5124 Node_Id gnat_error_node = Empty;
5126 if (Is_Packed_Array_Type (gnat_entity))
5127 gnat_entity = Associated_Node_For_Itype (gnat_entity);
5129 if ((Ekind (gnat_entity) == E_Component
5130 || Ekind (gnat_entity) == E_Discriminant)
5131 && Present (Component_Clause (gnat_entity)))
5132 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
5133 else if (Present (Size_Clause (gnat_entity)))
5134 gnat_error_node = Expression (Size_Clause (gnat_entity));
5136 /* Generate message only for entities that come from source, since
5137 if we have an entity created by expansion, the message will be
5138 generated for some other corresponding source entity. */
5139 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
5140 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
5141 gnat_entity,
5142 size_diffop (size, orig_size));
5144 else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
5145 post_error_ne_tree ("component of& padded{ by ^ bits}?",
5146 gnat_entity, gnat_entity,
5147 size_diffop (size, orig_size));
5150 return type;
5153 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
5154 the value passed against the list of choices. */
5156 tree
5157 choices_to_gnu (tree operand, Node_Id choices)
5159 Node_Id choice;
5160 Node_Id gnat_temp;
5161 tree result = integer_zero_node;
5162 tree this_test, low = 0, high = 0, single = 0;
5164 for (choice = First (choices); Present (choice); choice = Next (choice))
5166 switch (Nkind (choice))
5168 case N_Range:
5169 low = gnat_to_gnu (Low_Bound (choice));
5170 high = gnat_to_gnu (High_Bound (choice));
5172 /* There's no good type to use here, so we might as well use
5173 integer_type_node. */
5174 this_test
5175 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5176 build_binary_op (GE_EXPR, integer_type_node,
5177 operand, low),
5178 build_binary_op (LE_EXPR, integer_type_node,
5179 operand, high));
5181 break;
5183 case N_Subtype_Indication:
5184 gnat_temp = Range_Expression (Constraint (choice));
5185 low = gnat_to_gnu (Low_Bound (gnat_temp));
5186 high = gnat_to_gnu (High_Bound (gnat_temp));
5188 this_test
5189 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5190 build_binary_op (GE_EXPR, integer_type_node,
5191 operand, low),
5192 build_binary_op (LE_EXPR, integer_type_node,
5193 operand, high));
5194 break;
5196 case N_Identifier:
5197 case N_Expanded_Name:
5198 /* This represents either a subtype range, an enumeration
5199 literal, or a constant Ekind says which. If an enumeration
5200 literal or constant, fall through to the next case. */
5201 if (Ekind (Entity (choice)) != E_Enumeration_Literal
5202 && Ekind (Entity (choice)) != E_Constant)
5204 tree type = gnat_to_gnu_type (Entity (choice));
5206 low = TYPE_MIN_VALUE (type);
5207 high = TYPE_MAX_VALUE (type);
5209 this_test
5210 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
5211 build_binary_op (GE_EXPR, integer_type_node,
5212 operand, low),
5213 build_binary_op (LE_EXPR, integer_type_node,
5214 operand, high));
5215 break;
5217 /* ... fall through ... */
5218 case N_Character_Literal:
5219 case N_Integer_Literal:
5220 single = gnat_to_gnu (choice);
5221 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
5222 single);
5223 break;
5225 case N_Others_Choice:
5226 this_test = integer_one_node;
5227 break;
5229 default:
5230 gcc_unreachable ();
5233 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5234 result, this_test);
5237 return result;
5240 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
5241 placed in GNU_RECORD_TYPE.
5243 PACKED is 1 if the enclosing record is packed and -1 if the enclosing
5244 record has a Component_Alignment of Storage_Unit.
5246 DEFINITION is true if this field is for a record being defined. */
5248 static tree
5249 gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
5250 bool definition)
5252 tree gnu_field_id = get_entity_name (gnat_field);
5253 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
5254 tree gnu_pos = 0;
5255 tree gnu_size = 0;
5256 tree gnu_field;
5257 bool needs_strict_alignment
5258 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
5259 || Treat_As_Volatile (gnat_field));
5261 /* If this field requires strict alignment or contains an item of
5262 variable sized, pretend it isn't packed. */
5263 if (needs_strict_alignment || is_variable_size (gnu_field_type))
5264 packed = 0;
5266 /* For packed records, this is one of the few occasions on which we use
5267 the official RM size for discrete or fixed-point components, instead
5268 of the normal GNAT size stored in Esize. See description in Einfo:
5269 "Handling of Type'Size Values" for further details. */
5271 if (packed == 1)
5272 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
5273 gnat_field, FIELD_DECL, false, true);
5275 if (Known_Static_Esize (gnat_field))
5276 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5277 gnat_field, FIELD_DECL, false, true);
5279 /* If we have a specified size that's smaller than that of the field type,
5280 or a position is specified, and the field type is also a record that's
5281 BLKmode and with a small constant size, see if we can get an integral
5282 mode form of the type when appropriate. If we can, show a size was
5283 specified for the field if there wasn't one already, so we know to make
5284 this a bitfield and avoid making things wider.
5286 Doing this is first useful if the record is packed because we can then
5287 place the field at a non-byte-aligned position and so achieve tighter
5288 packing.
5290 This is in addition *required* if the field shares a byte with another
5291 field and the front-end lets the back-end handle the references, because
5292 GCC does not handle BLKmode bitfields properly.
5294 We avoid the transformation if it is not required or potentially useful,
5295 as it might entail an increase of the field's alignment and have ripple
5296 effects on the outer record type. A typical case is a field known to be
5297 byte aligned and not to share a byte with another field.
5299 Besides, we don't even look the possibility of a transformation in cases
5300 known to be in error already, for instance when an invalid size results
5301 from a component clause. */
5303 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5304 && TYPE_MODE (gnu_field_type) == BLKmode
5305 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
5306 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
5307 && (packed == 1
5308 || (gnu_size
5309 && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))
5310 || (Present (Component_Clause (gnat_field)) && gnu_size != 0)))
5312 /* See what the alternate type and size would be. */
5313 tree gnu_packable_type = make_packable_type (gnu_field_type);
5315 bool has_byte_aligned_clause
5316 = Present (Component_Clause (gnat_field))
5317 && (UI_To_Int (Component_Bit_Offset (gnat_field))
5318 % BITS_PER_UNIT == 0);
5320 /* Compute whether we should avoid the substitution. */
5321 int reject =
5322 /* There is no point substituting if there is no change. */
5323 (gnu_packable_type == gnu_field_type
5325 /* ... nor when the field is known to be byte aligned and not to
5326 share a byte with another field. */
5327 (has_byte_aligned_clause
5328 && value_factor_p (gnu_size, BITS_PER_UNIT))
5330 /* The size of an aliased field must be an exact multiple of the
5331 type's alignment, which the substitution might increase. Reject
5332 substitutions that would so invalidate a component clause when the
5333 specified position is byte aligned, as the change would have no
5334 real benefit from the packing standpoint anyway. */
5335 (Is_Aliased (gnat_field)
5336 && has_byte_aligned_clause
5337 && ! value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)))
5340 /* Substitute unless told otherwise. */
5341 if (!reject)
5343 gnu_field_type = gnu_packable_type;
5345 if (gnu_size == 0)
5346 gnu_size = rm_size (gnu_field_type);
5350 /* If we are packing the record and the field is BLKmode, round the
5351 size up to a byte boundary. */
5352 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
5353 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
5355 if (Present (Component_Clause (gnat_field)))
5357 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
5358 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
5359 gnat_field, FIELD_DECL, false, true);
5361 /* Ensure the position does not overlap with the parent subtype,
5362 if there is one. */
5363 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
5365 tree gnu_parent
5366 = gnat_to_gnu_type (Parent_Subtype
5367 (Underlying_Type (Scope (gnat_field))));
5369 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
5370 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
5372 post_error_ne_tree
5373 ("offset of& must be beyond parent{, minimum allowed is ^}",
5374 First_Bit (Component_Clause (gnat_field)), gnat_field,
5375 TYPE_SIZE_UNIT (gnu_parent));
5379 /* If this field needs strict alignment, ensure the record is
5380 sufficiently aligned and that that position and size are
5381 consistent with the alignment. */
5382 if (needs_strict_alignment)
5384 tree gnu_rounded_size = round_up (rm_size (gnu_field_type),
5385 TYPE_ALIGN (gnu_field_type));
5387 TYPE_ALIGN (gnu_record_type)
5388 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
5390 /* If Atomic, the size must match exactly that of the field. */
5391 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
5392 && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
5394 post_error_ne_tree
5395 ("atomic field& must be natural size of type{ (^)}",
5396 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5397 TYPE_SIZE (gnu_field_type));
5399 gnu_size = NULL_TREE;
5402 /* If Aliased, the size must match exactly the rounded size. We
5403 used to be more accommodating here and accept greater sizes, but
5404 fully supporting this case on big-endian platforms would require
5405 switching to a more involved layout for the field. */
5406 else if (Is_Aliased (gnat_field)
5407 && gnu_size
5408 && ! operand_equal_p (gnu_size, gnu_rounded_size, 0))
5410 post_error_ne_tree
5411 ("size of aliased field& must be ^ bits",
5412 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5413 gnu_rounded_size);
5414 gnu_size = NULL_TREE;
5417 if (!integer_zerop (size_binop
5418 (TRUNC_MOD_EXPR, gnu_pos,
5419 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
5421 if (Is_Aliased (gnat_field))
5422 post_error_ne_num
5423 ("position of aliased field& must be multiple of ^ bits",
5424 First_Bit (Component_Clause (gnat_field)), gnat_field,
5425 TYPE_ALIGN (gnu_field_type));
5427 else if (Treat_As_Volatile (gnat_field))
5428 post_error_ne_num
5429 ("position of volatile field& must be multiple of ^ bits",
5430 First_Bit (Component_Clause (gnat_field)), gnat_field,
5431 TYPE_ALIGN (gnu_field_type));
5433 else if (Strict_Alignment (Etype (gnat_field)))
5434 post_error_ne_num
5435 ("position of & with aliased or tagged components not multiple of ^ bits",
5436 First_Bit (Component_Clause (gnat_field)), gnat_field,
5437 TYPE_ALIGN (gnu_field_type));
5438 else
5439 gcc_unreachable ();
5441 gnu_pos = NULL_TREE;
5445 if (Is_Atomic (gnat_field))
5446 check_ok_for_atomic (gnu_field_type, gnat_field, false);
5449 /* If the record has rep clauses and this is the tag field, make a rep
5450 clause for it as well. */
5451 else if (Has_Specified_Layout (Scope (gnat_field))
5452 && Chars (gnat_field) == Name_uTag)
5454 gnu_pos = bitsize_zero_node;
5455 gnu_size = TYPE_SIZE (gnu_field_type);
5458 /* We need to make the size the maximum for the type if it is
5459 self-referential and an unconstrained type. In that case, we can't
5460 pack the field since we can't make a copy to align it. */
5461 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5462 && !gnu_size
5463 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
5464 && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
5466 gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
5467 packed = 0;
5470 /* If no size is specified (or if there was an error), don't specify a
5471 position. */
5472 if (!gnu_size)
5473 gnu_pos = NULL_TREE;
5474 else
5476 /* If the field's type is justified modular, we would need to remove
5477 the wrapper to (better) meet the layout requirements. However we
5478 can do so only if the field is not aliased to preserve the unique
5479 layout and if the prescribed size is not greater than that of the
5480 packed array to preserve the justification. */
5481 if (!needs_strict_alignment
5482 && TREE_CODE (gnu_field_type) == RECORD_TYPE
5483 && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
5484 && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
5485 <= 0)
5486 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5488 gnu_field_type
5489 = make_type_from_size (gnu_field_type, gnu_size,
5490 Has_Biased_Representation (gnat_field));
5491 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
5492 "PAD", false, definition, true);
5495 gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
5496 || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
5498 /* Now create the decl for the field. */
5499 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
5500 packed, gnu_size, gnu_pos,
5501 Is_Aliased (gnat_field));
5502 Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
5503 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
5505 if (Ekind (gnat_field) == E_Discriminant)
5506 DECL_DISCRIMINANT_NUMBER (gnu_field)
5507 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
5509 return gnu_field;
5512 /* Return true if TYPE is a type with variable size, a padding type with a
5513 field of variable size or is a record that has a field such a field. */
5515 static bool
5516 is_variable_size (tree type)
5518 tree field;
5520 /* We need not be concerned about this at all if we don't have
5521 strict alignment. */
5522 if (!STRICT_ALIGNMENT)
5523 return false;
5524 else if (!TREE_CONSTANT (TYPE_SIZE (type)))
5525 return true;
5526 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
5527 && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
5528 return true;
5529 else if (TREE_CODE (type) != RECORD_TYPE
5530 && TREE_CODE (type) != UNION_TYPE
5531 && TREE_CODE (type) != QUAL_UNION_TYPE)
5532 return false;
5534 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
5535 if (is_variable_size (TREE_TYPE (field)))
5536 return true;
5538 return false;
5541 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5542 of GCC trees for fields that are in the record and have already been
5543 processed. When called from gnat_to_gnu_entity during the processing of a
5544 record type definition, the GCC nodes for the discriminants will be on
5545 the chain. The other calls to this function are recursive calls from
5546 itself for the Component_List of a variant and the chain is empty.
5548 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is
5549 for a record type with "pragma component_alignment (storage_unit)".
5551 DEFINITION is true if we are defining this record.
5553 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5554 with a rep clause is to be added. If it is nonzero, that is all that
5555 should be done with such fields.
5557 CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
5558 laying out the record. This means the alignment only serves to force fields
5559 to be bitfields, but not require the record to be that aligned. This is
5560 used for variants.
5562 ALL_REP, if true, means a rep clause was found for all the fields. This
5563 simplifies the logic since we know we're not in the mixed case.
5565 DEFER_DEBUG, if true, means that the debugging routines should not be
5566 called when finishing constructing the record type.
5568 UNCHECKED_UNION, if tree, means that we are building a type for a record
5569 with a Pragma Unchecked_Union.
5571 The processing of the component list fills in the chain with all of the
5572 fields of the record and then the record type is finished. */
5574 static void
5575 components_to_record (tree gnu_record_type, Node_Id component_list,
5576 tree gnu_field_list, int packed, bool definition,
5577 tree *p_gnu_rep_list, bool cancel_alignment,
5578 bool all_rep, bool defer_debug, bool unchecked_union)
5580 Node_Id component_decl;
5581 Entity_Id gnat_field;
5582 Node_Id variant_part;
5583 tree gnu_our_rep_list = NULL_TREE;
5584 tree gnu_field, gnu_last;
5585 bool layout_with_rep = false;
5586 bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
5588 /* For each variable within each component declaration create a GCC field
5589 and add it to the list, skipping any pragmas in the list. */
5591 if (Present (Component_Items (component_list)))
5592 for (component_decl = First_Non_Pragma (Component_Items (component_list));
5593 Present (component_decl);
5594 component_decl = Next_Non_Pragma (component_decl))
5596 gnat_field = Defining_Entity (component_decl);
5598 if (Chars (gnat_field) == Name_uParent)
5599 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
5600 else
5602 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
5603 packed, definition);
5605 /* If this is the _Tag field, put it before any discriminants,
5606 instead of after them as is the case for all other fields.
5607 Ignore field of void type if only annotating. */
5608 if (Chars (gnat_field) == Name_uTag)
5609 gnu_field_list = chainon (gnu_field_list, gnu_field);
5610 else
5612 TREE_CHAIN (gnu_field) = gnu_field_list;
5613 gnu_field_list = gnu_field;
5617 save_gnu_tree (gnat_field, gnu_field, false);
5620 /* At the end of the component list there may be a variant part. */
5621 variant_part = Variant_Part (component_list);
5623 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5624 mutually exclusive and should go in the same memory. To do this we need
5625 to treat each variant as a record whose elements are created from the
5626 component list for the variant. So here we create the records from the
5627 lists for the variants and put them all into the QUAL_UNION_TYPE.
5628 If this is an Unchecked_Union, we make a UNION_TYPE instead or
5629 use GNU_RECORD_TYPE if there are no fields so far. */
5630 if (Present (variant_part))
5632 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
5633 Node_Id variant;
5634 tree gnu_name = TYPE_NAME (gnu_record_type);
5635 tree gnu_var_name
5636 = concat_id_with_name (get_identifier (Get_Name_String
5637 (Chars (Name (variant_part)))),
5638 "XVN");
5639 tree gnu_union_type;
5640 tree gnu_union_name;
5641 tree gnu_union_field;
5642 tree gnu_variant_list = NULL_TREE;
5644 if (TREE_CODE (gnu_name) == TYPE_DECL)
5645 gnu_name = DECL_NAME (gnu_name);
5647 gnu_union_name = concat_id_with_name (gnu_name,
5648 IDENTIFIER_POINTER (gnu_var_name));
5650 if (!gnu_field_list && TREE_CODE (gnu_record_type) == UNION_TYPE)
5651 gnu_union_type = gnu_record_type;
5652 else
5655 gnu_union_type
5656 = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
5658 TYPE_NAME (gnu_union_type) = gnu_union_name;
5659 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
5662 for (variant = First_Non_Pragma (Variants (variant_part));
5663 Present (variant);
5664 variant = Next_Non_Pragma (variant))
5666 tree gnu_variant_type = make_node (RECORD_TYPE);
5667 tree gnu_inner_name;
5668 tree gnu_qual;
5670 Get_Variant_Encoding (variant);
5671 gnu_inner_name = get_identifier (Name_Buffer);
5672 TYPE_NAME (gnu_variant_type)
5673 = concat_id_with_name (gnu_union_name,
5674 IDENTIFIER_POINTER (gnu_inner_name));
5676 /* Set the alignment of the inner type in case we need to make
5677 inner objects into bitfields, but then clear it out
5678 so the record actually gets only the alignment required. */
5679 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
5680 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
5682 /* Similarly, if the outer record has a size specified and all fields
5683 have record rep clauses, we can propagate the size into the
5684 variant part. */
5685 if (all_rep_and_size)
5687 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
5688 TYPE_SIZE_UNIT (gnu_variant_type)
5689 = TYPE_SIZE_UNIT (gnu_record_type);
5692 /* Create the record for the variant. Note that we defer emitting
5693 debug info for it until after we are sure to actually use it. */
5694 components_to_record (gnu_variant_type, Component_List (variant),
5695 NULL_TREE, packed, definition,
5696 &gnu_our_rep_list, !all_rep_and_size, all_rep,
5697 true, unchecked_union);
5699 gnu_qual = choices_to_gnu (gnu_discriminant,
5700 Discrete_Choices (variant));
5702 Set_Present_Expr (variant, annotate_value (gnu_qual));
5704 /* If this is an Unchecked_Union and we have exactly one field,
5705 use that field here. */
5706 if (unchecked_union && TYPE_FIELDS (gnu_variant_type)
5707 && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
5708 gnu_field = TYPE_FIELDS (gnu_variant_type);
5709 else
5711 /* Emit debug info for the record. We used to throw away
5712 empty records but we no longer do that because we need
5713 them to generate complete debug info for the variant;
5714 otherwise, the union type definition will be lacking
5715 the fields associated with these empty variants. */
5716 write_record_type_debug_info (gnu_variant_type);
5718 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
5719 gnu_union_type, 0,
5720 (all_rep_and_size
5721 ? TYPE_SIZE (gnu_record_type)
5722 : 0),
5723 (all_rep_and_size
5724 ? bitsize_zero_node : 0),
5727 DECL_INTERNAL_P (gnu_field) = 1;
5729 if (!unchecked_union)
5730 DECL_QUALIFIER (gnu_field) = gnu_qual;
5733 TREE_CHAIN (gnu_field) = gnu_variant_list;
5734 gnu_variant_list = gnu_field;
5737 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
5738 if (gnu_variant_list)
5740 if (all_rep_and_size)
5742 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
5743 TYPE_SIZE_UNIT (gnu_union_type)
5744 = TYPE_SIZE_UNIT (gnu_record_type);
5747 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
5748 all_rep_and_size, false);
5750 /* If GNU_UNION_TYPE is our record type, it means we must have an
5751 Unchecked_Union with no fields. Verify that and, if so, just
5752 return. */
5753 if (gnu_union_type == gnu_record_type)
5755 gcc_assert (!gnu_field_list && unchecked_union);
5756 return;
5759 gnu_union_field
5760 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
5761 packed,
5762 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
5763 all_rep ? bitsize_zero_node : 0, 0);
5765 DECL_INTERNAL_P (gnu_union_field) = 1;
5766 TREE_CHAIN (gnu_union_field) = gnu_field_list;
5767 gnu_field_list = gnu_union_field;
5771 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
5772 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
5773 in a separate pass since we want to handle the discriminants but can't
5774 play with them until we've used them in debugging data above.
5776 ??? Note: if we then reorder them, debugging information will be wrong,
5777 but there's nothing that can be done about this at the moment. */
5779 for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
5781 if (DECL_FIELD_OFFSET (gnu_field))
5783 tree gnu_next = TREE_CHAIN (gnu_field);
5785 if (!gnu_last)
5786 gnu_field_list = gnu_next;
5787 else
5788 TREE_CHAIN (gnu_last) = gnu_next;
5790 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
5791 gnu_our_rep_list = gnu_field;
5792 gnu_field = gnu_next;
5794 else
5796 gnu_last = gnu_field;
5797 gnu_field = TREE_CHAIN (gnu_field);
5801 /* If we have any items in our rep'ed field list, it is not the case that all
5802 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
5803 set it and ignore the items. */
5804 if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
5805 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
5806 else if (gnu_our_rep_list)
5808 /* Otherwise, sort the fields by bit position and put them into their
5809 own record if we have any fields without rep clauses. */
5810 tree gnu_rep_type
5811 = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
5812 int len = list_length (gnu_our_rep_list);
5813 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
5814 int i;
5816 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
5817 gnu_field = TREE_CHAIN (gnu_field), i++)
5818 gnu_arr[i] = gnu_field;
5820 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
5822 /* Put the fields in the list in order of increasing position, which
5823 means we start from the end. */
5824 gnu_our_rep_list = NULL_TREE;
5825 for (i = len - 1; i >= 0; i--)
5827 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
5828 gnu_our_rep_list = gnu_arr[i];
5829 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
5832 if (gnu_field_list)
5834 finish_record_type (gnu_rep_type, gnu_our_rep_list, true, false);
5835 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
5836 gnu_record_type, 0, 0, 0, 1);
5837 DECL_INTERNAL_P (gnu_field) = 1;
5838 gnu_field_list = chainon (gnu_field_list, gnu_field);
5840 else
5842 layout_with_rep = true;
5843 gnu_field_list = nreverse (gnu_our_rep_list);
5847 if (cancel_alignment)
5848 TYPE_ALIGN (gnu_record_type) = 0;
5850 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
5851 layout_with_rep, defer_debug);
5854 /* Called via qsort from the above. Returns -1, 1, depending on the
5855 bit positions and ordinals of the two fields. Use DECL_UID to ensure
5856 a stable sort. */
5858 static int
5859 compare_field_bitpos (const PTR rt1, const PTR rt2)
5861 tree *t1 = (tree *) rt1;
5862 tree *t2 = (tree *) rt2;
5864 if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
5865 return DECL_UID (*t1) < DECL_UID (*t2) ? -1 : 1;
5866 else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
5867 return -1;
5868 else
5869 return 1;
5872 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
5873 placed into an Esize, Component_Bit_Offset, or Component_Size value
5874 in the GNAT tree. */
5876 static Uint
5877 annotate_value (tree gnu_size)
5879 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
5880 TCode tcode;
5881 Node_Ref_Or_Val ops[3], ret;
5882 int i;
5883 int size;
5884 struct tree_int_map **h = NULL;
5886 /* See if we've already saved the value for this node. */
5887 if (EXPR_P (gnu_size))
5889 struct tree_int_map in;
5890 if (!annotate_value_cache)
5891 annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
5892 tree_int_map_eq, 0);
5893 in.base.from = gnu_size;
5894 h = (struct tree_int_map **)
5895 htab_find_slot (annotate_value_cache, &in, INSERT);
5897 if (*h)
5898 return (Node_Ref_Or_Val) (*h)->to;
5901 /* If we do not return inside this switch, TCODE will be set to the
5902 code to use for a Create_Node operand and LEN (set above) will be
5903 the number of recursive calls for us to make. */
5905 switch (TREE_CODE (gnu_size))
5907 case INTEGER_CST:
5908 if (TREE_OVERFLOW (gnu_size))
5909 return No_Uint;
5911 /* This may have come from a conversion from some smaller type,
5912 so ensure this is in bitsizetype. */
5913 gnu_size = convert (bitsizetype, gnu_size);
5915 /* For negative values, use NEGATE_EXPR of the supplied value. */
5916 if (tree_int_cst_sgn (gnu_size) < 0)
5918 /* The ridiculous code below is to handle the case of the largest
5919 negative integer. */
5920 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
5921 bool adjust = false;
5922 tree temp;
5924 if (TREE_OVERFLOW (negative_size))
5926 negative_size
5927 = size_binop (MINUS_EXPR, bitsize_zero_node,
5928 size_binop (PLUS_EXPR, gnu_size,
5929 bitsize_one_node));
5930 adjust = true;
5933 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
5934 if (adjust)
5935 temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
5937 return annotate_value (temp);
5940 if (!host_integerp (gnu_size, 1))
5941 return No_Uint;
5943 size = tree_low_cst (gnu_size, 1);
5945 /* This peculiar test is to make sure that the size fits in an int
5946 on machines where HOST_WIDE_INT is not "int". */
5947 if (tree_low_cst (gnu_size, 1) == size)
5948 return UI_From_Int (size);
5949 else
5950 return No_Uint;
5952 case COMPONENT_REF:
5953 /* The only case we handle here is a simple discriminant reference. */
5954 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
5955 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
5956 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
5957 return Create_Node (Discrim_Val,
5958 annotate_value (DECL_DISCRIMINANT_NUMBER
5959 (TREE_OPERAND (gnu_size, 1))),
5960 No_Uint, No_Uint);
5961 else
5962 return No_Uint;
5964 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
5965 return annotate_value (TREE_OPERAND (gnu_size, 0));
5967 /* Now just list the operations we handle. */
5968 case COND_EXPR: tcode = Cond_Expr; break;
5969 case PLUS_EXPR: tcode = Plus_Expr; break;
5970 case MINUS_EXPR: tcode = Minus_Expr; break;
5971 case MULT_EXPR: tcode = Mult_Expr; break;
5972 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
5973 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
5974 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
5975 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
5976 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
5977 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
5978 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
5979 case NEGATE_EXPR: tcode = Negate_Expr; break;
5980 case MIN_EXPR: tcode = Min_Expr; break;
5981 case MAX_EXPR: tcode = Max_Expr; break;
5982 case ABS_EXPR: tcode = Abs_Expr; break;
5983 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
5984 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
5985 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
5986 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
5987 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
5988 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
5989 case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
5990 case LT_EXPR: tcode = Lt_Expr; break;
5991 case LE_EXPR: tcode = Le_Expr; break;
5992 case GT_EXPR: tcode = Gt_Expr; break;
5993 case GE_EXPR: tcode = Ge_Expr; break;
5994 case EQ_EXPR: tcode = Eq_Expr; break;
5995 case NE_EXPR: tcode = Ne_Expr; break;
5997 default:
5998 return No_Uint;
6001 /* Now get each of the operands that's relevant for this code. If any
6002 cannot be expressed as a repinfo node, say we can't. */
6003 for (i = 0; i < 3; i++)
6004 ops[i] = No_Uint;
6006 for (i = 0; i < len; i++)
6008 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
6009 if (ops[i] == No_Uint)
6010 return No_Uint;
6013 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
6015 /* Save the result in the cache. */
6016 if (h)
6018 *h = ggc_alloc (sizeof (struct tree_int_map));
6019 (*h)->from = gnu_size;
6020 (*h)->to = ret;
6023 return ret;
6026 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
6027 GCC type, set Component_Bit_Offset and Esize to the position and size
6028 used by Gigi. */
6030 static void
6031 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
6033 tree gnu_list;
6034 tree gnu_entry;
6035 Entity_Id gnat_field;
6037 /* We operate by first making a list of all fields and their positions
6038 (we can get the sizes easily at any time) by a recursive call
6039 and then update all the sizes into the tree. */
6040 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
6041 size_zero_node, bitsize_zero_node,
6042 BIGGEST_ALIGNMENT);
6044 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
6045 gnat_field = Next_Entity (gnat_field))
6046 if ((Ekind (gnat_field) == E_Component
6047 || (Ekind (gnat_field) == E_Discriminant
6048 && !Is_Unchecked_Union (Scope (gnat_field)))))
6050 tree parent_offset = bitsize_zero_node;
6052 gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
6053 gnu_list);
6055 if (gnu_entry)
6057 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
6059 /* In this mode the tag and parent components have not been
6060 generated, so we add the appropriate offset to each
6061 component. For a component appearing in the current
6062 extension, the offset is the size of the parent. */
6063 if (Is_Derived_Type (gnat_entity)
6064 && Original_Record_Component (gnat_field) == gnat_field)
6065 parent_offset
6066 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
6067 bitsizetype);
6068 else
6069 parent_offset = bitsize_int (POINTER_SIZE);
6072 Set_Component_Bit_Offset
6073 (gnat_field,
6074 annotate_value
6075 (size_binop (PLUS_EXPR,
6076 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
6077 TREE_VALUE (TREE_VALUE
6078 (TREE_VALUE (gnu_entry)))),
6079 parent_offset)));
6081 Set_Esize (gnat_field,
6082 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
6084 else if (Is_Tagged_Type (gnat_entity)
6085 && Is_Derived_Type (gnat_entity))
6087 /* If there is no gnu_entry, this is an inherited component whose
6088 position is the same as in the parent type. */
6089 Set_Component_Bit_Offset
6090 (gnat_field,
6091 Component_Bit_Offset (Original_Record_Component (gnat_field)));
6092 Set_Esize (gnat_field,
6093 Esize (Original_Record_Component (gnat_field)));
6098 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
6099 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
6100 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
6101 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
6102 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
6103 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
6104 so far. */
6106 static tree
6107 compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
6108 tree gnu_bitpos, unsigned int offset_align)
6110 tree gnu_field;
6111 tree gnu_result = gnu_list;
6113 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
6114 gnu_field = TREE_CHAIN (gnu_field))
6116 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
6117 DECL_FIELD_BIT_OFFSET (gnu_field));
6118 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
6119 DECL_FIELD_OFFSET (gnu_field));
6120 unsigned int our_offset_align
6121 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
6123 gnu_result
6124 = tree_cons (gnu_field,
6125 tree_cons (gnu_our_offset,
6126 tree_cons (size_int (our_offset_align),
6127 gnu_our_bitpos, NULL_TREE),
6128 NULL_TREE),
6129 gnu_result);
6131 if (DECL_INTERNAL_P (gnu_field))
6132 gnu_result
6133 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
6134 gnu_our_offset, gnu_our_bitpos,
6135 our_offset_align);
6138 return gnu_result;
6141 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
6142 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
6143 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
6144 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
6145 for the size of a field. COMPONENT_P is true if we are being called
6146 to process the Component_Size of GNAT_OBJECT. This is used for error
6147 message handling and to indicate to use the object size of GNU_TYPE.
6148 ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
6149 it means that a size of zero should be treated as an unspecified size. */
6151 static tree
6152 validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
6153 enum tree_code kind, bool component_p, bool zero_ok)
6155 Node_Id gnat_error_node;
6156 tree type_size
6157 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
6158 tree size;
6160 /* Find the node to use for errors. */
6161 if ((Ekind (gnat_object) == E_Component
6162 || Ekind (gnat_object) == E_Discriminant)
6163 && Present (Component_Clause (gnat_object)))
6164 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
6165 else if (Present (Size_Clause (gnat_object)))
6166 gnat_error_node = Expression (Size_Clause (gnat_object));
6167 else
6168 gnat_error_node = gnat_object;
6170 /* Return 0 if no size was specified, either because Esize was not Present or
6171 the specified size was zero. */
6172 if (No (uint_size) || uint_size == No_Uint)
6173 return NULL_TREE;
6175 /* Get the size as a tree. Give an error if a size was specified, but cannot
6176 be represented as in sizetype. */
6177 size = UI_To_gnu (uint_size, bitsizetype);
6178 if (TREE_OVERFLOW (size))
6180 post_error_ne (component_p ? "component size of & is too large"
6181 : "size of & is too large",
6182 gnat_error_node, gnat_object);
6183 return NULL_TREE;
6186 /* Ignore a negative size since that corresponds to our back-annotation.
6187 Also ignore a zero size unless a size clause exists. */
6188 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
6189 return NULL_TREE;
6191 /* The size of objects is always a multiple of a byte. */
6192 if (kind == VAR_DECL
6193 && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
6195 if (component_p)
6196 post_error_ne ("component size for& is not a multiple of Storage_Unit",
6197 gnat_error_node, gnat_object);
6198 else
6199 post_error_ne ("size for& is not a multiple of Storage_Unit",
6200 gnat_error_node, gnat_object);
6201 return NULL_TREE;
6204 /* If this is an integral type or a packed array type, the front-end has
6205 verified the size, so we need not do it here (which would entail
6206 checking against the bounds). However, if this is an aliased object, it
6207 may not be smaller than the type of the object. */
6208 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
6209 && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
6210 return size;
6212 /* If the object is a record that contains a template, add the size of
6213 the template to the specified size. */
6214 if (TREE_CODE (gnu_type) == RECORD_TYPE
6215 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6216 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
6218 /* Modify the size of the type to be that of the maximum size if it has a
6219 discriminant or the size of a thin pointer if this is a fat pointer. */
6220 if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
6221 type_size = max_size (type_size, true);
6222 else if (TYPE_FAT_POINTER_P (gnu_type))
6223 type_size = bitsize_int (POINTER_SIZE);
6225 /* If this is an access type, the minimum size is that given by the smallest
6226 integral mode that's valid for pointers. */
6227 if (TREE_CODE (gnu_type) == POINTER_TYPE)
6229 enum machine_mode p_mode;
6231 for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
6232 !targetm.valid_pointer_mode (p_mode);
6233 p_mode = GET_MODE_WIDER_MODE (p_mode))
6236 type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
6239 /* If the size of the object is a constant, the new size must not be
6240 smaller. */
6241 if (TREE_CODE (type_size) != INTEGER_CST
6242 || TREE_OVERFLOW (type_size)
6243 || tree_int_cst_lt (size, type_size))
6245 if (component_p)
6246 post_error_ne_tree
6247 ("component size for& too small{, minimum allowed is ^}",
6248 gnat_error_node, gnat_object, type_size);
6249 else
6250 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
6251 gnat_error_node, gnat_object, type_size);
6253 if (kind == VAR_DECL && !component_p
6254 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
6255 && !tree_int_cst_lt (size, rm_size (gnu_type)))
6256 post_error_ne_tree_2
6257 ("\\size of ^ is not a multiple of alignment (^ bits)",
6258 gnat_error_node, gnat_object, rm_size (gnu_type),
6259 TYPE_ALIGN (gnu_type));
6261 else if (INTEGRAL_TYPE_P (gnu_type))
6262 post_error_ne ("\\size would be legal if & were not aliased!",
6263 gnat_error_node, gnat_object);
6265 return NULL_TREE;
6268 return size;
6271 /* Similarly, but both validate and process a value of RM_Size. This
6272 routine is only called for types. */
6274 static void
6275 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
6277 /* Only give an error if a Value_Size clause was explicitly given.
6278 Otherwise, we'd be duplicating an error on the Size clause. */
6279 Node_Id gnat_attr_node
6280 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
6281 tree old_size = rm_size (gnu_type);
6282 tree size;
6284 /* Get the size as a tree. Do nothing if none was specified, either
6285 because RM_Size was not Present or if the specified size was zero.
6286 Give an error if a size was specified, but cannot be represented as
6287 in sizetype. */
6288 if (No (uint_size) || uint_size == No_Uint)
6289 return;
6291 size = UI_To_gnu (uint_size, bitsizetype);
6292 if (TREE_OVERFLOW (size))
6294 if (Present (gnat_attr_node))
6295 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
6296 gnat_entity);
6298 return;
6301 /* Ignore a negative size since that corresponds to our back-annotation.
6302 Also ignore a zero size unless a size clause exists, a Value_Size
6303 clause exists, or this is an integer type, in which case the
6304 front end will have always set it. */
6305 else if (tree_int_cst_sgn (size) < 0
6306 || (integer_zerop (size) && No (gnat_attr_node)
6307 && !Has_Size_Clause (gnat_entity)
6308 && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
6309 return;
6311 /* If the old size is self-referential, get the maximum size. */
6312 if (CONTAINS_PLACEHOLDER_P (old_size))
6313 old_size = max_size (old_size, true);
6315 /* If the size of the object is a constant, the new size must not be
6316 smaller (the front end checks this for scalar types). */
6317 if (TREE_CODE (old_size) != INTEGER_CST
6318 || TREE_OVERFLOW (old_size)
6319 || (AGGREGATE_TYPE_P (gnu_type)
6320 && tree_int_cst_lt (size, old_size)))
6322 if (Present (gnat_attr_node))
6323 post_error_ne_tree
6324 ("Value_Size for& too small{, minimum allowed is ^}",
6325 gnat_attr_node, gnat_entity, old_size);
6327 return;
6330 /* Otherwise, set the RM_Size. */
6331 if (TREE_CODE (gnu_type) == INTEGER_TYPE
6332 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
6333 TYPE_RM_SIZE_NUM (gnu_type) = size;
6334 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
6335 TYPE_RM_SIZE_NUM (gnu_type) = size;
6336 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6337 || TREE_CODE (gnu_type) == UNION_TYPE
6338 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6339 && !TYPE_IS_FAT_POINTER_P (gnu_type))
6340 SET_TYPE_ADA_SIZE (gnu_type, size);
6343 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
6344 If TYPE is the best type, return it. Otherwise, make a new type. We
6345 only support new integral and pointer types. BIASED_P is nonzero if
6346 we are making a biased type. */
6348 static tree
6349 make_type_from_size (tree type, tree size_tree, bool biased_p)
6351 tree new_type;
6352 unsigned HOST_WIDE_INT size;
6353 bool unsigned_p;
6355 /* If size indicates an error, just return TYPE to avoid propagating the
6356 error. Likewise if it's too large to represent. */
6357 if (!size_tree || !host_integerp (size_tree, 1))
6358 return type;
6360 size = tree_low_cst (size_tree, 1);
6361 switch (TREE_CODE (type))
6363 case INTEGER_TYPE:
6364 case ENUMERAL_TYPE:
6365 /* Only do something if the type is not already the proper size and is
6366 not a packed array type. */
6367 if (TYPE_PACKED_ARRAY_TYPE_P (type)
6368 || (TYPE_PRECISION (type) == size
6369 && biased_p == (TREE_CODE (type) == INTEGER_CST
6370 && TYPE_BIASED_REPRESENTATION_P (type))))
6371 break;
6373 biased_p |= (TREE_CODE (type) == INTEGER_TYPE
6374 && TYPE_BIASED_REPRESENTATION_P (type));
6375 unsigned_p = TYPE_UNSIGNED (type) || biased_p;
6377 size = MIN (size, LONG_LONG_TYPE_SIZE);
6378 new_type
6379 = unsigned_p ? make_unsigned_type (size) : make_signed_type (size);
6380 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
6381 TYPE_MIN_VALUE (new_type)
6382 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
6383 TYPE_MAX_VALUE (new_type)
6384 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
6385 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
6386 TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
6387 return new_type;
6389 case RECORD_TYPE:
6390 /* Do something if this is a fat pointer, in which case we
6391 may need to return the thin pointer. */
6392 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
6393 return
6394 build_pointer_type
6395 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
6396 break;
6398 case POINTER_TYPE:
6399 /* Only do something if this is a thin pointer, in which case we
6400 may need to return the fat pointer. */
6401 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
6402 return
6403 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
6405 break;
6407 default:
6408 break;
6411 return type;
6414 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6415 a type or object whose present alignment is ALIGN. If this alignment is
6416 valid, return it. Otherwise, give an error and return ALIGN. */
6418 static unsigned int
6419 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
6421 Node_Id gnat_error_node = gnat_entity;
6422 unsigned int new_align;
6424 #ifndef MAX_OFILE_ALIGNMENT
6425 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
6426 #endif
6428 if (Present (Alignment_Clause (gnat_entity)))
6429 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
6431 /* Don't worry about checking alignment if alignment was not specified
6432 by the source program and we already posted an error for this entity. */
6434 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
6435 return align;
6437 /* Within GCC, an alignment is an integer, so we must make sure a
6438 value is specified that fits in that range. Also, alignments of
6439 more than MAX_OFILE_ALIGNMENT can't be supported. */
6441 if (! UI_Is_In_Int_Range (alignment)
6442 || ((new_align = UI_To_Int (alignment))
6443 > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT))
6444 post_error_ne_num ("largest supported alignment for& is ^",
6445 gnat_error_node, gnat_entity,
6446 MAX_OFILE_ALIGNMENT / BITS_PER_UNIT);
6447 else if (!(Present (Alignment_Clause (gnat_entity))
6448 && From_At_Mod (Alignment_Clause (gnat_entity)))
6449 && new_align * BITS_PER_UNIT < align)
6450 post_error_ne_num ("alignment for& must be at least ^",
6451 gnat_error_node, gnat_entity,
6452 align / BITS_PER_UNIT);
6453 else
6454 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
6456 return align;
6459 /* Verify that OBJECT, a type or decl, is something we can implement
6460 atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
6461 if we require atomic components. */
6463 static void
6464 check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
6466 Node_Id gnat_error_point = gnat_entity;
6467 Node_Id gnat_node;
6468 enum machine_mode mode;
6469 unsigned int align;
6470 tree size;
6472 /* There are three case of what OBJECT can be. It can be a type, in which
6473 case we take the size, alignment and mode from the type. It can be a
6474 declaration that was indirect, in which case the relevant values are
6475 that of the type being pointed to, or it can be a normal declaration,
6476 in which case the values are of the decl. The code below assumes that
6477 OBJECT is either a type or a decl. */
6478 if (TYPE_P (object))
6480 mode = TYPE_MODE (object);
6481 align = TYPE_ALIGN (object);
6482 size = TYPE_SIZE (object);
6484 else if (DECL_BY_REF_P (object))
6486 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
6487 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
6488 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
6490 else
6492 mode = DECL_MODE (object);
6493 align = DECL_ALIGN (object);
6494 size = DECL_SIZE (object);
6497 /* Consider all floating-point types atomic and any types that that are
6498 represented by integers no wider than a machine word. */
6499 if (GET_MODE_CLASS (mode) == MODE_FLOAT
6500 || ((GET_MODE_CLASS (mode) == MODE_INT
6501 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
6502 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
6503 return;
6505 /* For the moment, also allow anything that has an alignment equal
6506 to its size and which is smaller than a word. */
6507 if (size && TREE_CODE (size) == INTEGER_CST
6508 && compare_tree_int (size, align) == 0
6509 && align <= BITS_PER_WORD)
6510 return;
6512 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
6513 gnat_node = Next_Rep_Item (gnat_node))
6515 if (!comp_p && Nkind (gnat_node) == N_Pragma
6516 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
6517 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6518 else if (comp_p && Nkind (gnat_node) == N_Pragma
6519 && (Get_Pragma_Id (Chars (gnat_node))
6520 == Pragma_Atomic_Components))
6521 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6524 if (comp_p)
6525 post_error_ne ("atomic access to component of & cannot be guaranteed",
6526 gnat_error_point, gnat_entity);
6527 else
6528 post_error_ne ("atomic access to & cannot be guaranteed",
6529 gnat_error_point, gnat_entity);
6532 /* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
6533 have compatible signatures so that a call using one type may be safely
6534 issued if the actual target function type is the other. Return 1 if it is
6535 the case, 0 otherwise, and post errors on the incompatibilities.
6537 This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
6538 that calls to the subprogram will have arguments suitable for the later
6539 underlying builtin expansion. */
6541 static int
6542 compatible_signatures_p (tree ftype1, tree ftype2)
6544 /* As of now, we only perform very trivial tests and consider it's the
6545 programmer's responsibility to ensure the type correctness in the Ada
6546 declaration, as in the regular Import cases.
6548 Mismatches typically result in either error messages from the builtin
6549 expander, internal compiler errors, or in a real call sequence. This
6550 should be refined to issue diagnostics helping error detection and
6551 correction. */
6553 /* Almost fake test, ensuring a use of each argument. */
6554 if (ftype1 == ftype2)
6555 return 1;
6557 return 1;
6560 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type
6561 with all size expressions that contain F updated by replacing F with R.
6562 This is identical to GCC's substitute_in_type except that it knows about
6563 TYPE_INDEX_TYPE. If F is NULL_TREE, always make a new RECORD_TYPE, even if
6564 nothing has changed. */
6566 tree
6567 gnat_substitute_in_type (tree t, tree f, tree r)
6569 tree new = t;
6570 tree tem;
6572 switch (TREE_CODE (t))
6574 case INTEGER_TYPE:
6575 case ENUMERAL_TYPE:
6576 case BOOLEAN_TYPE:
6577 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6578 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6580 tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
6581 tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
6583 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6584 return t;
6586 new = build_range_type (TREE_TYPE (t), low, high);
6587 if (TYPE_INDEX_TYPE (t))
6588 SET_TYPE_INDEX_TYPE
6589 (new, gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
6590 return new;
6593 return t;
6595 case REAL_TYPE:
6596 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6597 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6599 tree low = NULL_TREE, high = NULL_TREE;
6601 if (TYPE_MIN_VALUE (t))
6602 low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
6603 if (TYPE_MAX_VALUE (t))
6604 high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
6606 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6607 return t;
6609 t = copy_type (t);
6610 TYPE_MIN_VALUE (t) = low;
6611 TYPE_MAX_VALUE (t) = high;
6613 return t;
6615 case COMPLEX_TYPE:
6616 tem = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6617 if (tem == TREE_TYPE (t))
6618 return t;
6620 return build_complex_type (tem);
6622 case OFFSET_TYPE:
6623 case METHOD_TYPE:
6624 case FUNCTION_TYPE:
6625 case LANG_TYPE:
6626 /* Don't know how to do these yet. */
6627 gcc_unreachable ();
6629 case ARRAY_TYPE:
6631 tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6632 tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r);
6634 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
6635 return t;
6637 new = build_array_type (component, domain);
6638 TYPE_SIZE (new) = 0;
6639 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
6640 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
6641 layout_type (new);
6642 TYPE_ALIGN (new) = TYPE_ALIGN (t);
6644 /* If we had bounded the sizes of T by a constant, bound the sizes of
6645 NEW by the same constant. */
6646 if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
6647 TYPE_SIZE (new)
6648 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
6649 TYPE_SIZE (new));
6650 if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
6651 TYPE_SIZE_UNIT (new)
6652 = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
6653 TYPE_SIZE_UNIT (new));
6654 return new;
6657 case RECORD_TYPE:
6658 case UNION_TYPE:
6659 case QUAL_UNION_TYPE:
6661 tree field;
6662 bool changed_field
6663 = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
6664 bool field_has_rep = false;
6665 tree last_field = NULL_TREE;
6667 tree new = copy_type (t);
6669 /* Start out with no fields, make new fields, and chain them
6670 in. If we haven't actually changed the type of any field,
6671 discard everything we've done and return the old type. */
6673 TYPE_FIELDS (new) = NULL_TREE;
6674 TYPE_SIZE (new) = NULL_TREE;
6676 for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
6678 tree new_field = copy_node (field);
6680 TREE_TYPE (new_field)
6681 = gnat_substitute_in_type (TREE_TYPE (new_field), f, r);
6683 if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
6684 field_has_rep = true;
6685 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
6686 changed_field = true;
6688 /* If this is an internal field and the type of this field is
6689 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
6690 the type just has one element, treat that as the field.
6691 But don't do this if we are processing a QUAL_UNION_TYPE. */
6692 if (TREE_CODE (t) != QUAL_UNION_TYPE
6693 && DECL_INTERNAL_P (new_field)
6694 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
6695 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
6697 if (!TYPE_FIELDS (TREE_TYPE (new_field)))
6698 continue;
6700 if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
6702 tree next_new_field
6703 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
6705 /* Make sure omitting the union doesn't change
6706 the layout. */
6707 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
6708 new_field = next_new_field;
6712 DECL_CONTEXT (new_field) = new;
6713 SET_DECL_ORIGINAL_FIELD (new_field,
6714 (DECL_ORIGINAL_FIELD (field)
6715 ? DECL_ORIGINAL_FIELD (field) : field));
6717 /* If the size of the old field was set at a constant,
6718 propagate the size in case the type's size was variable.
6719 (This occurs in the case of a variant or discriminated
6720 record with a default size used as a field of another
6721 record.) */
6722 DECL_SIZE (new_field)
6723 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
6724 ? DECL_SIZE (field) : NULL_TREE;
6725 DECL_SIZE_UNIT (new_field)
6726 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
6727 ? DECL_SIZE_UNIT (field) : NULL_TREE;
6729 if (TREE_CODE (t) == QUAL_UNION_TYPE)
6731 tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
6733 if (new_q != DECL_QUALIFIER (new_field))
6734 changed_field = true;
6736 /* Do the substitution inside the qualifier and if we find
6737 that this field will not be present, omit it. */
6738 DECL_QUALIFIER (new_field) = new_q;
6740 if (integer_zerop (DECL_QUALIFIER (new_field)))
6741 continue;
6744 if (!last_field)
6745 TYPE_FIELDS (new) = new_field;
6746 else
6747 TREE_CHAIN (last_field) = new_field;
6749 last_field = new_field;
6751 /* If this is a qualified type and this field will always be
6752 present, we are done. */
6753 if (TREE_CODE (t) == QUAL_UNION_TYPE
6754 && integer_onep (DECL_QUALIFIER (new_field)))
6755 break;
6758 /* If this used to be a qualified union type, but we now know what
6759 field will be present, make this a normal union. */
6760 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
6761 && (!TYPE_FIELDS (new)
6762 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
6763 TREE_SET_CODE (new, UNION_TYPE);
6764 else if (!changed_field)
6765 return t;
6767 gcc_assert (!field_has_rep);
6768 layout_type (new);
6770 /* If the size was originally a constant use it. */
6771 if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
6772 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
6774 TYPE_SIZE (new) = TYPE_SIZE (t);
6775 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
6776 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
6779 return new;
6782 default:
6783 return t;
6787 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
6788 needed to represent the object. */
6790 tree
6791 rm_size (tree gnu_type)
6793 /* For integer types, this is the precision. For record types, we store
6794 the size explicitly. For other types, this is just the size. */
6796 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
6797 return TYPE_RM_SIZE (gnu_type);
6798 else if (TREE_CODE (gnu_type) == RECORD_TYPE
6799 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6800 /* Return the rm_size of the actual data plus the size of the template. */
6801 return
6802 size_binop (PLUS_EXPR,
6803 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
6804 DECL_SIZE (TYPE_FIELDS (gnu_type)));
6805 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6806 || TREE_CODE (gnu_type) == UNION_TYPE
6807 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6808 && !TYPE_IS_FAT_POINTER_P (gnu_type)
6809 && TYPE_ADA_SIZE (gnu_type))
6810 return TYPE_ADA_SIZE (gnu_type);
6811 else
6812 return TYPE_SIZE (gnu_type);
6815 /* Return an identifier representing the external name to be used for
6816 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
6817 and the specified suffix. */
6819 tree
6820 create_concat_name (Entity_Id gnat_entity, const char *suffix)
6822 Entity_Kind kind = Ekind (gnat_entity);
6824 const char *str = (!suffix ? "" : suffix);
6825 String_Template temp = {1, strlen (str)};
6826 Fat_Pointer fp = {str, &temp};
6828 Get_External_Name_With_Suffix (gnat_entity, fp);
6830 /* A variable using the Stdcall convention (meaning we are running
6831 on a Windows box) live in a DLL. Here we adjust its name to use
6832 the jump-table, the _imp__NAME contains the address for the NAME
6833 variable. */
6834 if ((kind == E_Variable || kind == E_Constant)
6835 && Has_Stdcall_Convention (gnat_entity))
6837 const char *prefix = "_imp__";
6838 int k, plen = strlen (prefix);
6840 for (k = 0; k <= Name_Len; k++)
6841 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
6842 strncpy (Name_Buffer, prefix, plen);
6845 return get_identifier (Name_Buffer);
6848 /* Return the name to be used for GNAT_ENTITY. If a type, create a
6849 fully-qualified name, possibly with type information encoding.
6850 Otherwise, return the name. */
6852 tree
6853 get_entity_name (Entity_Id gnat_entity)
6855 Get_Encoded_Name (gnat_entity);
6856 return get_identifier (Name_Buffer);
6859 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
6860 string, return a new IDENTIFIER_NODE that is the concatenation of
6861 the name in GNU_ID and SUFFIX. */
6863 tree
6864 concat_id_with_name (tree gnu_id, const char *suffix)
6866 int len = IDENTIFIER_LENGTH (gnu_id);
6868 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
6869 IDENTIFIER_LENGTH (gnu_id));
6870 strncpy (Name_Buffer + len, "___", 3);
6871 len += 3;
6872 strcpy (Name_Buffer + len, suffix);
6873 return get_identifier (Name_Buffer);
6876 #include "gt-ada-decl.h"