1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * D E C L *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2004, 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, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, 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 ****************************************************************************/
26
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
38 #include "ada.h"
39 #include "types.h"
40 #include "atree.h"
41 #include "elists.h"
42 #include "namet.h"
43 #include "nlists.h"
44 #include "repinfo.h"
45 #include "snames.h"
46 #include "stringt.h"
47 #include "uintp.h"
48 #include "fe.h"
49 #include "sinfo.h"
50 #include "einfo.h"
51 #include "ada-tree.h"
52 #include "gigi.h"
53
54 /* Setting this to 1 suppresses hashing of types. */
55 extern int debug_no_type_hash;
56
57 /* Provide default values for the macros controlling stack checking.
58 This is copied from GCC's expr.h. */
59
60 #ifndef STACK_CHECK_BUILTIN
61 #define STACK_CHECK_BUILTIN 0
62 #endif
63 #ifndef STACK_CHECK_PROBE_INTERVAL
64 #define STACK_CHECK_PROBE_INTERVAL 4096
65 #endif
66 #ifndef STACK_CHECK_MAX_FRAME_SIZE
67 #define STACK_CHECK_MAX_FRAME_SIZE \
68 (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
69 #endif
70 #ifndef STACK_CHECK_MAX_VAR_SIZE
71 #define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
72 #endif
73
74 /* These two variables are used to defer recursively expanding incomplete
75 types while we are processing a record or subprogram type. */
76
77 static int defer_incomplete_level = 0;
78 static struct incomplete
79 {
80 struct incomplete *next;
81 tree old_type;
82 Entity_Id full_type;
83 } *defer_incomplete_list = 0;
84
85 static tree substitution_list (Entity_Id, Entity_Id, tree, int);
86 static int allocatable_size_p (tree, int);
87 static struct attrib *build_attr_list (Entity_Id);
88 static tree elaborate_expression (Node_Id, Entity_Id, tree, int, int, int);
89 static int is_variable_size (tree);
90 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, int, int);
91 static tree make_packable_type (tree);
92 static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *,
93 int, int, int);
94 static tree gnat_to_gnu_field (Entity_Id, tree, int, int);
95 static void components_to_record (tree, Node_Id, tree, int, int, tree *,
96 int, int);
97 static int compare_field_bitpos (const PTR, const PTR);
98 static Uint annotate_value (tree);
99 static void annotate_rep (Entity_Id, tree);
100 static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
101 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, int, int);
102 static void set_rm_size (Uint, tree, Entity_Id);
103 static tree make_type_from_size (tree, tree, int);
104 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
105 static void check_ok_for_atomic (tree, Entity_Id, int);
106
107 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
108 GCC type corresponding to that entity. GNAT_ENTITY is assumed to
109 refer to an Ada type. */
110
111 tree
gnat_to_gnu_type(Entity_Id gnat_entity)112 gnat_to_gnu_type (Entity_Id gnat_entity)
113 {
114 tree gnu_decl;
115
116 /* Convert the ada entity type into a GCC TYPE_DECL node. */
117 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
118 if (TREE_CODE (gnu_decl) != TYPE_DECL)
119 gigi_abort (101);
120
121 return TREE_TYPE (gnu_decl);
122 }
123
124 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
125 entity, this routine returns the equivalent GCC tree for that entity
126 (an ..._DECL node) and associates the ..._DECL node with the input GNAT
127 defining identifier.
128
129 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
130 initial value (in GCC tree form). This is optional for variables.
131 For renamed entities, GNU_EXPR gives the object being renamed.
132
133 DEFINITION is nonzero if this call is intended for a definition. This is
134 used for separate compilation where it necessary to know whether an
135 external declaration or a definition should be created if the GCC equivalent
136 was not created previously. The value of 1 is normally used for a non-zero
137 DEFINITION, but a value of 2 is used in special circumstances, defined in
138 the code. */
139
140 tree
gnat_to_gnu_entity(Entity_Id gnat_entity,tree gnu_expr,int definition)141 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
142 {
143 tree gnu_entity_id;
144 tree gnu_type = 0;
145 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
146 GNAT tree. This node will be associated with the GNAT node by calling
147 the save_gnu_tree routine at the end of the `switch' statement. */
148 tree gnu_decl = 0;
149 /* Nonzero if we have already saved gnu_decl as a gnat association. */
150 int saved = 0;
151 /* Nonzero if we incremented defer_incomplete_level. */
152 int this_deferred = 0;
153 /* Nonzero if we incremented force_global. */
154 int this_global = 0;
155 /* Nonzero if we should check to see if elaborated during processing. */
156 int maybe_present = 0;
157 /* Nonzero if we made GNU_DECL and its type here. */
158 int this_made_decl = 0;
159 struct attrib *attr_list = 0;
160 int debug_info_p = (Needs_Debug_Info (gnat_entity)
161 || debug_info_level == DINFO_LEVEL_VERBOSE);
162 Entity_Kind kind = Ekind (gnat_entity);
163 Entity_Id gnat_temp;
164 unsigned int esize
165 = ((Known_Esize (gnat_entity)
166 && UI_Is_In_Int_Range (Esize (gnat_entity)))
167 ? MIN (UI_To_Int (Esize (gnat_entity)),
168 IN (kind, Float_Kind)
169 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
170 : IN (kind, Access_Kind) ? POINTER_SIZE * 2
171 : LONG_LONG_TYPE_SIZE)
172 : LONG_LONG_TYPE_SIZE);
173 tree gnu_size = 0;
174 int imported_p
175 = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
176 || From_With_Type (gnat_entity));
177 unsigned int align = 0;
178
179 /* Since a use of an Itype is a definition, process it as such if it
180 is not in a with'ed unit. */
181
182 if (! definition && Is_Itype (gnat_entity)
183 && ! present_gnu_tree (gnat_entity)
184 && In_Extended_Main_Code_Unit (gnat_entity))
185 {
186 /* Ensure that we are in a subprogram mentioned in the Scope
187 chain of this entity, our current scope is global,
188 or that we encountered a task or entry (where we can't currently
189 accurately check scoping). */
190 if (current_function_decl == 0
191 || DECL_ELABORATION_PROC_P (current_function_decl))
192 {
193 process_type (gnat_entity);
194 return get_gnu_tree (gnat_entity);
195 }
196
197 for (gnat_temp = Scope (gnat_entity);
198 Present (gnat_temp); gnat_temp = Scope (gnat_temp))
199 {
200 if (Is_Type (gnat_temp))
201 gnat_temp = Underlying_Type (gnat_temp);
202
203 if (Ekind (gnat_temp) == E_Subprogram_Body)
204 gnat_temp
205 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
206
207 if (IN (Ekind (gnat_temp), Subprogram_Kind)
208 && Present (Protected_Body_Subprogram (gnat_temp)))
209 gnat_temp = Protected_Body_Subprogram (gnat_temp);
210
211 if (Ekind (gnat_temp) == E_Entry
212 || Ekind (gnat_temp) == E_Entry_Family
213 || Ekind (gnat_temp) == E_Task_Type
214 || (IN (Ekind (gnat_temp), Subprogram_Kind)
215 && present_gnu_tree (gnat_temp)
216 && (current_function_decl
217 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
218 {
219 process_type (gnat_entity);
220 return get_gnu_tree (gnat_entity);
221 }
222 }
223
224 /* gigi abort 122 means that the entity "gnat_entity" has an incorrect
225 scope, i.e. that its scope does not correspond to the subprogram
226 in which it is declared */
227 gigi_abort (122);
228 }
229
230 /* If this is entity 0, something went badly wrong. */
231 if (gnat_entity == 0)
232 gigi_abort (102);
233
234 /* If we've already processed this entity, return what we got last time.
235 If we are defining the node, we should not have already processed it.
236 In that case, we will abort below when we try to save a new GCC tree for
237 this object. We also need to handle the case of getting a dummy type
238 when a Full_View exists. */
239
240 if (present_gnu_tree (gnat_entity)
241 && (! definition
242 || (Is_Type (gnat_entity) && imported_p)))
243 {
244 gnu_decl = get_gnu_tree (gnat_entity);
245
246 if (TREE_CODE (gnu_decl) == TYPE_DECL
247 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
248 && IN (kind, Incomplete_Or_Private_Kind)
249 && Present (Full_View (gnat_entity)))
250 {
251 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
252 NULL_TREE, 0);
253
254 save_gnu_tree (gnat_entity, NULL_TREE, 0);
255 save_gnu_tree (gnat_entity, gnu_decl, 0);
256 }
257
258 return gnu_decl;
259 }
260
261 /* If this is a numeric or enumeral type, or an access type, a nonzero
262 Esize must be specified unless it was specified by the programmer. */
263 if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind)
264 || (IN (kind, Access_Kind)
265 && kind != E_Access_Protected_Subprogram_Type
266 && kind != E_Access_Subtype))
267 && Unknown_Esize (gnat_entity)
268 && ! Has_Size_Clause (gnat_entity))
269 gigi_abort (109);
270
271 /* Likewise, RM_Size must be specified for all discrete and fixed-point
272 types. */
273 if (IN (kind, Discrete_Or_Fixed_Point_Kind)
274 && Unknown_RM_Size (gnat_entity))
275 gigi_abort (123);
276
277 /* Get the name of the entity and set up the line number and filename of
278 the original definition for use in any decl we make. */
279
280 gnu_entity_id = get_entity_name (gnat_entity);
281 set_lineno (gnat_entity, 0);
282
283 /* If we get here, it means we have not yet done anything with this
284 entity. If we are not defining it here, it must be external,
285 otherwise we should have defined it already. */
286 if (! definition && ! Is_Public (gnat_entity)
287 && ! type_annotate_only
288 && kind != E_Discriminant && kind != E_Component
289 && kind != E_Label
290 && ! (kind == E_Constant && Present (Full_View (gnat_entity)))
291 #if 1
292 && !IN (kind, Type_Kind)
293 #endif
294 )
295 gigi_abort (116);
296
297 /* For cases when we are not defining (i.e., we are referencing from
298 another compilation unit) Public entities, show we are at global level
299 for the purpose of computing sizes. Don't do this for components or
300 discriminants since the relevant test is whether or not the record is
301 being defined. */
302 if (! definition && Is_Public (gnat_entity)
303 && ! Is_Statically_Allocated (gnat_entity)
304 && kind != E_Discriminant && kind != E_Component)
305 force_global++, this_global = 1;
306
307 /* Handle any attributes. */
308 if (Has_Gigi_Rep_Item (gnat_entity))
309 attr_list = build_attr_list (gnat_entity);
310
311 switch (kind)
312 {
313 case E_Constant:
314 /* If this is a use of a deferred constant, get its full
315 declaration. */
316 if (! definition && Present (Full_View (gnat_entity)))
317 {
318 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
319 gnu_expr, definition);
320 saved = 1;
321 break;
322 }
323
324 /* If we have an external constant that we are not defining,
325 get the expression that is was defined to represent. We
326 may throw that expression away later if it is not a
327 constant.
328 Do not retrieve the expression if it is an aggregate, because
329 in complex instantiation contexts it may not be expanded */
330
331 if (! definition
332 && Present (Expression (Declaration_Node (gnat_entity)))
333 && ! No_Initialization (Declaration_Node (gnat_entity))
334 && Nkind (Expression (Declaration_Node (gnat_entity)))
335 != N_Aggregate)
336 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
337
338 /* Ignore deferred constant definitions; they are processed fully in the
339 front-end. For deferred constant references, get the full
340 definition. On the other hand, constants that are renamings are
341 handled like variable renamings. If No_Initialization is set, this is
342 not a deferred constant but a constant whose value is built
343 manually. */
344
345 if (definition && gnu_expr == 0
346 && ! No_Initialization (Declaration_Node (gnat_entity))
347 && No (Renamed_Object (gnat_entity)))
348 {
349 gnu_decl = error_mark_node;
350 saved = 1;
351 break;
352 }
353 else if (! definition && IN (kind, Incomplete_Or_Private_Kind)
354 && Present (Full_View (gnat_entity)))
355 {
356 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
357 NULL_TREE, 0);
358 saved = 1;
359 break;
360 }
361
362 goto object;
363
364 case E_Exception:
365 /* If this is not a VMS exception, treat it as a normal object.
366 Otherwise, make an object at the specific address of character
367 type, point to it, and convert it to integer, and mask off
368 the lower 3 bits. */
369 if (! Is_VMS_Exception (gnat_entity))
370 goto object;
371
372 /* Allocate the global object that we use to get the value of the
373 exception. */
374 gnu_decl = create_var_decl (gnu_entity_id,
375 (Present (Interface_Name (gnat_entity))
376 ? create_concat_name (gnat_entity, 0)
377 : NULL_TREE),
378 char_type_node, NULL_TREE, 0, 0, 1, 1,
379 0);
380
381 /* Now return the expression giving the desired value. */
382 gnu_decl
383 = build_binary_op (BIT_AND_EXPR, integer_type_node,
384 convert (integer_type_node,
385 build_unary_op (ADDR_EXPR, NULL_TREE,
386 gnu_decl)),
387 build_unary_op (NEGATE_EXPR, integer_type_node,
388 build_int_2 (7, 0)));
389
390 save_gnu_tree (gnat_entity, gnu_decl, 1);
391 saved = 1;
392 break;
393
394 case E_Discriminant:
395 case E_Component:
396 {
397 /* The GNAT record where the component was defined. */
398 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
399
400 /* If the variable is an inherited record component (in the case of
401 extended record types), just return the inherited entity, which
402 must be a FIELD_DECL. Likewise for discriminants.
403 For discriminants of untagged records which have explicit
404 stored discriminants, return the entity for the corresponding
405 stored discriminant. Also use Original_Record_Component
406 if the record has a private extension. */
407
408 if ((Base_Type (gnat_record) == gnat_record
409 || Ekind (Scope (gnat_entity)) == E_Private_Subtype
410 || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
411 || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
412 && Present (Original_Record_Component (gnat_entity))
413 && Original_Record_Component (gnat_entity) != gnat_entity)
414 {
415 gnu_decl
416 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
417 gnu_expr, definition);
418 saved = 1;
419 break;
420 }
421
422 /* If the enclosing record has explicit stored discriminants,
423 then it is an untagged record. If the Corresponding_Discriminant
424 is not empty then this must be a renamed discriminant and its
425 Original_Record_Component must point to the corresponding explicit
426 stored discriminant (i.e., we should have taken the previous
427 branch). */
428
429 else if (Present (Corresponding_Discriminant (gnat_entity))
430 && Is_Tagged_Type (gnat_record))
431 {
432 /* A tagged record has no explicit stored discriminants. */
433
434 if (First_Discriminant (gnat_record)
435 != First_Stored_Discriminant (gnat_record))
436 gigi_abort (119);
437
438 gnu_decl
439 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
440 gnu_expr, definition);
441 saved = 1;
442 break;
443 }
444
445 /* If the enclosing record has explicit stored discriminants,
446 then it is an untagged record. If the Corresponding_Discriminant
447 is not empty then this must be a renamed discriminant and its
448 Original_Record_Component must point to the corresponding explicit
449 stored discriminant (i.e., we should have taken the first
450 branch). */
451
452 else if (Present (Corresponding_Discriminant (gnat_entity))
453 && (First_Discriminant (gnat_record)
454 != First_Stored_Discriminant (gnat_record)))
455 gigi_abort (120);
456
457 /* Otherwise, if we are not defining this and we have no GCC type
458 for the containing record, make one for it. Then we should
459 have made our own equivalent. */
460 else if (! definition && ! present_gnu_tree (gnat_record))
461 {
462 /* ??? If this is in a record whose scope is a protected
463 type and we have an Original_Record_Component, use it.
464 This is a workaround for major problems in protected type
465 handling. */
466
467 Entity_Id Scop = Scope (Scope (gnat_entity));
468 if ((Is_Protected_Type (Scop)
469 || (Is_Private_Type (Scop)
470 && Present (Full_View (Scop))
471 && Is_Protected_Type (Full_View (Scop))))
472 && Present (Original_Record_Component (gnat_entity)))
473 {
474 gnu_decl
475 = gnat_to_gnu_entity (Original_Record_Component
476 (gnat_entity),
477 gnu_expr, definition);
478 saved = 1;
479 break;
480 }
481
482 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
483 gnu_decl = get_gnu_tree (gnat_entity);
484 saved = 1;
485 break;
486 }
487
488 /* Here we have no GCC type and this is a reference rather than a
489 definition. This should never happen. Most likely the cause is a
490 reference before declaration in the gnat tree for gnat_entity. */
491 else
492 gigi_abort (103);
493 }
494
495 case E_Loop_Parameter:
496 case E_Out_Parameter:
497 case E_Variable:
498
499 /* Simple variables, loop variables, OUT parameters, and exceptions. */
500 object:
501 {
502 int used_by_ref = 0;
503 int const_flag
504 = ((kind == E_Constant || kind == E_Variable)
505 && ! Is_Statically_Allocated (gnat_entity)
506 && Is_True_Constant (gnat_entity)
507 && (((Nkind (Declaration_Node (gnat_entity))
508 == N_Object_Declaration)
509 && Present (Expression (Declaration_Node (gnat_entity))))
510 || Present (Renamed_Object (gnat_entity))));
511 int inner_const_flag = const_flag;
512 int static_p = Is_Statically_Allocated (gnat_entity);
513 tree gnu_ext_name = NULL_TREE;
514
515 if (Present (Renamed_Object (gnat_entity)) && ! definition)
516 {
517 if (kind == E_Exception)
518 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
519 NULL_TREE, 0);
520 else
521 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
522 }
523
524 /* Get the type after elaborating the renamed object. */
525 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
526
527 /* If this is a loop variable, its type should be the base type.
528 This is because the code for processing a loop determines whether
529 a normal loop end test can be done by comparing the bounds of the
530 loop against those of the base type, which is presumed to be the
531 size used for computation. But this is not correct when the size
532 of the subtype is smaller than the type. */
533 if (kind == E_Loop_Parameter)
534 gnu_type = get_base_type (gnu_type);
535
536 /* Reject non-renamed objects whose types are unconstrained arrays or
537 any object whose type is a dummy type or VOID_TYPE. */
538
539 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
540 && No (Renamed_Object (gnat_entity)))
541 || TYPE_IS_DUMMY_P (gnu_type)
542 || TREE_CODE (gnu_type) == VOID_TYPE)
543 {
544 if (type_annotate_only)
545 return error_mark_node;
546 else
547 gigi_abort (104);
548 }
549
550 /* If we are defining the object, see if it has a Size value and
551 validate it if so. If we are not defining the object and a Size
552 clause applies, simply retrieve the value. We don't want to ignore
553 the clause and it is expected to have been validated already. Then
554 get the new type, if any. */
555 if (definition)
556 gnu_size = validate_size (Esize (gnat_entity), gnu_type,
557 gnat_entity, VAR_DECL, 0,
558 Has_Size_Clause (gnat_entity));
559 else if (Has_Size_Clause (gnat_entity))
560 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
561
562 if (gnu_size != 0)
563 {
564 gnu_type
565 = make_type_from_size (gnu_type, gnu_size,
566 Has_Biased_Representation (gnat_entity));
567
568 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
569 gnu_size = 0;
570 }
571
572 /* If this object has self-referential size, it must be a record with
573 a default value. We are supposed to allocate an object of the
574 maximum size in this case unless it is a constant with an
575 initializing expression, in which case we can get the size from
576 that. Note that the resulting size may still be a variable, so
577 this may end up with an indirect allocation. */
578
579 if (No (Renamed_Object (gnat_entity))
580 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
581 {
582 if (gnu_expr != 0 && kind == E_Constant)
583 {
584 gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
585 if (CONTAINS_PLACEHOLDER_P (gnu_size))
586 gnu_size = build (WITH_RECORD_EXPR, bitsizetype,
587 gnu_size, gnu_expr);
588 }
589
590 /* We may have no GNU_EXPR because No_Initialization is
591 set even though there's an Expression. */
592 else if (kind == E_Constant
593 && (Nkind (Declaration_Node (gnat_entity))
594 == N_Object_Declaration)
595 && Present (Expression (Declaration_Node (gnat_entity))))
596 gnu_size
597 = TYPE_SIZE (gnat_to_gnu_type
598 (Etype
599 (Expression (Declaration_Node (gnat_entity)))));
600 else
601 gnu_size = max_size (TYPE_SIZE (gnu_type), 1);
602 }
603
604 /* If the size is zero bytes, make it one byte since some linkers have
605 trouble with zero-sized objects. If the object will have a
606 template, that will make it nonzero so don't bother. Also avoid
607 doing that for an object renaming or an object with an address
608 clause, as we would lose useful information on the view size
609 (e.g. for null array slices) and we are not allocating the object
610 here anyway. */
611 if (((gnu_size != 0 && integer_zerop (gnu_size))
612 || (TYPE_SIZE (gnu_type) != 0
613 && integer_zerop (TYPE_SIZE (gnu_type))))
614 && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
615 || ! Is_Array_Type (Etype (gnat_entity)))
616 && ! Present (Renamed_Object (gnat_entity))
617 && ! Present (Address_Clause (gnat_entity)))
618 gnu_size = bitsize_unit_node;
619
620 /* If an alignment is specified, use it if valid. Note that
621 exceptions are objects but don't have alignments. */
622 if (kind != E_Exception && Known_Alignment (gnat_entity))
623 {
624 if (No (Alignment (gnat_entity)))
625 gigi_abort (125);
626
627 align
628 = validate_alignment (Alignment (gnat_entity), gnat_entity,
629 TYPE_ALIGN (gnu_type));
630 }
631
632 /* If this is an atomic object with no specified size and alignment,
633 but where the size of the type is a constant, set the alignment to
634 the lowest power of two greater than the size, or to the
635 biggest meaningful alignment, whichever is smaller. */
636
637 if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0
638 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
639 {
640 if (! host_integerp (TYPE_SIZE (gnu_type), 1)
641 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
642 BIGGEST_ALIGNMENT))
643 align = BIGGEST_ALIGNMENT;
644 else
645 align = ((unsigned int) 1
646 << (floor_log2 (tree_low_cst
647 (TYPE_SIZE (gnu_type), 1) - 1)
648 + 1));
649 }
650
651 /* If the object is set to have atomic components, find the component
652 type and validate it.
653
654 ??? Note that we ignore Has_Volatile_Components on objects; it's
655 not at all clear what to do in that case. */
656
657 if (Has_Atomic_Components (gnat_entity))
658 {
659 tree gnu_inner
660 = (TREE_CODE (gnu_type) == ARRAY_TYPE
661 ? TREE_TYPE (gnu_type) : gnu_type);
662
663 while (TREE_CODE (gnu_inner) == ARRAY_TYPE
664 && TYPE_MULTI_ARRAY_P (gnu_inner))
665 gnu_inner = TREE_TYPE (gnu_inner);
666
667 check_ok_for_atomic (gnu_inner, gnat_entity, 1);
668 }
669
670 /* Now check if the type of the object allows atomic access. Note
671 that we must test the type, even if this object has size and
672 alignment to allow such access, because we will be going
673 inside the padded record to assign to the object. We could fix
674 this by always copying via an intermediate value, but it's not
675 clear it's worth the effort. */
676 if (Is_Atomic (gnat_entity))
677 check_ok_for_atomic (gnu_type, gnat_entity, 0);
678
679 /* If this is an aliased object with an unconstrained nominal subtype,
680 make a type that includes the template. */
681 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
682 && Is_Array_Type (Etype (gnat_entity))
683 && ! type_annotate_only)
684 {
685 tree gnu_fat
686 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
687 tree gnu_temp_type
688 = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
689
690 gnu_type
691 = build_unc_object_type (gnu_temp_type, gnu_type,
692 concat_id_with_name (gnu_entity_id,
693 "UNC"));
694 }
695
696 #ifdef MINIMUM_ATOMIC_ALIGNMENT
697 /* If the size is a constant and no alignment is specified, force
698 the alignment to be the minimum valid atomic alignment. The
699 restriction on constant size avoids problems with variable-size
700 temporaries; if the size is variable, there's no issue with
701 atomic access. Also don't do this for a constant, since it isn't
702 necessary and can interfere with constant replacement. Finally,
703 do not do it for Out parameters since that creates an
704 size inconsistency with In parameters. */
705 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
706 && ! FLOAT_TYPE_P (gnu_type)
707 && ! const_flag && No (Renamed_Object (gnat_entity))
708 && ! imported_p && No (Address_Clause (gnat_entity))
709 && kind != E_Out_Parameter
710 && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
711 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
712 align = MINIMUM_ATOMIC_ALIGNMENT;
713 #endif
714
715 /* Make a new type with the desired size and alignment, if needed. */
716 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
717 gnat_entity, "PAD", 0, definition, 1);
718
719 /* Make a volatile version of this object's type if we are to
720 make the object volatile. Note that 13.3(19) says that we
721 should treat other types of objects as volatile as well. */
722 if ((Treat_As_Volatile (gnat_entity)
723 || Is_Exported (gnat_entity)
724 || Is_Imported (gnat_entity)
725 || Present (Address_Clause (gnat_entity)))
726 && ! TYPE_VOLATILE (gnu_type))
727 gnu_type = build_qualified_type (gnu_type,
728 (TYPE_QUALS (gnu_type)
729 | TYPE_QUAL_VOLATILE));
730
731 /* Convert the expression to the type of the object except in the
732 case where the object's type is unconstrained or the object's type
733 is a padded record whose field is of self-referential size. In
734 the former case, converting will generate unnecessary evaluations
735 of the CONSTRUCTOR to compute the size and in the latter case, we
736 want to only copy the actual data. */
737 if (gnu_expr != 0
738 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
739 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
740 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
741 && TYPE_IS_PADDING_P (gnu_type)
742 && (CONTAINS_PLACEHOLDER_P
743 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
744 gnu_expr = convert (gnu_type, gnu_expr);
745
746 /* See if this is a renaming. If this is a constant renaming,
747 treat it as a normal variable whose initial value is what
748 is being renamed. We cannot do this if the type is
749 unconstrained or class-wide.
750
751 Otherwise, if what we are renaming is a reference, we can simply
752 return a stabilized version of that reference, after forcing
753 any SAVE_EXPRs to be evaluated. But, if this is at global level,
754 we can only do this if we know no SAVE_EXPRs will be made.
755 Otherwise, make this into a constant pointer to the object we are
756 to rename. */
757
758 if (Present (Renamed_Object (gnat_entity)))
759 {
760 /* If the renamed object had padding, strip off the reference
761 to the inner object and reset our type. */
762 if (TREE_CODE (gnu_expr) == COMPONENT_REF
763 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
764 == RECORD_TYPE)
765 && (TYPE_IS_PADDING_P
766 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
767 {
768 gnu_expr = TREE_OPERAND (gnu_expr, 0);
769 gnu_type = TREE_TYPE (gnu_expr);
770 }
771
772 if (const_flag
773 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
774 && TYPE_MODE (gnu_type) != BLKmode
775 && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
776 && !Is_Array_Type (Etype (gnat_entity)))
777 ;
778
779 /* If this is a declaration or reference, we can just use that
780 declaration or reference as this entity. */
781 else if ((DECL_P (gnu_expr)
782 || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r')
783 && ! Materialize_Entity (gnat_entity)
784 && (! global_bindings_p ()
785 || (staticp (gnu_expr)
786 && ! TREE_SIDE_EFFECTS (gnu_expr))))
787 {
788 set_lineno (gnat_entity, ! global_bindings_p ());
789 gnu_decl = gnat_stabilize_reference (gnu_expr, 1);
790 save_gnu_tree (gnat_entity, gnu_decl, 1);
791 saved = 1;
792
793 if (! global_bindings_p ())
794 expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node,
795 gnu_decl));
796 break;
797 }
798 else
799 {
800 inner_const_flag = TREE_READONLY (gnu_expr);
801 const_flag = 1;
802 gnu_type = build_reference_type (gnu_type);
803 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
804 gnu_size = 0;
805 used_by_ref = 1;
806 }
807 }
808
809 /* If this is an aliased object whose nominal subtype is unconstrained,
810 the object is a record that contains both the template and
811 the object. If there is an initializer, it will have already
812 been converted to the right type, but we need to create the
813 template if there is no initializer. */
814 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
815 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
816 /* Beware that padding might have been introduced
817 via maybe_pad_type above. */
818 || (TYPE_IS_PADDING_P (gnu_type)
819 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
820 == RECORD_TYPE
821 && TYPE_CONTAINS_TEMPLATE_P
822 (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
823 && gnu_expr == 0)
824 {
825 tree template_field
826 = TYPE_IS_PADDING_P (gnu_type)
827 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
828 : TYPE_FIELDS (gnu_type);
829
830 gnu_expr
831 = gnat_build_constructor
832 (gnu_type,
833 tree_cons
834 (template_field,
835 build_template (TREE_TYPE (template_field),
836 TREE_TYPE (TREE_CHAIN (template_field)),
837 NULL_TREE),
838 NULL_TREE));
839 }
840
841 /* If this is a pointer and it does not have an initializing
842 expression, initialize it to NULL, unless the obect is
843 imported. */
844 if (definition
845 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
846 && !Is_Imported (gnat_entity)
847 && gnu_expr == 0)
848 gnu_expr = integer_zero_node;
849
850 /* If we are defining the object and it has an Address clause we must
851 get the address expression from the saved GCC tree for the
852 object if the object has a Freeze_Node. Otherwise, we elaborate
853 the address expression here since the front-end has guaranteed
854 in that case that the elaboration has no effects. Note that
855 only the latter mechanism is currently in use. */
856 if (definition && Present (Address_Clause (gnat_entity)))
857 {
858 tree gnu_address
859 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
860 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
861
862 save_gnu_tree (gnat_entity, NULL_TREE, 0);
863
864 /* Ignore the size. It's either meaningless or was handled
865 above. */
866 gnu_size = 0;
867 gnu_type = build_reference_type (gnu_type);
868 gnu_address = convert (gnu_type, gnu_address);
869 used_by_ref = 1;
870 const_flag = ! Is_Public (gnat_entity);
871
872 /* If we don't have an initializing expression for the underlying
873 variable, the initializing expression for the pointer is the
874 specified address. Otherwise, we have to make a COMPOUND_EXPR
875 to assign both the address and the initial value. */
876 if (gnu_expr == 0)
877 gnu_expr = gnu_address;
878 else
879 gnu_expr
880 = build (COMPOUND_EXPR, gnu_type,
881 build_binary_op
882 (MODIFY_EXPR, NULL_TREE,
883 build_unary_op (INDIRECT_REF, NULL_TREE,
884 gnu_address),
885 gnu_expr),
886 gnu_address);
887 }
888
889 /* If it has an address clause and we are not defining it, mark it
890 as an indirect object. Likewise for Stdcall objects that are
891 imported. */
892 if ((! definition && Present (Address_Clause (gnat_entity)))
893 || (Is_Imported (gnat_entity)
894 && Convention (gnat_entity) == Convention_Stdcall))
895 {
896 gnu_type = build_reference_type (gnu_type);
897 gnu_size = 0;
898 used_by_ref = 1;
899 }
900
901 /* If we are at top level and this object is of variable size,
902 make the actual type a hidden pointer to the real type and
903 make the initializer be a memory allocation and initialization.
904 Likewise for objects we aren't defining (presumed to be
905 external references from other packages), but there we do
906 not set up an initialization.
907
908 If the object's size overflows, make an allocator too, so that
909 Storage_Error gets raised. Note that we will never free
910 such memory, so we presume it never will get allocated. */
911
912 if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
913 global_bindings_p () || ! definition
914 || static_p)
915 || (gnu_size != 0
916 && ! allocatable_size_p (gnu_size,
917 global_bindings_p () || ! definition
918 || static_p)))
919 {
920 gnu_type = build_reference_type (gnu_type);
921 gnu_size = 0;
922 used_by_ref = 1;
923 const_flag = 1;
924
925 /* Get the data part of GNU_EXPR in case this was a
926 aliased object whose nominal subtype is unconstrained.
927 In that case the pointer above will be a thin pointer and
928 build_allocator will automatically make the template and
929 constructor already made above. */
930
931 if (definition)
932 {
933 tree gnu_alloc_type = TREE_TYPE (gnu_type);
934
935 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
936 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
937 {
938 gnu_alloc_type
939 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
940 gnu_expr
941 = build_component_ref
942 (gnu_expr, NULL_TREE,
943 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0);
944 }
945
946 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
947 && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
948 && ! Is_Imported (gnat_entity))
949 post_error ("Storage_Error will be raised at run-time?",
950 gnat_entity);
951
952 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
953 gnu_type, 0, 0, gnat_entity);
954 }
955 else
956 {
957 gnu_expr = 0;
958 const_flag = 0;
959 }
960 }
961
962 /* If this object would go into the stack and has an alignment
963 larger than the default largest alignment, make a variable
964 to hold the "aligning type" with a modified initial value,
965 if any, then point to it and make that the value of this
966 variable, which is now indirect. */
967
968 if (! global_bindings_p () && ! static_p && definition
969 && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
970 {
971 tree gnu_new_type
972 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
973 TYPE_SIZE_UNIT (gnu_type));
974 tree gnu_new_var;
975
976 set_lineno (gnat_entity, 1);
977 gnu_new_var
978 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
979 NULL_TREE, gnu_new_type, gnu_expr,
980 0, 0, 0, 0, 0);
981
982 if (gnu_expr != 0)
983 expand_expr_stmt
984 (build_binary_op
985 (MODIFY_EXPR, NULL_TREE,
986 build_component_ref (gnu_new_var, NULL_TREE,
987 TYPE_FIELDS (gnu_new_type), 0),
988 gnu_expr));
989
990 gnu_type = build_reference_type (gnu_type);
991 gnu_expr
992 = build_unary_op
993 (ADDR_EXPR, gnu_type,
994 build_component_ref (gnu_new_var, NULL_TREE,
995 TYPE_FIELDS (gnu_new_type), 0));
996
997 gnu_size = 0;
998 used_by_ref = 1;
999 const_flag = 1;
1000 }
1001
1002 /* Convert the expression to the type of the object except in the
1003 case where the object's type is unconstrained or the object's type
1004 is a padded record whose field is of self-referential size. In
1005 the former case, converting will generate unnecessary evaluations
1006 of the CONSTRUCTOR to compute the size and in the latter case, we
1007 want to only copy the actual data. */
1008 if (gnu_expr != 0
1009 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
1010 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1011 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
1012 && TYPE_IS_PADDING_P (gnu_type)
1013 && (CONTAINS_PLACEHOLDER_P
1014 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
1015 gnu_expr = convert (gnu_type, gnu_expr);
1016
1017 /* This name is external or there was a name specified, use it.
1018 Don't use the Interface_Name if there is an address clause.
1019 (see CD30005). */
1020 if ((Present (Interface_Name (gnat_entity))
1021 && No (Address_Clause (gnat_entity)))
1022 || (Is_Public (gnat_entity)
1023 && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity))))
1024 gnu_ext_name = create_concat_name (gnat_entity, 0);
1025
1026 if (const_flag)
1027 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
1028 | TYPE_QUAL_CONST));
1029
1030 /* If this is constant initialized to a static constant and the
1031 object has an aggregrate type, force it to be statically
1032 allocated. */
1033 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
1034 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
1035 && (AGGREGATE_TYPE_P (gnu_type)
1036 && ! (TREE_CODE (gnu_type) == RECORD_TYPE
1037 && TYPE_IS_PADDING_P (gnu_type))))
1038 static_p = 1;
1039
1040 set_lineno (gnat_entity, ! global_bindings_p ());
1041 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1042 gnu_expr, const_flag,
1043 Is_Public (gnat_entity),
1044 imported_p || !definition,
1045 static_p, attr_list);
1046
1047 DECL_BY_REF_P (gnu_decl) = used_by_ref;
1048 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
1049
1050 if (definition && DECL_SIZE (gnu_decl) != 0
1051 && gnu_block_stack != 0
1052 && TREE_VALUE (gnu_block_stack) != 0
1053 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
1054 || (flag_stack_check && ! STACK_CHECK_BUILTIN
1055 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
1056 STACK_CHECK_MAX_VAR_SIZE))))
1057 update_setjmp_buf (TREE_VALUE (gnu_block_stack));
1058
1059 /* If this is a public constant or we're not optimizing and we're not
1060 making a VAR_DECL for it, make one just for export or debugger
1061 use. Likewise if the address is taken or if the object or type is
1062 aliased. */
1063 if (definition && TREE_CODE (gnu_decl) == CONST_DECL
1064 && (Is_Public (gnat_entity)
1065 || optimize == 0
1066 || Address_Taken (gnat_entity)
1067 || Is_Aliased (gnat_entity)
1068 || Is_Aliased (Etype (gnat_entity))))
1069 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl,
1070 create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
1071 gnu_expr, 0, Is_Public (gnat_entity), 0,
1072 static_p, 0));
1073
1074 /* If this is declared in a block that contains an block with an
1075 exception handler, we must force this variable in memory to
1076 suppress an invalid optimization. */
1077 if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
1078 && Exception_Mechanism != GCC_ZCX)
1079 {
1080 gnat_mark_addressable (gnu_decl);
1081 flush_addressof (gnu_decl);
1082 }
1083
1084 /* Back-annotate the Alignment of the object if not already in the
1085 tree. Likewise for Esize if the object is of a constant size.
1086 But if the "object" is actually a pointer to an object, the
1087 alignment and size are the same as teh type, so don't back-annotate
1088 the values for the pointer. */
1089 if (! used_by_ref && Unknown_Alignment (gnat_entity))
1090 Set_Alignment (gnat_entity,
1091 UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT));
1092
1093 if (! used_by_ref && Unknown_Esize (gnat_entity)
1094 && DECL_SIZE (gnu_decl) != 0)
1095 {
1096 tree gnu_back_size = DECL_SIZE (gnu_decl);
1097
1098 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
1099 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl)))
1100 gnu_back_size
1101 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN
1102 (TYPE_FIELDS (TREE_TYPE (gnu_decl)))));
1103
1104 Set_Esize (gnat_entity, annotate_value (gnu_back_size));
1105 }
1106 }
1107 break;
1108
1109 case E_Void:
1110 /* Return a TYPE_DECL for "void" that we previously made. */
1111 gnu_decl = void_type_decl_node;
1112 break;
1113
1114 case E_Enumeration_Type:
1115 /* A special case, for the types Character and Wide_Character in
1116 Standard, we do not list all the literals. So if the literals
1117 are not specified, make this an unsigned type. */
1118 if (No (First_Literal (gnat_entity)))
1119 {
1120 gnu_type = make_unsigned_type (esize);
1121 break;
1122 }
1123
1124 /* Normal case of non-character type, or non-Standard character type */
1125 {
1126 /* Here we have a list of enumeral constants in First_Literal.
1127 We make a CONST_DECL for each and build into GNU_LITERAL_LIST
1128 the list to be places into TYPE_FIELDS. Each node in the list
1129 is a TREE_LIST node whose TREE_VALUE is the literal name
1130 and whose TREE_PURPOSE is the value of the literal.
1131
1132 Esize contains the number of bits needed to represent the enumeral
1133 type, Type_Low_Bound also points to the first literal and
1134 Type_High_Bound points to the last literal. */
1135
1136 Entity_Id gnat_literal;
1137 tree gnu_literal_list = NULL_TREE;
1138
1139 if (Is_Unsigned_Type (gnat_entity))
1140 gnu_type = make_unsigned_type (esize);
1141 else
1142 gnu_type = make_signed_type (esize);
1143
1144 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
1145
1146 for (gnat_literal = First_Literal (gnat_entity);
1147 Present (gnat_literal);
1148 gnat_literal = Next_Literal (gnat_literal))
1149 {
1150 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
1151 gnu_type);
1152 tree gnu_literal
1153 = create_var_decl (get_entity_name (gnat_literal),
1154 0, gnu_type, gnu_value, 1, 0, 0, 0, 0);
1155
1156 save_gnu_tree (gnat_literal, gnu_literal, 0);
1157 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
1158 gnu_value, gnu_literal_list);
1159 }
1160
1161 TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list);
1162
1163 /* Note that the bounds are updated at the end of this function
1164 because to avoid an infinite recursion when we get the bounds of
1165 this type, since those bounds are objects of this type. */
1166 }
1167 break;
1168
1169 case E_Signed_Integer_Type:
1170 case E_Ordinary_Fixed_Point_Type:
1171 case E_Decimal_Fixed_Point_Type:
1172 /* For integer types, just make a signed type the appropriate number
1173 of bits. */
1174 gnu_type = make_signed_type (esize);
1175 break;
1176
1177 case E_Modular_Integer_Type:
1178 /* For modular types, make the unsigned type of the proper number of
1179 bits and then set up the modulus, if required. */
1180 {
1181 enum machine_mode mode;
1182 tree gnu_modulus;
1183 tree gnu_high = 0;
1184
1185 if (Is_Packed_Array_Type (gnat_entity))
1186 esize = UI_To_Int (RM_Size (gnat_entity));
1187
1188 /* Find the smallest mode at least ESIZE bits wide and make a class
1189 using that mode. */
1190
1191 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
1192 GET_MODE_BITSIZE (mode) < esize;
1193 mode = GET_MODE_WIDER_MODE (mode))
1194 ;
1195
1196 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
1197 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1198 = Is_Packed_Array_Type (gnat_entity);
1199
1200 /* Get the modulus in this type. If it overflows, assume it is because
1201 it is equal to 2**Esize. Note that there is no overflow checking
1202 done on unsigned type, so we detect the overflow by looking for
1203 a modulus of zero, which is otherwise invalid. */
1204 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
1205
1206 if (! integer_zerop (gnu_modulus))
1207 {
1208 TYPE_MODULAR_P (gnu_type) = 1;
1209 SET_TYPE_MODULUS (gnu_type, gnu_modulus);
1210 gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
1211 convert (gnu_type, integer_one_node)));
1212 }
1213
1214 /* If we have to set TYPE_PRECISION different from its natural value,
1215 make a subtype to do do. Likewise if there is a modulus and
1216 it is not one greater than TYPE_MAX_VALUE. */
1217 if (TYPE_PRECISION (gnu_type) != esize
1218 || (TYPE_MODULAR_P (gnu_type)
1219 && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
1220 {
1221 tree gnu_subtype = make_node (INTEGER_TYPE);
1222
1223 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
1224 TREE_TYPE (gnu_subtype) = gnu_type;
1225 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
1226 TYPE_MAX_VALUE (gnu_subtype)
1227 = TYPE_MODULAR_P (gnu_type)
1228 ? gnu_high : TYPE_MAX_VALUE (gnu_type);
1229 TYPE_PRECISION (gnu_subtype) = esize;
1230 TREE_UNSIGNED (gnu_subtype) = 1;
1231 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
1232 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
1233 = Is_Packed_Array_Type (gnat_entity);
1234 layout_type (gnu_subtype);
1235
1236 gnu_type = gnu_subtype;
1237 }
1238 }
1239 break;
1240
1241 case E_Signed_Integer_Subtype:
1242 case E_Enumeration_Subtype:
1243 case E_Modular_Integer_Subtype:
1244 case E_Ordinary_Fixed_Point_Subtype:
1245 case E_Decimal_Fixed_Point_Subtype:
1246
1247 /* For integral subtypes, we make a new INTEGER_TYPE. Note
1248 that we do not want to call build_range_type since we would
1249 like each subtype node to be distinct. This will be important
1250 when memory aliasing is implemented.
1251
1252 The TREE_TYPE field of the INTEGER_TYPE we make points to the
1253 parent type; this fact is used by the arithmetic conversion
1254 functions.
1255
1256 We elaborate the Ancestor_Subtype if it is not in the current
1257 unit and one of our bounds is non-static. We do this to ensure
1258 consistent naming in the case where several subtypes share the same
1259 bounds by always elaborating the first such subtype first, thus
1260 using its name. */
1261
1262 if (definition == 0
1263 && Present (Ancestor_Subtype (gnat_entity))
1264 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1265 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1266 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1267 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1268 gnu_expr, definition);
1269
1270 gnu_type = make_node (INTEGER_TYPE);
1271 if (Is_Packed_Array_Type (gnat_entity))
1272 {
1273 esize = UI_To_Int (RM_Size (gnat_entity));
1274 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
1275 }
1276
1277 TYPE_PRECISION (gnu_type) = esize;
1278 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1279
1280 TYPE_MIN_VALUE (gnu_type)
1281 = convert (TREE_TYPE (gnu_type),
1282 elaborate_expression (Type_Low_Bound (gnat_entity),
1283 gnat_entity,
1284 get_identifier ("L"), definition, 1,
1285 Needs_Debug_Info (gnat_entity)));
1286
1287 TYPE_MAX_VALUE (gnu_type)
1288 = convert (TREE_TYPE (gnu_type),
1289 elaborate_expression (Type_High_Bound (gnat_entity),
1290 gnat_entity,
1291 get_identifier ("U"), definition, 1,
1292 Needs_Debug_Info (gnat_entity)));
1293
1294 /* One of the above calls might have caused us to be elaborated,
1295 so don't blow up if so. */
1296 if (present_gnu_tree (gnat_entity))
1297 {
1298 maybe_present = 1;
1299 break;
1300 }
1301
1302 TYPE_BIASED_REPRESENTATION_P (gnu_type)
1303 = Has_Biased_Representation (gnat_entity);
1304
1305 /* This should be an unsigned type if the lower bound is constant
1306 and non-negative or if the base type is unsigned; a signed type
1307 otherwise. */
1308 TREE_UNSIGNED (gnu_type)
1309 = (TREE_UNSIGNED (TREE_TYPE (gnu_type))
1310 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
1311 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
1312 || TYPE_BIASED_REPRESENTATION_P (gnu_type)
1313 || Is_Unsigned_Type (gnat_entity));
1314
1315 layout_type (gnu_type);
1316
1317 if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN)
1318 {
1319 tree gnu_field_type = gnu_type;
1320 tree gnu_field;
1321
1322 TYPE_RM_SIZE_INT (gnu_field_type)
1323 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
1324 gnu_type = make_node (RECORD_TYPE);
1325 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM");
1326 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
1327 TYPE_PACKED (gnu_type) = 1;
1328 gnu_field = create_field_decl (get_identifier ("OBJECT"),
1329 gnu_field_type, gnu_type, 1, 0, 0, 1),
1330 finish_record_type (gnu_type, gnu_field, 0, 0);
1331 TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1;
1332 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
1333 }
1334
1335 break;
1336
1337 case E_Floating_Point_Type:
1338 /* If this is a VAX floating-point type, use an integer of the proper
1339 size. All the operations will be handled with ASM statements. */
1340 if (Vax_Float (gnat_entity))
1341 {
1342 gnu_type = make_signed_type (esize);
1343 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
1344 SET_TYPE_DIGITS_VALUE (gnu_type,
1345 UI_To_gnu (Digits_Value (gnat_entity),
1346 sizetype));
1347 break;
1348 }
1349
1350 /* The type of the Low and High bounds can be our type if this is
1351 a type from Standard, so set them at the end of the function. */
1352 gnu_type = make_node (REAL_TYPE);
1353 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1354 layout_type (gnu_type);
1355 break;
1356
1357 case E_Floating_Point_Subtype:
1358 if (Vax_Float (gnat_entity))
1359 {
1360 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1361 break;
1362 }
1363
1364 {
1365 if (definition == 0
1366 && Present (Ancestor_Subtype (gnat_entity))
1367 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
1368 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
1369 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
1370 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
1371 gnu_expr, definition);
1372
1373 gnu_type = make_node (REAL_TYPE);
1374 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
1375 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
1376
1377 TYPE_MIN_VALUE (gnu_type)
1378 = convert (TREE_TYPE (gnu_type),
1379 elaborate_expression (Type_Low_Bound (gnat_entity),
1380 gnat_entity, get_identifier ("L"),
1381 definition, 1,
1382 Needs_Debug_Info (gnat_entity)));
1383
1384 TYPE_MAX_VALUE (gnu_type)
1385 = convert (TREE_TYPE (gnu_type),
1386 elaborate_expression (Type_High_Bound (gnat_entity),
1387 gnat_entity, get_identifier ("U"),
1388 definition, 1,
1389 Needs_Debug_Info (gnat_entity)));
1390
1391 /* One of the above calls might have caused us to be elaborated,
1392 so don't blow up if so. */
1393 if (present_gnu_tree (gnat_entity))
1394 {
1395 maybe_present = 1;
1396 break;
1397 }
1398
1399 layout_type (gnu_type);
1400 }
1401 break;
1402
1403 /* Array and String Types and Subtypes
1404
1405 Unconstrained array types are represented by E_Array_Type and
1406 constrained array types are represented by E_Array_Subtype. There
1407 are no actual objects of an unconstrained array type; all we have
1408 are pointers to that type.
1409
1410 The following fields are defined on array types and subtypes:
1411
1412 Component_Type Component type of the array.
1413 Number_Dimensions Number of dimensions (an int).
1414 First_Index Type of first index. */
1415
1416 case E_String_Type:
1417 case E_Array_Type:
1418 {
1419 tree gnu_template_fields = NULL_TREE;
1420 tree gnu_template_type = make_node (RECORD_TYPE);
1421 tree gnu_ptr_template = build_pointer_type (gnu_template_type);
1422 tree gnu_fat_type = make_node (RECORD_TYPE);
1423 int ndim = Number_Dimensions (gnat_entity);
1424 int firstdim
1425 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
1426 int nextdim
1427 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
1428 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
1429 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
1430 tree gnu_comp_size = 0;
1431 tree gnu_max_size = size_one_node;
1432 tree gnu_max_size_unit;
1433 int index;
1434 Entity_Id gnat_ind_subtype;
1435 Entity_Id gnat_ind_base_subtype;
1436 tree gnu_template_reference;
1437 tree tem;
1438
1439 TYPE_NAME (gnu_template_type)
1440 = create_concat_name (gnat_entity, "XUB");
1441 TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP");
1442 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
1443 TREE_READONLY (gnu_template_type) = 1;
1444
1445 /* Make a node for the array. If we are not defining the array
1446 suppress expanding incomplete types and save the node as the type
1447 for GNAT_ENTITY. */
1448 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
1449 if (! definition)
1450 {
1451 defer_incomplete_level++;
1452 this_deferred = this_made_decl = 1;
1453 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
1454 ! Comes_From_Source (gnat_entity),
1455 debug_info_p);
1456 save_gnu_tree (gnat_entity, gnu_decl, 0);
1457 saved = 1;
1458 }
1459
1460 /* Build the fat pointer type. Use a "void *" object instead of
1461 a pointer to the array type since we don't have the array type
1462 yet (it will reference the fat pointer via the bounds). */
1463 tem = chainon (chainon (NULL_TREE,
1464 create_field_decl (get_identifier ("P_ARRAY"),
1465 ptr_void_type_node,
1466 gnu_fat_type, 0, 0, 0, 0)),
1467 create_field_decl (get_identifier ("P_BOUNDS"),
1468 gnu_ptr_template,
1469 gnu_fat_type, 0, 0, 0, 0));
1470
1471 /* Make sure we can put this into a register. */
1472 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
1473 finish_record_type (gnu_fat_type, tem, 0, 1);
1474
1475 /* Build a reference to the template from a PLACEHOLDER_EXPR that
1476 is the fat pointer. This will be used to access the individual
1477 fields once we build them. */
1478 tem = build (COMPONENT_REF, gnu_ptr_template,
1479 build (PLACEHOLDER_EXPR, gnu_fat_type),
1480 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
1481 gnu_template_reference
1482 = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
1483 TREE_READONLY (gnu_template_reference) = 1;
1484
1485 /* Now create the GCC type for each index and add the fields for
1486 that index to the template. */
1487 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
1488 gnat_ind_base_subtype
1489 = First_Index (Implementation_Base_Type (gnat_entity));
1490 index < ndim && index >= 0;
1491 index += nextdim,
1492 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1493 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1494 {
1495 char field_name[10];
1496 tree gnu_ind_subtype
1497 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
1498 tree gnu_base_subtype
1499 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1500 tree gnu_base_min
1501 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1502 tree gnu_base_max
1503 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1504 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
1505
1506 /* Make the FIELD_DECLs for the minimum and maximum of this
1507 type and then make extractions of that field from the
1508 template. */
1509 set_lineno (gnat_entity, 0);
1510 sprintf (field_name, "LB%d", index);
1511 gnu_min_field = create_field_decl (get_identifier (field_name),
1512 gnu_ind_subtype,
1513 gnu_template_type, 0, 0, 0, 0);
1514 field_name[0] = 'U';
1515 gnu_max_field = create_field_decl (get_identifier (field_name),
1516 gnu_ind_subtype,
1517 gnu_template_type, 0, 0, 0, 0);
1518
1519 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
1520
1521 /* We can't use build_component_ref here since the template
1522 type isn't complete yet. */
1523 gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
1524 gnu_template_reference, gnu_min_field);
1525 gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
1526 gnu_template_reference, gnu_max_field);
1527 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
1528
1529 /* Make a range type with the new ranges, but using
1530 the Ada subtype. Then we convert to sizetype. */
1531 gnu_index_types[index]
1532 = create_index_type (convert (sizetype, gnu_min),
1533 convert (sizetype, gnu_max),
1534 build_range_type (gnu_ind_subtype,
1535 gnu_min, gnu_max));
1536 /* Update the maximum size of the array, in elements. */
1537 gnu_max_size
1538 = size_binop (MULT_EXPR, gnu_max_size,
1539 size_binop (PLUS_EXPR, size_one_node,
1540 size_binop (MINUS_EXPR, gnu_base_max,
1541 gnu_base_min)));
1542
1543 TYPE_NAME (gnu_index_types[index])
1544 = create_concat_name (gnat_entity, field_name);
1545 }
1546
1547 for (index = 0; index < ndim; index++)
1548 gnu_template_fields
1549 = chainon (gnu_template_fields, gnu_temp_fields[index]);
1550
1551 /* Install all the fields into the template. */
1552 finish_record_type (gnu_template_type, gnu_template_fields, 0, 0);
1553 TREE_READONLY (gnu_template_type) = 1;
1554
1555 /* Now make the array of arrays and update the pointer to the array
1556 in the fat pointer. Note that it is the first field. */
1557
1558 tem = gnat_to_gnu_type (Component_Type (gnat_entity));
1559
1560 /* Get and validate any specified Component_Size, but if Packed,
1561 ignore it since the front end will have taken care of it. */
1562 gnu_comp_size
1563 = validate_size (Component_Size (gnat_entity), tem,
1564 gnat_entity,
1565 (Is_Bit_Packed_Array (gnat_entity)
1566 ? TYPE_DECL : VAR_DECL), 1,
1567 Has_Component_Size_Clause (gnat_entity));
1568
1569 if (Has_Atomic_Components (gnat_entity))
1570 check_ok_for_atomic (tem, gnat_entity, 1);
1571
1572 /* If the component type is a RECORD_TYPE that has a self-referential
1573 size, use the maxium size. */
1574 if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE
1575 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
1576 gnu_comp_size = max_size (TYPE_SIZE (tem), 1);
1577
1578 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1579 {
1580 tem = make_type_from_size (tem, gnu_comp_size, 0);
1581 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
1582 "C_PAD", 0, definition, 1);
1583 }
1584
1585 if (Has_Volatile_Components (gnat_entity))
1586 tem = build_qualified_type (tem,
1587 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
1588
1589 /* If Component_Size is not already specified, annotate it with the
1590 size of the component. */
1591 if (Unknown_Component_Size (gnat_entity))
1592 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
1593
1594 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
1595 size_binop (MULT_EXPR, gnu_max_size,
1596 TYPE_SIZE_UNIT (tem)));
1597 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
1598 size_binop (MULT_EXPR,
1599 convert (bitsizetype,
1600 gnu_max_size),
1601 TYPE_SIZE (tem)));
1602
1603 for (index = ndim - 1; index >= 0; index--)
1604 {
1605 tem = build_array_type (tem, gnu_index_types[index]);
1606 TYPE_MULTI_ARRAY_P (tem) = (index > 0);
1607
1608 /* ??? For now, we say that any component of aggregate type is
1609 addressable because the front end may take 'Reference of it.
1610 But we have to make it addressable if it must be passed by
1611 reference or it that is the default. */
1612 TYPE_NONALIASED_COMPONENT (tem)
1613 = (! Has_Aliased_Components (gnat_entity)
1614 && ! AGGREGATE_TYPE_P (TREE_TYPE (tem)));
1615 }
1616
1617 /* If an alignment is specified, use it if valid. But ignore it for
1618 types that represent the unpacked base type for packed arrays. */
1619 if (No (Packed_Array_Type (gnat_entity))
1620 && Known_Alignment (gnat_entity))
1621 {
1622 if (No (Alignment (gnat_entity)))
1623 gigi_abort (124);
1624
1625 TYPE_ALIGN (tem)
1626 = validate_alignment (Alignment (gnat_entity), gnat_entity,
1627 TYPE_ALIGN (tem));
1628 }
1629
1630 TYPE_CONVENTION_FORTRAN_P (tem)
1631 = (Convention (gnat_entity) == Convention_Fortran);
1632 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
1633
1634 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
1635 corresponding fat pointer. */
1636 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
1637 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
1638 TYPE_MODE (gnu_type) = BLKmode;
1639 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
1640 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
1641
1642 /* If the maximum size doesn't overflow, use it. */
1643 if (TREE_CODE (gnu_max_size) == INTEGER_CST
1644 && ! TREE_OVERFLOW (gnu_max_size))
1645 TYPE_SIZE (tem)
1646 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
1647 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
1648 && ! TREE_OVERFLOW (gnu_max_size_unit))
1649 TYPE_SIZE_UNIT (tem)
1650 = size_binop (MIN_EXPR, gnu_max_size_unit,
1651 TYPE_SIZE_UNIT (tem));
1652
1653 create_type_decl (create_concat_name (gnat_entity, "XUA"),
1654 tem, 0, ! Comes_From_Source (gnat_entity),
1655 debug_info_p);
1656 rest_of_type_compilation (gnu_fat_type, global_bindings_p ());
1657
1658 /* Create a record type for the object and its template and
1659 set the template at a negative offset. */
1660 tem = build_unc_object_type (gnu_template_type, tem,
1661 create_concat_name (gnat_entity, "XUT"));
1662 DECL_FIELD_OFFSET (TYPE_FIELDS (tem))
1663 = size_binop (MINUS_EXPR, size_zero_node,
1664 byte_position (TREE_CHAIN (TYPE_FIELDS (tem))));
1665 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node;
1666 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem)))
1667 = bitsize_zero_node;
1668 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
1669 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
1670
1671 /* Give the thin pointer type a name. */
1672 create_type_decl (create_concat_name (gnat_entity, "XUX"),
1673 build_pointer_type (tem), 0,
1674 ! Comes_From_Source (gnat_entity), debug_info_p);
1675 }
1676 break;
1677
1678 case E_String_Subtype:
1679 case E_Array_Subtype:
1680
1681 /* This is the actual data type for array variables. Multidimensional
1682 arrays are implemented in the gnu tree as arrays of arrays. Note
1683 that for the moment arrays which have sparse enumeration subtypes as
1684 index components create sparse arrays, which is obviously space
1685 inefficient but so much easier to code for now.
1686
1687 Also note that the subtype never refers to the unconstrained
1688 array type, which is somewhat at variance with Ada semantics.
1689
1690 First check to see if this is simply a renaming of the array
1691 type. If so, the result is the array type. */
1692
1693 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
1694 if (! Is_Constrained (gnat_entity))
1695 break;
1696 else
1697 {
1698 int index;
1699 int array_dim = Number_Dimensions (gnat_entity);
1700 int first_dim
1701 = ((Convention (gnat_entity) == Convention_Fortran)
1702 ? array_dim - 1 : 0);
1703 int next_dim
1704 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
1705 Entity_Id gnat_ind_subtype;
1706 Entity_Id gnat_ind_base_subtype;
1707 tree gnu_base_type = gnu_type;
1708 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
1709 tree gnu_comp_size = 0;
1710 tree gnu_max_size = size_one_node;
1711 tree gnu_max_size_unit;
1712 int need_index_type_struct = 0;
1713 int max_overflow = 0;
1714
1715 /* First create the gnu types for each index. Create types for
1716 debugging information to point to the index types if the
1717 are not integer types, have variable bounds, or are
1718 wider than sizetype. */
1719
1720 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
1721 gnat_ind_base_subtype
1722 = First_Index (Implementation_Base_Type (gnat_entity));
1723 index < array_dim && index >= 0;
1724 index += next_dim,
1725 gnat_ind_subtype = Next_Index (gnat_ind_subtype),
1726 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
1727 {
1728 tree gnu_index_subtype
1729 = get_unpadded_type (Etype (gnat_ind_subtype));
1730 tree gnu_min
1731 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
1732 tree gnu_max
1733 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
1734 tree gnu_base_subtype
1735 = get_unpadded_type (Etype (gnat_ind_base_subtype));
1736 tree gnu_base_min
1737 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
1738 tree gnu_base_max
1739 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
1740 tree gnu_base_type = get_base_type (gnu_base_subtype);
1741 tree gnu_base_base_min
1742 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
1743 tree gnu_base_base_max
1744 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
1745 tree gnu_high;
1746 tree gnu_this_max;
1747
1748 /* If the minimum and maximum values both overflow in
1749 SIZETYPE, but the difference in the original type
1750 does not overflow in SIZETYPE, ignore the overflow
1751 indications. */
1752 if ((TYPE_PRECISION (gnu_index_subtype)
1753 > TYPE_PRECISION (sizetype))
1754 && TREE_CODE (gnu_min) == INTEGER_CST
1755 && TREE_CODE (gnu_max) == INTEGER_CST
1756 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
1757 && (! TREE_OVERFLOW
1758 (fold (build (MINUS_EXPR, gnu_index_subtype,
1759 TYPE_MAX_VALUE (gnu_index_subtype),
1760 TYPE_MIN_VALUE (gnu_index_subtype))))))
1761 TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
1762 = TREE_CONSTANT_OVERFLOW (gnu_min)
1763 = TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
1764
1765 /* Similarly, if the range is null, use bounds of 1..0 for
1766 the sizetype bounds. */
1767 else if ((TYPE_PRECISION (gnu_index_subtype)
1768 > TYPE_PRECISION (sizetype))
1769 && TREE_CODE (gnu_min) == INTEGER_CST
1770 && TREE_CODE (gnu_max) == INTEGER_CST
1771 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
1772 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
1773 TYPE_MIN_VALUE (gnu_index_subtype)))
1774 gnu_min = size_one_node, gnu_max = size_zero_node;
1775
1776 /* Now compute the size of this bound. We need to provide
1777 GCC with an upper bound to use but have to deal with the
1778 "superflat" case. There are three ways to do this. If we
1779 can prove that the array can never be superflat, we can
1780 just use the high bound of the index subtype. If we can
1781 prove that the low bound minus one can't overflow, we
1782 can do this as MAX (hb, lb - 1). Otherwise, we have to use
1783 the expression hb >= lb ? hb : lb - 1. */
1784 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
1785
1786 /* See if the base array type is already flat. If it is, we
1787 are probably compiling an ACVC test, but it will cause the
1788 code below to malfunction if we don't handle it specially. */
1789 if (TREE_CODE (gnu_base_min) == INTEGER_CST
1790 && TREE_CODE (gnu_base_max) == INTEGER_CST
1791 && ! TREE_CONSTANT_OVERFLOW (gnu_base_min)
1792 && ! TREE_CONSTANT_OVERFLOW (gnu_base_max)
1793 && tree_int_cst_lt (gnu_base_max, gnu_base_min))
1794 gnu_high = size_zero_node, gnu_min = size_one_node;
1795
1796 /* If gnu_high is now an integer which overflowed, the array
1797 cannot be superflat. */
1798 else if (TREE_CODE (gnu_high) == INTEGER_CST
1799 && TREE_OVERFLOW (gnu_high))
1800 gnu_high = gnu_max;
1801 else if (TREE_UNSIGNED (gnu_base_subtype)
1802 || TREE_CODE (gnu_high) == INTEGER_CST)
1803 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
1804 else
1805 gnu_high
1806 = build_cond_expr
1807 (sizetype, build_binary_op (GE_EXPR, integer_type_node,
1808 gnu_max, gnu_min),
1809 gnu_max, gnu_high);
1810
1811 gnu_index_type[index]
1812 = create_index_type (gnu_min, gnu_high, gnu_index_subtype);
1813
1814 /* Also compute the maximum size of the array. Here we
1815 see if any constraint on the index type of the base type
1816 can be used in the case of self-referential bound on
1817 the index type of the subtype. We look for a non-"infinite"
1818 and non-self-referential bound from any type involved and
1819 handle each bound separately. */
1820
1821 if ((TREE_CODE (gnu_min) == INTEGER_CST
1822 && ! TREE_OVERFLOW (gnu_min)
1823 && ! operand_equal_p (gnu_min, gnu_base_base_min, 0))
1824 || ! CONTAINS_PLACEHOLDER_P (gnu_min))
1825 gnu_base_min = gnu_min;
1826
1827 if ((TREE_CODE (gnu_max) == INTEGER_CST
1828 && ! TREE_OVERFLOW (gnu_max)
1829 && ! operand_equal_p (gnu_max, gnu_base_base_max, 0))
1830 || ! CONTAINS_PLACEHOLDER_P (gnu_max))
1831 gnu_base_max = gnu_max;
1832
1833 if ((TREE_CODE (gnu_base_min) == INTEGER_CST
1834 && TREE_CONSTANT_OVERFLOW (gnu_base_min))
1835 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
1836 || (TREE_CODE (gnu_base_max) == INTEGER_CST
1837 && TREE_CONSTANT_OVERFLOW (gnu_base_max))
1838 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
1839 max_overflow = 1;
1840
1841 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
1842 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
1843
1844 gnu_this_max
1845 = size_binop (MAX_EXPR,
1846 size_binop (PLUS_EXPR, size_one_node,
1847 size_binop (MINUS_EXPR, gnu_base_max,
1848 gnu_base_min)),
1849 size_zero_node);
1850
1851 if (TREE_CODE (gnu_this_max) == INTEGER_CST
1852 && TREE_CONSTANT_OVERFLOW (gnu_this_max))
1853 max_overflow = 1;
1854
1855 gnu_max_size
1856 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
1857
1858 if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
1859 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
1860 != INTEGER_CST)
1861 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
1862 || (TREE_TYPE (gnu_index_subtype) != 0
1863 && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
1864 != INTEGER_TYPE))
1865 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
1866 || (TYPE_PRECISION (gnu_index_subtype)
1867 > TYPE_PRECISION (sizetype)))
1868 need_index_type_struct = 1;
1869 }
1870
1871 /* Then flatten: create the array of arrays. */
1872
1873 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
1874
1875 /* One of the above calls might have caused us to be elaborated,
1876 so don't blow up if so. */
1877 if (present_gnu_tree (gnat_entity))
1878 {
1879 maybe_present = 1;
1880 break;
1881 }
1882
1883 /* Get and validate any specified Component_Size, but if Packed,
1884 ignore it since the front end will have taken care of it. */
1885 gnu_comp_size
1886 = validate_size (Component_Size (gnat_entity), gnu_type,
1887 gnat_entity,
1888 (Is_Bit_Packed_Array (gnat_entity)
1889 ? TYPE_DECL : VAR_DECL),
1890 1, Has_Component_Size_Clause (gnat_entity));
1891
1892 /* If the component type is a RECORD_TYPE that has a self-referential
1893 size, use the maxium size. */
1894 if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE
1895 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
1896 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1);
1897
1898 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
1899 {
1900 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0);
1901 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
1902 gnat_entity, "C_PAD", 0,
1903 definition, 1);
1904 }
1905
1906 if (Has_Volatile_Components (Base_Type (gnat_entity)))
1907 gnu_type = build_qualified_type (gnu_type,
1908 (TYPE_QUALS (gnu_type)
1909 | TYPE_QUAL_VOLATILE));
1910
1911 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
1912 TYPE_SIZE_UNIT (gnu_type));
1913 gnu_max_size = size_binop (MULT_EXPR,
1914 convert (bitsizetype, gnu_max_size),
1915 TYPE_SIZE (gnu_type));
1916
1917 /* We don't want any array types shared for two reasons: first,
1918 we want to keep differently-named types distinct; second,
1919 setting TYPE_MULTI_ARRAY_TYPE of one type can clobber
1920 another. */
1921 debug_no_type_hash = 1;
1922 for (index = array_dim - 1; index >= 0; index --)
1923 {
1924 gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
1925 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
1926 /* ??? For now, we say that any component of aggregate type is
1927 addressable because the front end may take 'Reference.
1928 But we have to make it addressable if it must be passed by
1929 reference or it that is the default. */
1930 TYPE_NONALIASED_COMPONENT (gnu_type)
1931 = (! Has_Aliased_Components (gnat_entity)
1932 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type)));
1933 }
1934
1935 /* If we are at file level and this is a multi-dimensional array, we
1936 need to make a variable corresponding to the stride of the
1937 inner dimensions. */
1938 if (global_bindings_p () && array_dim > 1)
1939 {
1940 tree gnu_str_name = get_identifier ("ST");
1941 tree gnu_arr_type;
1942
1943 for (gnu_arr_type = TREE_TYPE (gnu_type);
1944 TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
1945 gnu_arr_type = TREE_TYPE (gnu_arr_type),
1946 gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
1947 {
1948 TYPE_SIZE (gnu_arr_type)
1949 = elaborate_expression_1 (gnat_entity, gnat_entity,
1950 TYPE_SIZE (gnu_arr_type),
1951 gnu_str_name, definition, 0);
1952 TYPE_SIZE_UNIT (gnu_arr_type)
1953 = elaborate_expression_1
1954 (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type),
1955 concat_id_with_name (gnu_str_name, "U"), definition, 0);
1956 }
1957 }
1958
1959 /* If we need to write out a record type giving the names of
1960 the bounds, do it now. */
1961 if (need_index_type_struct && debug_info_p)
1962 {
1963 tree gnu_bound_rec_type = make_node (RECORD_TYPE);
1964 tree gnu_field_list = 0;
1965 tree gnu_field;
1966
1967 TYPE_NAME (gnu_bound_rec_type)
1968 = create_concat_name (gnat_entity, "XA");
1969
1970 for (index = array_dim - 1; index >= 0; index--)
1971 {
1972 tree gnu_type_name
1973 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
1974
1975 if (TREE_CODE (gnu_type_name) == TYPE_DECL)
1976 gnu_type_name = DECL_NAME (gnu_type_name);
1977
1978 gnu_field = create_field_decl (gnu_type_name,
1979 integer_type_node,
1980 gnu_bound_rec_type,
1981 0, NULL_TREE, NULL_TREE, 0);
1982 TREE_CHAIN (gnu_field) = gnu_field_list;
1983 gnu_field_list = gnu_field;
1984 }
1985
1986 finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0);
1987 }
1988
1989 debug_no_type_hash = 0;
1990 TYPE_CONVENTION_FORTRAN_P (gnu_type)
1991 = (Convention (gnat_entity) == Convention_Fortran);
1992 TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
1993 = Is_Packed_Array_Type (gnat_entity);
1994
1995 /* If our size depends on a placeholder and the maximum size doesn't
1996 overflow, use it. */
1997 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
1998 && ! (TREE_CODE (gnu_max_size) == INTEGER_CST
1999 && TREE_OVERFLOW (gnu_max_size))
2000 && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
2001 && TREE_OVERFLOW (gnu_max_size_unit))
2002 && ! max_overflow)
2003 {
2004 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
2005 TYPE_SIZE (gnu_type));
2006 TYPE_SIZE_UNIT (gnu_type)
2007 = size_binop (MIN_EXPR, gnu_max_size_unit,
2008 TYPE_SIZE_UNIT (gnu_type));
2009 }
2010
2011 /* Set our alias set to that of our base type. This gives all
2012 array subtypes the same alias set. */
2013 TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
2014 record_component_aliases (gnu_type);
2015 }
2016
2017 /* If this is a packed type, make this type the same as the packed
2018 array type, but do some adjusting in the type first. */
2019
2020 if (Present (Packed_Array_Type (gnat_entity)))
2021 {
2022 Entity_Id gnat_index;
2023 tree gnu_inner_type;
2024
2025 /* First finish the type we had been making so that we output
2026 debugging information for it */
2027 gnu_type = build_qualified_type (gnu_type,
2028 (TYPE_QUALS (gnu_type)
2029 | (TYPE_QUAL_VOLATILE
2030 * Treat_As_Volatile (gnat_entity))));
2031 set_lineno (gnat_entity, 0);
2032 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2033 ! Comes_From_Source (gnat_entity),
2034 debug_info_p);
2035 if (! Comes_From_Source (gnat_entity))
2036 DECL_ARTIFICIAL (gnu_decl) = 1;
2037
2038 /* Save it as our equivalent in case the call below elaborates
2039 this type again. */
2040 save_gnu_tree (gnat_entity, gnu_decl, 0);
2041
2042 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
2043 NULL_TREE, 0);
2044 this_made_decl = 1;
2045 gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
2046 save_gnu_tree (gnat_entity, NULL_TREE, 0);
2047
2048 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
2049 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type)
2050 || TYPE_IS_PADDING_P (gnu_inner_type)))
2051 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
2052
2053 /* We need to point the type we just made to our index type so
2054 the actual bounds can be put into a template. */
2055
2056 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
2057 && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0)
2058 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
2059 && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
2060 {
2061 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
2062 {
2063 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
2064 If it is, we need to make another type. */
2065 if (TYPE_MODULAR_P (gnu_inner_type))
2066 {
2067 tree gnu_subtype;
2068
2069 gnu_subtype = make_node (INTEGER_TYPE);
2070
2071 TREE_TYPE (gnu_subtype) = gnu_inner_type;
2072 TYPE_MIN_VALUE (gnu_subtype)
2073 = TYPE_MIN_VALUE (gnu_inner_type);
2074 TYPE_MAX_VALUE (gnu_subtype)
2075 = TYPE_MAX_VALUE (gnu_inner_type);
2076 TYPE_PRECISION (gnu_subtype)
2077 = TYPE_PRECISION (gnu_inner_type);
2078 TREE_UNSIGNED (gnu_subtype)
2079 = TREE_UNSIGNED (gnu_inner_type);
2080 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
2081 layout_type (gnu_subtype);
2082
2083 gnu_inner_type = gnu_subtype;
2084 }
2085
2086 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
2087 }
2088
2089 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
2090
2091 for (gnat_index = First_Index (gnat_entity);
2092 Present (gnat_index); gnat_index = Next_Index (gnat_index))
2093 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type,
2094 tree_cons (NULL_TREE,
2095 get_unpadded_type (Etype (gnat_index)),
2096 TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2097
2098 if (Convention (gnat_entity) != Convention_Fortran)
2099 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type,
2100 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
2101
2102 if (TREE_CODE (gnu_type) == RECORD_TYPE
2103 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
2104 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
2105 }
2106 }
2107
2108 /* Abort if packed array with no packed array type field set. */
2109 else if (Is_Packed (gnat_entity))
2110 gigi_abort (107);
2111
2112 break;
2113
2114 case E_String_Literal_Subtype:
2115 /* Create the type for a string literal. */
2116 {
2117 Entity_Id gnat_full_type
2118 = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
2119 && Present (Full_View (Etype (gnat_entity)))
2120 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
2121 tree gnu_string_type = get_unpadded_type (gnat_full_type);
2122 tree gnu_string_array_type
2123 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
2124 tree gnu_string_index_type
2125 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
2126 (TYPE_DOMAIN (gnu_string_array_type))));
2127 tree gnu_lower_bound
2128 = convert (gnu_string_index_type,
2129 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
2130 int length = UI_To_Int (String_Literal_Length (gnat_entity));
2131 tree gnu_length = ssize_int (length - 1);
2132 tree gnu_upper_bound
2133 = build_binary_op (PLUS_EXPR, gnu_string_index_type,
2134 gnu_lower_bound,
2135 convert (gnu_string_index_type, gnu_length));
2136 tree gnu_range_type
2137 = build_range_type (gnu_string_index_type,
2138 gnu_lower_bound, gnu_upper_bound);
2139 tree gnu_index_type
2140 = create_index_type (convert (sizetype,
2141 TYPE_MIN_VALUE (gnu_range_type)),
2142 convert (sizetype,
2143 TYPE_MAX_VALUE (gnu_range_type)),
2144 gnu_range_type);
2145
2146 gnu_type
2147 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
2148 gnu_index_type);
2149 }
2150 break;
2151
2152 /* Record Types and Subtypes
2153
2154 The following fields are defined on record types:
2155
2156 Has_Discriminants True if the record has discriminants
2157 First_Discriminant Points to head of list of discriminants
2158 First_Entity Points to head of list of fields
2159 Is_Tagged_Type True if the record is tagged
2160
2161 Implementation of Ada records and discriminated records:
2162
2163 A record type definition is transformed into the equivalent of a C
2164 struct definition. The fields that are the discriminants which are
2165 found in the Full_Type_Declaration node and the elements of the
2166 Component_List found in the Record_Type_Definition node. The
2167 Component_List can be a recursive structure since each Variant of
2168 the Variant_Part of the Component_List has a Component_List.
2169
2170 Processing of a record type definition comprises starting the list of
2171 field declarations here from the discriminants and the calling the
2172 function components_to_record to add the rest of the fields from the
2173 component list and return the gnu type node. The function
2174 components_to_record will call itself recursively as it traverses
2175 the tree. */
2176
2177 case E_Record_Type:
2178 if (Has_Complex_Representation (gnat_entity))
2179 {
2180 gnu_type
2181 = build_complex_type
2182 (get_unpadded_type
2183 (Etype (Defining_Entity
2184 (First (Component_Items
2185 (Component_List
2186 (Type_Definition
2187 (Declaration_Node (gnat_entity)))))))));
2188
2189 break;
2190 }
2191
2192 {
2193 Node_Id full_definition = Declaration_Node (gnat_entity);
2194 Node_Id record_definition = Type_Definition (full_definition);
2195 Entity_Id gnat_field;
2196 tree gnu_field;
2197 tree gnu_field_list = NULL_TREE;
2198 tree gnu_get_parent;
2199 int packed = (Is_Packed (gnat_entity) ? 1
2200 : (Component_Alignment (gnat_entity)
2201 == Calign_Storage_Unit) ? -1
2202 : 0);
2203 int has_rep = Has_Specified_Layout (gnat_entity);
2204 int all_rep = has_rep;
2205 int is_extension
2206 = (Is_Tagged_Type (gnat_entity)
2207 && Nkind (record_definition) == N_Derived_Type_Definition);
2208
2209 /* See if all fields have a rep clause. Stop when we find one
2210 that doesn't. */
2211 for (gnat_field = First_Entity (gnat_entity);
2212 Present (gnat_field) && all_rep;
2213 gnat_field = Next_Entity (gnat_field))
2214 if ((Ekind (gnat_field) == E_Component
2215 || Ekind (gnat_field) == E_Discriminant)
2216 && No (Component_Clause (gnat_field)))
2217 all_rep = 0;
2218
2219 /* If this is a record extension, go a level further to find the
2220 record definition. Also, verify we have a Parent_Subtype. */
2221 if (is_extension)
2222 {
2223 if (! type_annotate_only
2224 || Present (Record_Extension_Part (record_definition)))
2225 record_definition = Record_Extension_Part (record_definition);
2226
2227 if (! type_annotate_only && No (Parent_Subtype (gnat_entity)))
2228 gigi_abort (121);
2229 }
2230
2231 /* Make a node for the record. If we are not defining the record,
2232 suppress expanding incomplete types and save the node as the type
2233 for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
2234 and reset TYPE_DUMMY_P to show it's no longer a dummy.
2235
2236 It is very tempting to delay resetting this bit until we are done
2237 with completing the type, e.g. to let possible intermediate
2238 elaboration of access types designating the record know it is not
2239 complete and arrange for update_pointer_to to fix things up later.
2240
2241 It would be wrong, however, because dummy types are expected only
2242 to be created for Ada incomplete or private types, which is not
2243 what we have here. Doing so would make other parts of gigi think
2244 we are dealing with a really incomplete or private type, and have
2245 nasty side effects, typically on the generation of the associated
2246 debugging information. */
2247 gnu_type = make_dummy_type (gnat_entity);
2248 TYPE_DUMMY_P (gnu_type) = 0;
2249
2250 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
2251 DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
2252
2253 TYPE_ALIGN (gnu_type) = 0;
2254 TYPE_PACKED (gnu_type) = packed != 0 || has_rep;
2255
2256 if (! definition)
2257 {
2258 defer_incomplete_level++;
2259 this_deferred = 1;
2260 set_lineno (gnat_entity, 0);
2261 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2262 ! Comes_From_Source (gnat_entity),
2263 debug_info_p);
2264 save_gnu_tree (gnat_entity, gnu_decl, 0);
2265 this_made_decl = saved = 1;
2266 }
2267
2268 /* If both a size and rep clause was specified, put the size in
2269 the record type now so that it can get the proper mode. */
2270 if (has_rep && Known_Esize (gnat_entity))
2271 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
2272
2273 /* Always set the alignment here so that it can be used to
2274 set the mode, if it is making the alignment stricter. If
2275 it is invalid, it will be checked again below. If this is to
2276 be Atomic, choose a default alignment of a word unless we know
2277 the size and it's smaller. */
2278 if (Known_Alignment (gnat_entity))
2279 TYPE_ALIGN (gnu_type)
2280 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
2281 else if (Is_Atomic (gnat_entity))
2282 TYPE_ALIGN (gnu_type)
2283 = (esize >= BITS_PER_WORD ? BITS_PER_WORD
2284 : 1 << ((floor_log2 (esize) - 1) + 1));
2285
2286 /* If we have a Parent_Subtype, make a field for the parent. If
2287 this record has rep clauses, force the position to zero. */
2288 if (Present (Parent_Subtype (gnat_entity)))
2289 {
2290 tree gnu_parent;
2291
2292 /* A major complexity here is that the parent subtype will
2293 reference our discriminants. But those must reference
2294 the parent component of this record. So here we will
2295 initialize each of those components to a COMPONENT_REF.
2296 The first operand of that COMPONENT_REF is another
2297 COMPONENT_REF which will be filled in below, once
2298 the parent type can be safely built. */
2299
2300 gnu_get_parent = build (COMPONENT_REF, void_type_node,
2301 build (PLACEHOLDER_EXPR, gnu_type),
2302 build_decl (FIELD_DECL, NULL_TREE,
2303 NULL_TREE));
2304
2305 if (Has_Discriminants (gnat_entity))
2306 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2307 Present (gnat_field);
2308 gnat_field = Next_Stored_Discriminant (gnat_field))
2309 if (Present (Corresponding_Discriminant (gnat_field)))
2310 save_gnu_tree
2311 (gnat_field,
2312 build (COMPONENT_REF,
2313 get_unpadded_type (Etype (gnat_field)),
2314 gnu_get_parent,
2315 gnat_to_gnu_entity (Corresponding_Discriminant
2316 (gnat_field),
2317 NULL_TREE, 0)),
2318 1);
2319
2320 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
2321
2322 gnu_field_list
2323 = create_field_decl (get_identifier
2324 (Get_Name_String (Name_uParent)),
2325 gnu_parent, gnu_type, 0,
2326 has_rep ? TYPE_SIZE (gnu_parent) : 0,
2327 has_rep ? bitsize_zero_node : 0, 1);
2328 DECL_INTERNAL_P (gnu_field_list) = 1;
2329
2330 TREE_TYPE (gnu_get_parent) = gnu_parent;
2331 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
2332 }
2333
2334 /* Add the fields for the discriminants into the record. */
2335 if (! Is_Unchecked_Union (gnat_entity)
2336 && Has_Discriminants (gnat_entity))
2337 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2338 Present (gnat_field);
2339 gnat_field = Next_Stored_Discriminant (gnat_field))
2340 {
2341 /* If this is a record extension and this discriminant
2342 is the renaming of another discriminant, we've already
2343 handled the discriminant above. */
2344 if (Present (Parent_Subtype (gnat_entity))
2345 && Present (Corresponding_Discriminant (gnat_field)))
2346 continue;
2347
2348 gnu_field
2349 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
2350
2351 /* Make an expression using a PLACEHOLDER_EXPR from the
2352 FIELD_DECL node just created and link that with the
2353 corresponding GNAT defining identifier. Then add to the
2354 list of fields. */
2355 save_gnu_tree (gnat_field,
2356 build (COMPONENT_REF, TREE_TYPE (gnu_field),
2357 build (PLACEHOLDER_EXPR,
2358 DECL_CONTEXT (gnu_field)),
2359 gnu_field),
2360 1);
2361
2362 TREE_CHAIN (gnu_field) = gnu_field_list;
2363 gnu_field_list = gnu_field;
2364 }
2365
2366 /* Put the discriminants into the record (backwards), so we can
2367 know the appropriate discriminant to use for the names of the
2368 variants. */
2369 TYPE_FIELDS (gnu_type) = gnu_field_list;
2370
2371 /* Add the listed fields into the record and finish up. */
2372 components_to_record (gnu_type, Component_List (record_definition),
2373 gnu_field_list, packed, definition, 0,
2374 0, all_rep);
2375
2376 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2377 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
2378
2379 /* If this is an extension type, reset the tree for any
2380 inherited discriminants. Also remove the PLACEHOLDER_EXPR
2381 for non-inherited discriminants. */
2382 if (! Is_Unchecked_Union (gnat_entity)
2383 && Has_Discriminants (gnat_entity))
2384 for (gnat_field = First_Stored_Discriminant (gnat_entity);
2385 Present (gnat_field);
2386 gnat_field = Next_Stored_Discriminant (gnat_field))
2387 {
2388 if (Present (Parent_Subtype (gnat_entity))
2389 && Present (Corresponding_Discriminant (gnat_field)))
2390 save_gnu_tree (gnat_field, NULL_TREE, 0);
2391 else
2392 {
2393 gnu_field = get_gnu_tree (gnat_field);
2394 save_gnu_tree (gnat_field, NULL_TREE, 0);
2395 save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0);
2396 }
2397 }
2398
2399 /* If it is a tagged record force the type to BLKmode to insure
2400 that these objects will always be placed in memory. Do the
2401 same thing for limited record types. */
2402 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
2403 TYPE_MODE (gnu_type) = BLKmode;
2404
2405 /* If this is a derived type, we must make the alias set of this type
2406 the same as that of the type we are derived from. We assume here
2407 that the other type is already frozen. */
2408 if (Etype (gnat_entity) != gnat_entity
2409 && ! (Is_Private_Type (Etype (gnat_entity))
2410 && Full_View (Etype (gnat_entity)) == gnat_entity))
2411 {
2412 TYPE_ALIAS_SET (gnu_type)
2413 = get_alias_set (gnat_to_gnu_type (Etype (gnat_entity)));
2414 record_component_aliases (gnu_type);
2415 }
2416
2417 /* Fill in locations of fields. */
2418 annotate_rep (gnat_entity, gnu_type);
2419
2420 /* If there are any entities in the chain corresponding to
2421 components that we did not elaborate, ensure we elaborate their
2422 types if they are Itypes. */
2423 for (gnat_temp = First_Entity (gnat_entity);
2424 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
2425 if ((Ekind (gnat_temp) == E_Component
2426 || Ekind (gnat_temp) == E_Discriminant)
2427 && Is_Itype (Etype (gnat_temp))
2428 && ! present_gnu_tree (gnat_temp))
2429 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
2430 }
2431 break;
2432
2433 case E_Class_Wide_Subtype:
2434 /* If an equivalent type is present, that is what we should use.
2435 Otherwise, fall through to handle this like a record subtype
2436 since it may have constraints. */
2437
2438 if (Present (Equivalent_Type (gnat_entity)))
2439 {
2440 gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
2441 NULL_TREE, 0);
2442 maybe_present = 1;
2443 break;
2444 }
2445
2446 /* ... fall through ... */
2447
2448 case E_Record_Subtype:
2449
2450 /* If Cloned_Subtype is Present it means this record subtype has
2451 identical layout to that type or subtype and we should use
2452 that GCC type for this one. The front end guarantees that
2453 the component list is shared. */
2454 if (Present (Cloned_Subtype (gnat_entity)))
2455 {
2456 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
2457 NULL_TREE, 0);
2458 maybe_present = 1;
2459 }
2460
2461 /* Otherwise, first ensure the base type is elaborated. Then, if we are
2462 changing the type, make a new type with each field having the
2463 type of the field in the new subtype but having the position
2464 computed by transforming every discriminant reference according
2465 to the constraints. We don't see any difference between
2466 private and nonprivate type here since derivations from types should
2467 have been deferred until the completion of the private type. */
2468 else
2469 {
2470 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
2471 tree gnu_base_type;
2472 tree gnu_orig_type;
2473
2474 if (! definition)
2475 defer_incomplete_level++, this_deferred = 1;
2476
2477 /* Get the base type initially for its alignment and sizes. But
2478 if it is a padded type, we do all the other work with the
2479 unpadded type. */
2480 gnu_type = gnu_orig_type = gnu_base_type
2481 = gnat_to_gnu_type (gnat_base_type);
2482
2483 if (TREE_CODE (gnu_type) == RECORD_TYPE
2484 && TYPE_IS_PADDING_P (gnu_type))
2485 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2486
2487 if (present_gnu_tree (gnat_entity))
2488 {
2489 maybe_present = 1;
2490 break;
2491 }
2492
2493 /* When the type has discriminants, and these discriminants
2494 affect the shape of what it built, factor them in.
2495
2496 If we are making a subtype of an Unchecked_Union (must be an
2497 Itype), just return the type.
2498
2499 We can't just use Is_Constrained because private subtypes without
2500 discriminants of full types with discriminants with default
2501 expressions are Is_Constrained but aren't constrained! */
2502
2503 if (IN (Ekind (gnat_base_type), Record_Kind)
2504 && ! Is_For_Access_Subtype (gnat_entity)
2505 && ! Is_Unchecked_Union (gnat_base_type)
2506 && Is_Constrained (gnat_entity)
2507 && Stored_Constraint (gnat_entity) != No_Elist
2508 && Present (Discriminant_Constraint (gnat_entity)))
2509 {
2510 Entity_Id gnat_field;
2511 Entity_Id gnat_root_type;
2512 tree gnu_field_list = 0;
2513 tree gnu_pos_list
2514 = compute_field_positions (gnu_orig_type, NULL_TREE,
2515 size_zero_node, bitsize_zero_node,
2516 BIGGEST_ALIGNMENT);
2517 tree gnu_subst_list
2518 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
2519 definition);
2520 tree gnu_temp;
2521
2522 /* If this is a derived type, we may be seeing fields from any
2523 original records, so add those positions and discriminant
2524 substitutions to our lists. */
2525 for (gnat_root_type = gnat_base_type;
2526 Underlying_Type (Etype (gnat_root_type)) != gnat_root_type;
2527 gnat_root_type = Underlying_Type (Etype (gnat_root_type)))
2528 {
2529 gnu_pos_list
2530 = compute_field_positions
2531 (gnat_to_gnu_type (Etype (gnat_root_type)),
2532 gnu_pos_list, size_zero_node, bitsize_zero_node,
2533 BIGGEST_ALIGNMENT);
2534
2535 if (Present (Parent_Subtype (gnat_root_type)))
2536 gnu_subst_list
2537 = substitution_list (Parent_Subtype (gnat_root_type),
2538 Empty, gnu_subst_list, definition);
2539 }
2540
2541 gnu_type = make_node (RECORD_TYPE);
2542 TYPE_NAME (gnu_type) = gnu_entity_id;
2543 TYPE_STUB_DECL (gnu_type)
2544 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
2545 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2546
2547 for (gnat_field = First_Entity (gnat_entity);
2548 Present (gnat_field); gnat_field = Next_Entity (gnat_field))
2549 if (Ekind (gnat_field) == E_Component
2550 || Ekind (gnat_field) == E_Discriminant)
2551 {
2552 tree gnu_old_field
2553 = gnat_to_gnu_entity
2554 (Original_Record_Component (gnat_field), NULL_TREE, 0);
2555 tree gnu_offset
2556 = TREE_VALUE (purpose_member (gnu_old_field,
2557 gnu_pos_list));
2558 tree gnu_pos = TREE_PURPOSE (gnu_offset);
2559 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
2560 tree gnu_field_type
2561 = gnat_to_gnu_type (Etype (gnat_field));
2562 tree gnu_size = TYPE_SIZE (gnu_field_type);
2563 tree gnu_new_pos = 0;
2564 unsigned int offset_align
2565 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
2566 1);
2567 tree gnu_field;
2568
2569 /* If there was a component clause, the field types must be
2570 the same for the type and subtype, so copy the data from
2571 the old field to avoid recomputation here. */
2572 if (Present (Component_Clause
2573 (Original_Record_Component (gnat_field))))
2574 {
2575 gnu_size = DECL_SIZE (gnu_old_field);
2576 gnu_field_type = TREE_TYPE (gnu_old_field);
2577 }
2578
2579 /* If this was a bitfield, get the size from the old field.
2580 Also ensure the type can be placed into a bitfield. */
2581 else if (DECL_BIT_FIELD (gnu_old_field))
2582 {
2583 gnu_size = DECL_SIZE (gnu_old_field);
2584 if (TYPE_MODE (gnu_field_type) == BLKmode
2585 && TREE_CODE (gnu_field_type) == RECORD_TYPE
2586 && host_integerp (TYPE_SIZE (gnu_field_type), 1))
2587 gnu_field_type = make_packable_type (gnu_field_type);
2588 }
2589
2590 if (CONTAINS_PLACEHOLDER_P (gnu_pos))
2591 for (gnu_temp = gnu_subst_list;
2592 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2593 gnu_pos = substitute_in_expr (gnu_pos,
2594 TREE_PURPOSE (gnu_temp),
2595 TREE_VALUE (gnu_temp));
2596
2597 /* If the size is now a constant, we can set it as the
2598 size of the field when we make it. Otherwise, we need
2599 to deal with it specially. */
2600 if (TREE_CONSTANT (gnu_pos))
2601 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
2602
2603 gnu_field
2604 = create_field_decl
2605 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
2606 0, gnu_size, gnu_new_pos,
2607 ! DECL_NONADDRESSABLE_P (gnu_old_field));
2608
2609 if (! TREE_CONSTANT (gnu_pos))
2610 {
2611 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
2612 DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
2613 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
2614 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
2615 DECL_SIZE (gnu_field) = gnu_size;
2616 DECL_SIZE_UNIT (gnu_field)
2617 = convert (sizetype,
2618 size_binop (CEIL_DIV_EXPR, gnu_size,
2619 bitsize_unit_node));
2620 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
2621 }
2622
2623 DECL_INTERNAL_P (gnu_field)
2624 = DECL_INTERNAL_P (gnu_old_field);
2625 SET_DECL_ORIGINAL_FIELD (gnu_field,
2626 (DECL_ORIGINAL_FIELD (gnu_old_field) != 0
2627 ? DECL_ORIGINAL_FIELD (gnu_old_field)
2628 : gnu_old_field));
2629 DECL_DISCRIMINANT_NUMBER (gnu_field)
2630 = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
2631 TREE_THIS_VOLATILE (gnu_field)
2632 = TREE_THIS_VOLATILE (gnu_old_field);
2633 TREE_CHAIN (gnu_field) = gnu_field_list;
2634 gnu_field_list = gnu_field;
2635 save_gnu_tree (gnat_field, gnu_field, 0);
2636 }
2637
2638 finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0);
2639
2640 /* Now set the size, alignment and alias set of the new type to
2641 match that of the old one, doing any substitutions, as
2642 above. */
2643 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
2644 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
2645 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
2646 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
2647 TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
2648 record_component_aliases (gnu_type);
2649
2650 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
2651 for (gnu_temp = gnu_subst_list;
2652 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2653 TYPE_SIZE (gnu_type)
2654 = substitute_in_expr (TYPE_SIZE (gnu_type),
2655 TREE_PURPOSE (gnu_temp),
2656 TREE_VALUE (gnu_temp));
2657
2658 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
2659 for (gnu_temp = gnu_subst_list;
2660 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2661 TYPE_SIZE_UNIT (gnu_type)
2662 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
2663 TREE_PURPOSE (gnu_temp),
2664 TREE_VALUE (gnu_temp));
2665
2666 if (TYPE_ADA_SIZE (gnu_type) != 0
2667 && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
2668 for (gnu_temp = gnu_subst_list;
2669 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
2670 SET_TYPE_ADA_SIZE (gnu_type,
2671 substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
2672 TREE_PURPOSE (gnu_temp),
2673 TREE_VALUE (gnu_temp)));
2674
2675 /* Recompute the mode of this record type now that we know its
2676 actual size. */
2677 compute_record_mode (gnu_type);
2678
2679 /* Fill in locations of fields. */
2680 annotate_rep (gnat_entity, gnu_type);
2681 }
2682
2683 /* If we've made a new type, record it and make an XVS type to show
2684 what this is a subtype of. Some debuggers require the XVS
2685 type to be output first, so do it in that order. */
2686 if (gnu_type != gnu_orig_type)
2687 {
2688 if (debug_info_p)
2689 {
2690 tree gnu_subtype_marker = make_node (RECORD_TYPE);
2691 tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
2692
2693 if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
2694 gnu_orig_name = DECL_NAME (gnu_orig_name);
2695
2696 TYPE_NAME (gnu_subtype_marker)
2697 = create_concat_name (gnat_entity, "XVS");
2698 finish_record_type (gnu_subtype_marker,
2699 create_field_decl (gnu_orig_name,
2700 integer_type_node,
2701 gnu_subtype_marker,
2702 0, NULL_TREE,
2703 NULL_TREE, 0),
2704 0, 0);
2705 }
2706
2707 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
2708 TYPE_NAME (gnu_type) = gnu_entity_id;
2709 TYPE_STUB_DECL (gnu_type)
2710 = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type),
2711 gnu_type));
2712 DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1;
2713 DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p;
2714 rest_of_type_compilation (gnu_type, global_bindings_p ());
2715 }
2716
2717 /* Otherwise, go down all the components in the new type and
2718 make them equivalent to those in the base type. */
2719 else
2720 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
2721 gnat_temp = Next_Entity (gnat_temp))
2722 if ((Ekind (gnat_temp) == E_Discriminant
2723 && ! Is_Unchecked_Union (gnat_base_type))
2724 || Ekind (gnat_temp) == E_Component)
2725 save_gnu_tree (gnat_temp,
2726 get_gnu_tree
2727 (Original_Record_Component (gnat_temp)), 0);
2728 }
2729 break;
2730
2731 case E_Access_Subprogram_Type:
2732 /* If we are not defining this entity, and we have incomplete
2733 entities being processed above us, make a dummy type and
2734 fill it in later. */
2735 if (! definition && defer_incomplete_level != 0)
2736 {
2737 struct incomplete *p
2738 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
2739
2740 gnu_type
2741 = build_pointer_type
2742 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
2743 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
2744 ! Comes_From_Source (gnat_entity),
2745 debug_info_p);
2746 save_gnu_tree (gnat_entity, gnu_decl, 0);
2747 this_made_decl = saved = 1;
2748
2749 p->old_type = TREE_TYPE (gnu_type);
2750 p->full_type = Directly_Designated_Type (gnat_entity);
2751 p->next = defer_incomplete_list;
2752 defer_incomplete_list = p;
2753 break;
2754 }
2755
2756 /* ... fall through ... */
2757
2758 case E_Allocator_Type:
2759 case E_Access_Type:
2760 case E_Access_Attribute_Type:
2761 case E_Anonymous_Access_Type:
2762 case E_General_Access_Type:
2763 {
2764 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
2765 Entity_Id gnat_desig_full
2766 = ((IN (Ekind (Etype (gnat_desig_type)),
2767 Incomplete_Or_Private_Kind))
2768 ? Full_View (gnat_desig_type) : 0);
2769 /* We want to know if we'll be seeing the freeze node for any
2770 incomplete type we may be pointing to. */
2771 int in_main_unit
2772 = (Present (gnat_desig_full)
2773 ? In_Extended_Main_Code_Unit (gnat_desig_full)
2774 : In_Extended_Main_Code_Unit (gnat_desig_type));
2775 int got_fat_p = 0;
2776 int made_dummy = 0;
2777 tree gnu_desig_type = 0;
2778
2779 if (No (gnat_desig_full)
2780 && (Ekind (gnat_desig_type) == E_Class_Wide_Type
2781 || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype
2782 && Present (Equivalent_Type (gnat_desig_type)))))
2783 {
2784 if (Present (Equivalent_Type (gnat_desig_type)))
2785 {
2786 gnat_desig_full = Equivalent_Type (gnat_desig_type);
2787 if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind))
2788 gnat_desig_full = Full_View (gnat_desig_full);
2789 }
2790 else if (IN (Ekind (Root_Type (gnat_desig_type)),
2791 Incomplete_Or_Private_Kind))
2792 gnat_desig_full = Full_View (Root_Type (gnat_desig_type));
2793 }
2794
2795 if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full))
2796 gnat_desig_full = Corresponding_Record_Type (gnat_desig_full);
2797
2798 /* If either the designated type or its full view is an
2799 unconstrained array subtype, replace it with the type it's a
2800 subtype of. This avoids problems with multiple copies of
2801 unconstrained array types. */
2802 if (Ekind (gnat_desig_type) == E_Array_Subtype
2803 && ! Is_Constrained (gnat_desig_type))
2804 gnat_desig_type = Etype (gnat_desig_type);
2805 if (Present (gnat_desig_full)
2806 && Ekind (gnat_desig_full) == E_Array_Subtype
2807 && ! Is_Constrained (gnat_desig_full))
2808 gnat_desig_full = Etype (gnat_desig_full);
2809
2810 /* If the designated type is a subtype of an incomplete record type,
2811 use the parent type to avoid order of elaboration issues. This
2812 can lose some code efficiency, but there is no alternative. */
2813 if (Present (gnat_desig_full)
2814 && Ekind (gnat_desig_full) == E_Record_Subtype
2815 && Ekind (Etype (gnat_desig_full)) == E_Record_Type)
2816 gnat_desig_full = Etype (gnat_desig_full);
2817
2818 /* If we are pointing to an incomplete type whose completion is an
2819 unconstrained array, make a fat pointer type instead of a pointer
2820 to VOID. The two types in our fields will be pointers to VOID and
2821 will be replaced in update_pointer_to. Similiarly, if the type
2822 itself is a dummy type or an unconstrained array. Also make
2823 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
2824 pointers to it. */
2825
2826 if ((Present (gnat_desig_full)
2827 && Is_Array_Type (gnat_desig_full)
2828 && ! Is_Constrained (gnat_desig_full))
2829 || (present_gnu_tree (gnat_desig_type)
2830 && TYPE_IS_DUMMY_P (TREE_TYPE
2831 (get_gnu_tree (gnat_desig_type)))
2832 && Is_Array_Type (gnat_desig_type)
2833 && ! Is_Constrained (gnat_desig_type))
2834 || (present_gnu_tree (gnat_desig_type)
2835 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type)))
2836 == UNCONSTRAINED_ARRAY_TYPE)
2837 && (TYPE_POINTER_TO (TREE_TYPE
2838 (get_gnu_tree (gnat_desig_type)))
2839 == 0))
2840 || (No (gnat_desig_full) && ! in_main_unit
2841 && defer_incomplete_level != 0
2842 && ! present_gnu_tree (gnat_desig_type)
2843 && Is_Array_Type (gnat_desig_type)
2844 && ! Is_Constrained (gnat_desig_type)))
2845 {
2846 tree gnu_old
2847 = (present_gnu_tree (gnat_desig_type)
2848 ? gnat_to_gnu_type (gnat_desig_type)
2849 : make_dummy_type (gnat_desig_type));
2850 tree fields;
2851
2852 /* Show the dummy we get will be a fat pointer. */
2853 got_fat_p = made_dummy = 1;
2854
2855 /* If the call above got something that has a pointer, that
2856 pointer is our type. This could have happened either
2857 because the type was elaborated or because somebody
2858 else executed the code below. */
2859 gnu_type = TYPE_POINTER_TO (gnu_old);
2860 if (gnu_type == 0)
2861 {
2862 gnu_type = make_node (RECORD_TYPE);
2863 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
2864 TYPE_POINTER_TO (gnu_old) = gnu_type;
2865
2866 set_lineno (gnat_entity, 0);
2867 fields
2868 = chainon (chainon (NULL_TREE,
2869 create_field_decl
2870 (get_identifier ("P_ARRAY"),
2871 ptr_void_type_node, gnu_type,
2872 0, 0, 0, 0)),
2873 create_field_decl (get_identifier ("P_BOUNDS"),
2874 ptr_void_type_node,
2875 gnu_type, 0, 0, 0, 0));
2876
2877 /* Make sure we can place this into a register. */
2878 TYPE_ALIGN (gnu_type)
2879 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
2880 TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
2881 finish_record_type (gnu_type, fields, 0, 1);
2882
2883 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
2884 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
2885 = concat_id_with_name (get_entity_name (gnat_desig_type),
2886 "XUT");
2887 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
2888 }
2889 }
2890
2891 /* If we already know what the full type is, use it. */
2892 else if (Present (gnat_desig_full)
2893 && present_gnu_tree (gnat_desig_full))
2894 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
2895
2896 /* Get the type of the thing we are to point to and build a pointer
2897 to it. If it is a reference to an incomplete or private type with a
2898 full view that is a record, make a dummy type node and get the
2899 actual type later when we have verified it is safe. */
2900 else if (! in_main_unit
2901 && ! present_gnu_tree (gnat_desig_type)
2902 && Present (gnat_desig_full)
2903 && ! present_gnu_tree (gnat_desig_full)
2904 && Is_Record_Type (gnat_desig_full))
2905 {
2906 gnu_desig_type = make_dummy_type (gnat_desig_type);
2907 made_dummy = 1;
2908 }
2909
2910 /* Likewise if we are pointing to a record or array and we are to defer
2911 elaborating incomplete types. We do this since this access type
2912 may be the full view of some private type. Note that the
2913 unconstrained array case is handled above. */
2914 else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0
2915 && ! present_gnu_tree (gnat_desig_type)
2916 && ((Is_Record_Type (gnat_desig_type)
2917 || Is_Array_Type (gnat_desig_type))
2918 || (Present (gnat_desig_full)
2919 && (Is_Record_Type (gnat_desig_full)
2920 || Is_Array_Type (gnat_desig_full)))))
2921 {
2922 gnu_desig_type = make_dummy_type (gnat_desig_type);
2923 made_dummy = 1;
2924 }
2925 else if (gnat_desig_type == gnat_entity)
2926 {
2927 gnu_type = build_pointer_type (make_node (VOID_TYPE));
2928 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
2929 }
2930 else
2931 gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
2932
2933 /* It is possible that the above call to gnat_to_gnu_type resolved our
2934 type. If so, just return it. */
2935 if (present_gnu_tree (gnat_entity))
2936 {
2937 maybe_present = 1;
2938 break;
2939 }
2940
2941 /* If we have a GCC type for the designated type, possibly modify it
2942 if we are pointing only to constant objects and then make a pointer
2943 to it. Don't do this for unconstrained arrays. */
2944 if (gnu_type == 0 && gnu_desig_type != 0)
2945 {
2946 if (Is_Access_Constant (gnat_entity)
2947 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
2948 {
2949 gnu_desig_type
2950 = build_qualified_type
2951 (gnu_desig_type,
2952 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
2953
2954 /* Some extra processing is required if we are building a
2955 pointer to an incomplete type (in the GCC sense). We might
2956 have such a type if we just made a dummy, or directly out
2957 of the call to gnat_to_gnu_type above if we are processing
2958 an access type for a record component designating the
2959 record type itself. */
2960 if (! COMPLETE_TYPE_P (gnu_desig_type))
2961 {
2962 /* We must ensure that the pointer to variant we make will
2963 be processed by update_pointer_to when the initial type
2964 is completed. Pretend we made a dummy and let further
2965 processing act as usual. */
2966 made_dummy = 1;
2967
2968 /* We must ensure that update_pointer_to will not retrieve
2969 the dummy variant when building a properly qualified
2970 version of the complete type. We take advantage of the
2971 fact that get_qualified_type is requiring TYPE_NAMEs to
2972 match to influence build_qualified_type and then also
2973 update_pointer_to here. */
2974 TYPE_NAME (gnu_desig_type)
2975 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
2976 }
2977 }
2978
2979 gnu_type = build_pointer_type (gnu_desig_type);
2980 }
2981
2982 /* If we are not defining this object and we made a dummy pointer,
2983 save our current definition, evaluate the actual type, and replace
2984 the tentative type we made with the actual one. If we are to defer
2985 actually looking up the actual type, make an entry in the
2986 deferred list. */
2987
2988 if (! in_main_unit && made_dummy)
2989 {
2990 tree gnu_old_type
2991 = TYPE_FAT_POINTER_P (gnu_type)
2992 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
2993
2994 if (esize == POINTER_SIZE
2995 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
2996 gnu_type
2997 = build_pointer_type
2998 (TYPE_OBJECT_RECORD_TYPE
2999 (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
3000
3001 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3002 ! Comes_From_Source (gnat_entity),
3003 debug_info_p);
3004 save_gnu_tree (gnat_entity, gnu_decl, 0);
3005 this_made_decl = saved = 1;
3006
3007 if (defer_incomplete_level == 0)
3008 {
3009 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
3010 gnat_to_gnu_type (gnat_desig_type));
3011 /* Note that the call to gnat_to_gnu_type here might have
3012 updated gnu_old_type directly, in which case it is not a
3013 dummy type any more when we get into update_pointer_to.
3014
3015 This may happen for instance when the designated type is a
3016 record type, because their elaboration starts with an
3017 initial node from make_dummy_type, which may yield the same
3018 node as the one we got.
3019
3020 Besides, variants of this non-dummy type might have been
3021 created along the way. update_pointer_to is expected to
3022 properly take care of those situations. */
3023 }
3024 else
3025 {
3026 struct incomplete *p
3027 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3028
3029 p->old_type = gnu_old_type;
3030 p->full_type = gnat_desig_type;
3031 p->next = defer_incomplete_list;
3032 defer_incomplete_list = p;
3033 }
3034 }
3035 }
3036 break;
3037
3038 case E_Access_Protected_Subprogram_Type:
3039 if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
3040 gnu_type = build_pointer_type (void_type_node);
3041 else
3042 /* The runtime representation is the equivalent type. */
3043 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3044
3045 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3046 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3047 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
3048 && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
3049 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3050 NULL_TREE, 0);
3051
3052 break;
3053
3054 case E_Access_Subtype:
3055
3056 /* We treat this as identical to its base type; any constraint is
3057 meaningful only to the front end.
3058
3059 The designated type must be elaborated as well, if it does
3060 not have its own freeze node. Designated (sub)types created
3061 for constrained components of records with discriminants are
3062 not frozen by the front end and thus not elaborated by gigi,
3063 because their use may appear before the base type is frozen,
3064 and because it is not clear that they are needed anywhere in
3065 Gigi. With the current model, there is no correct place where
3066 they could be elaborated. */
3067
3068 gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
3069 if (Is_Itype (Directly_Designated_Type (gnat_entity))
3070 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
3071 && Is_Frozen (Directly_Designated_Type (gnat_entity))
3072 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
3073 {
3074 /* If we are not defining this entity, and we have incomplete
3075 entities being processed above us, make a dummy type and
3076 elaborate it later. */
3077 if (! definition && defer_incomplete_level != 0)
3078 {
3079 struct incomplete *p
3080 = (struct incomplete *) xmalloc (sizeof (struct incomplete));
3081 tree gnu_ptr_type
3082 = build_pointer_type
3083 (make_dummy_type (Directly_Designated_Type (gnat_entity)));
3084
3085 p->old_type = TREE_TYPE (gnu_ptr_type);
3086 p->full_type = Directly_Designated_Type (gnat_entity);
3087 p->next = defer_incomplete_list;
3088 defer_incomplete_list = p;
3089 }
3090 else if
3091 (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))),
3092 Incomplete_Or_Private_Kind))
3093 { ;}
3094 else
3095 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
3096 NULL_TREE, 0);
3097 }
3098
3099 maybe_present = 1;
3100 break;
3101
3102 /* Subprogram Entities
3103
3104 The following access functions are defined for subprograms (functions
3105 or procedures):
3106
3107 First_Formal The first formal parameter.
3108 Is_Imported Indicates that the subprogram has appeared in
3109 an INTERFACE or IMPORT pragma. For now we
3110 assume that the external language is C.
3111 Is_Inlined True if the subprogram is to be inlined.
3112
3113 In addition for function subprograms we have:
3114
3115 Etype Return type of the function.
3116
3117 Each parameter is first checked by calling must_pass_by_ref on its
3118 type to determine if it is passed by reference. For parameters which
3119 are copied in, if they are Ada IN OUT or OUT parameters, their return
3120 value becomes part of a record which becomes the return type of the
3121 function (C function - note that this applies only to Ada procedures
3122 so there is no Ada return type). Additional code to store back the
3123 parameters will be generated on the caller side. This transformation
3124 is done here, not in the front-end.
3125
3126 The intended result of the transformation can be seen from the
3127 equivalent source rewritings that follow:
3128
3129 struct temp {int a,b};
3130 procedure P (A,B: IN OUT ...) is temp P (int A,B) {
3131 .. ..
3132 end P; return {A,B};
3133 }
3134 procedure call
3135
3136 {
3137 temp t;
3138 P(X,Y); t = P(X,Y);
3139 X = t.a , Y = t.b;
3140 }
3141
3142 For subprogram types we need to perform mainly the same conversions to
3143 GCC form that are needed for procedures and function declarations. The
3144 only difference is that at the end, we make a type declaration instead
3145 of a function declaration. */
3146
3147 case E_Subprogram_Type:
3148 case E_Function:
3149 case E_Procedure:
3150 {
3151 /* The first GCC parameter declaration (a PARM_DECL node). The
3152 PARM_DECL nodes are chained through the TREE_CHAIN field, so this
3153 actually is the head of this parameter list. */
3154 tree gnu_param_list = NULL_TREE;
3155 /* The type returned by a function. If the subprogram is a procedure
3156 this type should be void_type_node. */
3157 tree gnu_return_type = void_type_node;
3158 /* List of fields in return type of procedure with copy in copy out
3159 parameters. */
3160 tree gnu_field_list = NULL_TREE;
3161 /* Non-null for subprograms containing parameters passed by copy in
3162 copy out (Ada IN OUT or OUT parameters not passed by reference),
3163 in which case it is the list of nodes used to specify the values of
3164 the in out/out parameters that are returned as a record upon
3165 procedure return. The TREE_PURPOSE of an element of this list is
3166 a field of the record and the TREE_VALUE is the PARM_DECL
3167 corresponding to that field. This list will be saved in the
3168 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
3169 tree gnu_return_list = NULL_TREE;
3170 Entity_Id gnat_param;
3171 int inline_flag = Is_Inlined (gnat_entity);
3172 int public_flag = Is_Public (gnat_entity);
3173 int extern_flag
3174 = (Is_Public (gnat_entity) && !definition) || imported_p;
3175 int pure_flag = Is_Pure (gnat_entity);
3176 int volatile_flag = No_Return (gnat_entity);
3177 int returns_by_ref = 0;
3178 int returns_unconstrained = 0;
3179 tree gnu_ext_name = create_concat_name (gnat_entity, 0);
3180 int has_copy_in_out = 0;
3181 int parmnum;
3182
3183 if (kind == E_Subprogram_Type && ! definition)
3184 /* A parameter may refer to this type, so defer completion
3185 of any incomplete types. */
3186 defer_incomplete_level++, this_deferred = 1;
3187
3188 /* If the subprogram has an alias, it is probably inherited, so
3189 we can use the original one. If the original "subprogram"
3190 is actually an enumeration literal, it may be the first use
3191 of its type, so we must elaborate that type now. */
3192 if (Present (Alias (gnat_entity)))
3193 {
3194 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
3195 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
3196
3197 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
3198 gnu_expr, 0);
3199
3200 /* Elaborate any Itypes in the parameters of this entity. */
3201 for (gnat_temp = First_Formal (gnat_entity);
3202 Present (gnat_temp);
3203 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3204 if (Is_Itype (Etype (gnat_temp)))
3205 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3206
3207 break;
3208 }
3209
3210 if (kind == E_Function || kind == E_Subprogram_Type)
3211 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
3212
3213 /* If this function returns by reference, make the actual
3214 return type of this function the pointer and mark the decl. */
3215 if (Returns_By_Ref (gnat_entity))
3216 {
3217 returns_by_ref = 1;
3218 gnu_return_type = build_pointer_type (gnu_return_type);
3219 }
3220
3221 /* If the Mechanism is By_Reference, ensure the return type uses
3222 the machine's by-reference mechanism, which may not the same
3223 as above (e.g., it might be by passing a fake parameter). */
3224 else if (kind == E_Function
3225 && Mechanism (gnat_entity) == By_Reference)
3226 {
3227 gnu_return_type = copy_type (gnu_return_type);
3228 TREE_ADDRESSABLE (gnu_return_type) = 1;
3229 }
3230
3231 /* If we are supposed to return an unconstrained array,
3232 actually return a fat pointer and make a note of that. Return
3233 a pointer to an unconstrained record of variable size. */
3234 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
3235 {
3236 gnu_return_type = TREE_TYPE (gnu_return_type);
3237 returns_unconstrained = 1;
3238 }
3239
3240 /* If the type requires a transient scope, the result is allocated
3241 on the secondary stack, so the result type of the function is
3242 just a pointer. */
3243 else if (Requires_Transient_Scope (Etype (gnat_entity)))
3244 {
3245 gnu_return_type = build_pointer_type (gnu_return_type);
3246 returns_unconstrained = 1;
3247 }
3248
3249 /* If the type is a padded type and the underlying type would not
3250 be passed by reference or this function has a foreign convention,
3251 return the underlying type. */
3252 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
3253 && TYPE_IS_PADDING_P (gnu_return_type)
3254 && (! default_pass_by_ref (TREE_TYPE
3255 (TYPE_FIELDS (gnu_return_type)))
3256 || Has_Foreign_Convention (gnat_entity)))
3257 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
3258
3259 /* Look at all our parameters and get the type of
3260 each. While doing this, build a copy-out structure if
3261 we need one. */
3262
3263 /* If the return type has a size that overflows, we cannot have
3264 a function that returns that type. This usage doesn't make
3265 sense anyway, so give an error here. */
3266 if (TYPE_SIZE_UNIT (gnu_return_type)
3267 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
3268 {
3269 post_error ("cannot return type whose size overflows",
3270 gnat_entity);
3271 gnu_return_type = copy_node (gnu_return_type);
3272 TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
3273 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
3274 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
3275 TYPE_NEXT_VARIANT (gnu_return_type) = 0;
3276 }
3277
3278 for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
3279 Present (gnat_param);
3280 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
3281 {
3282 tree gnu_param_name = get_entity_name (gnat_param);
3283 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
3284 tree gnu_param, gnu_field;
3285 int by_ref_p = 0;
3286 int by_descr_p = 0;
3287 int by_component_ptr_p = 0;
3288 int copy_in_copy_out_flag = 0;
3289 int req_by_copy = 0, req_by_ref = 0;
3290
3291 /* See if a Mechanism was supplied that forced this
3292 parameter to be passed one way or another. */
3293 if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3294 req_by_copy = 1;
3295 else if (Mechanism (gnat_param) == Default)
3296 ;
3297 else if (Mechanism (gnat_param) == By_Copy)
3298 req_by_copy = 1;
3299 else if (Mechanism (gnat_param) == By_Reference)
3300 req_by_ref = 1;
3301 else if (Mechanism (gnat_param) <= By_Descriptor)
3302 by_descr_p = 1;
3303 else if (Mechanism (gnat_param) > 0)
3304 {
3305 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
3306 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
3307 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
3308 Mechanism (gnat_param)))
3309 req_by_ref = 1;
3310 else
3311 req_by_copy = 1;
3312 }
3313 else
3314 post_error ("unsupported mechanism for&", gnat_param);
3315
3316 /* If this is either a foreign function or if the
3317 underlying type won't be passed by refererence, strip off
3318 possible padding type. */
3319 if (TREE_CODE (gnu_param_type) == RECORD_TYPE
3320 && TYPE_IS_PADDING_P (gnu_param_type)
3321 && (req_by_ref || Has_Foreign_Convention (gnat_entity)
3322 || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
3323 (gnu_param_type)))))
3324 gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
3325
3326 /* If this is an IN parameter it is read-only, so make a variant
3327 of the type that is read-only.
3328
3329 ??? However, if this is an unconstrained array, that type can
3330 be very complex. So skip it for now. Likewise for any other
3331 self-referential type. */
3332 if (Ekind (gnat_param) == E_In_Parameter
3333 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
3334 && ! (TYPE_SIZE (gnu_param_type) != 0
3335 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))))
3336 gnu_param_type
3337 = build_qualified_type (gnu_param_type,
3338 (TYPE_QUALS (gnu_param_type)
3339 | TYPE_QUAL_CONST));
3340
3341 /* For foreign conventions, pass arrays as a pointer to the
3342 underlying type. First check for unconstrained array and get
3343 the underlying array. Then get the component type and build
3344 a pointer to it. */
3345 if (Has_Foreign_Convention (gnat_entity)
3346 && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
3347 gnu_param_type
3348 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3349 (TREE_TYPE (gnu_param_type))));
3350
3351 if (by_descr_p)
3352 gnu_param_type
3353 = build_pointer_type
3354 (build_vms_descriptor (gnu_param_type,
3355 Mechanism (gnat_param),
3356 gnat_entity));
3357
3358 else if (Has_Foreign_Convention (gnat_entity)
3359 && ! req_by_copy
3360 && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
3361 {
3362 /* Strip off any multi-dimensional entries, then strip
3363 off the last array to get the component type. */
3364 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
3365 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
3366 gnu_param_type = TREE_TYPE (gnu_param_type);
3367
3368 by_component_ptr_p = 1;
3369 gnu_param_type = TREE_TYPE (gnu_param_type);
3370
3371 if (Ekind (gnat_param) == E_In_Parameter)
3372 gnu_param_type
3373 = build_qualified_type (gnu_param_type,
3374 (TYPE_QUALS (gnu_param_type)
3375 | TYPE_QUAL_CONST));
3376
3377 gnu_param_type = build_pointer_type (gnu_param_type);
3378 }
3379
3380 /* Fat pointers are passed as thin pointers for foreign
3381 conventions. */
3382 else if (Has_Foreign_Convention (gnat_entity)
3383 && TYPE_FAT_POINTER_P (gnu_param_type))
3384 gnu_param_type
3385 = make_type_from_size (gnu_param_type,
3386 size_int (POINTER_SIZE), 0);
3387
3388 /* If we must pass or were requested to pass by reference, do so.
3389 If we were requested to pass by copy, do so.
3390 Otherwise, for foreign conventions, pass all in out parameters
3391 or aggregates by reference. For COBOL and Fortran, pass
3392 all integer and FP types that way too. For Convention Ada,
3393 use the standard Ada default. */
3394 else if (must_pass_by_ref (gnu_param_type) || req_by_ref
3395 || (! req_by_copy
3396 && ((Has_Foreign_Convention (gnat_entity)
3397 && (Ekind (gnat_param) != E_In_Parameter
3398 || AGGREGATE_TYPE_P (gnu_param_type)))
3399 || (((Convention (gnat_entity)
3400 == Convention_Fortran)
3401 || (Convention (gnat_entity)
3402 == Convention_COBOL))
3403 && (INTEGRAL_TYPE_P (gnu_param_type)
3404 || FLOAT_TYPE_P (gnu_param_type)))
3405 /* For convention Ada, see if we pass by reference
3406 by default. */
3407 || (! Has_Foreign_Convention (gnat_entity)
3408 && default_pass_by_ref (gnu_param_type)))))
3409 {
3410 gnu_param_type = build_reference_type (gnu_param_type);
3411 by_ref_p = 1;
3412 }
3413
3414 else if (Ekind (gnat_param) != E_In_Parameter)
3415 copy_in_copy_out_flag = 1;
3416
3417 if (req_by_copy && (by_ref_p || by_component_ptr_p))
3418 post_error ("?cannot pass & by copy", gnat_param);
3419
3420 /* If this is an OUT parameter that isn't passed by reference
3421 and isn't a pointer or aggregate, we don't make a PARM_DECL
3422 for it. Instead, it will be a VAR_DECL created when we process
3423 the procedure. For the special parameter of Valued_Procedure,
3424 never pass it in.
3425
3426 An exception is made to cover the RM-6.4.1 rule requiring "by
3427 copy" out parameters with discriminants or implicit initial
3428 values to be handled like in out parameters. These type are
3429 normally built as aggregates, and hence passed by reference,
3430 except for some packed arrays which end up encoded in special
3431 integer types.
3432
3433 The exception we need to make is then for packed arrays of
3434 records with discriminants or implicit initial values. We have
3435 no light/easy way to check for the latter case, so we merely
3436 check for packed arrays of records. This may lead to useless
3437 copy-in operations, but in very rare cases only, as these would
3438 be exceptions in a set of already exceptional situations. */
3439 if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p
3440 && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
3441 || (! by_descr_p
3442 && ! POINTER_TYPE_P (gnu_param_type)
3443 && ! AGGREGATE_TYPE_P (gnu_param_type)))
3444 && ! (Is_Array_Type (Etype (gnat_param))
3445 && Is_Packed (Etype (gnat_param))
3446 && Is_Composite_Type (Component_Type
3447 (Etype (gnat_param)))))
3448 gnu_param = 0;
3449 else
3450 {
3451 set_lineno (gnat_param, 0);
3452 gnu_param
3453 = create_param_decl
3454 (gnu_param_name, gnu_param_type,
3455 by_ref_p || by_component_ptr_p
3456 || Ekind (gnat_param) == E_In_Parameter);
3457
3458 DECL_BY_REF_P (gnu_param) = by_ref_p;
3459 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p;
3460 DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p;
3461 DECL_POINTS_TO_READONLY_P (gnu_param)
3462 = (Ekind (gnat_param) == E_In_Parameter
3463 && (by_ref_p || by_component_ptr_p));
3464 save_gnu_tree (gnat_param, gnu_param, 0);
3465 gnu_param_list = chainon (gnu_param, gnu_param_list);
3466
3467 /* If a parameter is a pointer, this function may modify
3468 memory through it and thus shouldn't be considered
3469 a pure function. Also, the memory may be modified
3470 between two calls, so they can't be CSE'ed. The latter
3471 case also handles by-ref parameters. */
3472 if (POINTER_TYPE_P (gnu_param_type)
3473 || TYPE_FAT_POINTER_P (gnu_param_type))
3474 pure_flag = 0;
3475 }
3476
3477 if (copy_in_copy_out_flag)
3478 {
3479 if (! has_copy_in_out)
3480 {
3481 if (TREE_CODE (gnu_return_type) != VOID_TYPE)
3482 gigi_abort (111);
3483
3484 gnu_return_type = make_node (RECORD_TYPE);
3485 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
3486 has_copy_in_out = 1;
3487 }
3488
3489 set_lineno (gnat_param, 0);
3490 gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
3491 gnu_return_type, 0, 0, 0, 0);
3492 TREE_CHAIN (gnu_field) = gnu_field_list;
3493 gnu_field_list = gnu_field;
3494 gnu_return_list = tree_cons (gnu_field, gnu_param,
3495 gnu_return_list);
3496 }
3497 }
3498
3499 /* Do not compute record for out parameters if subprogram is
3500 stubbed since structures are incomplete for the back-end. */
3501 if (gnu_field_list != 0
3502 && Convention (gnat_entity) != Convention_Stubbed)
3503 finish_record_type (gnu_return_type, nreverse (gnu_field_list),
3504 0, 0);
3505
3506 /* If we have a CICO list but it has only one entry, we convert
3507 this function into a function that simply returns that one
3508 object. */
3509 if (list_length (gnu_return_list) == 1)
3510 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
3511
3512 #ifdef _WIN32
3513 if (Convention (gnat_entity) == Convention_Stdcall)
3514 {
3515 struct attrib *attr
3516 = (struct attrib *) xmalloc (sizeof (struct attrib));
3517
3518 attr->next = attr_list;
3519 attr->type = ATTR_MACHINE_ATTRIBUTE;
3520 attr->name = get_identifier ("stdcall");
3521 attr->arg = NULL_TREE;
3522 attr->error_point = gnat_entity;
3523 attr_list = attr;
3524 }
3525 #endif
3526
3527 /* Both lists ware built in reverse. */
3528 gnu_param_list = nreverse (gnu_param_list);
3529 gnu_return_list = nreverse (gnu_return_list);
3530
3531 gnu_type
3532 = create_subprog_type (gnu_return_type, gnu_param_list,
3533 gnu_return_list, returns_unconstrained,
3534 returns_by_ref,
3535 Function_Returns_With_DSP (gnat_entity));
3536
3537 /* ??? For now, don't consider nested functions pure. */
3538 if (! global_bindings_p ())
3539 pure_flag = 0;
3540
3541 /* A subprogram (something that doesn't return anything) shouldn't
3542 be considered Pure since there would be no reason for such a
3543 subprogram. Note that procedures with Out (or In Out) parameters
3544 have already been converted into a function with a return type. */
3545 if (TREE_CODE (gnu_return_type) == VOID_TYPE)
3546 pure_flag = 0;
3547
3548 gnu_type
3549 = build_qualified_type (gnu_type,
3550 (TYPE_QUALS (gnu_type)
3551 | (TYPE_QUAL_CONST * pure_flag)
3552 | (TYPE_QUAL_VOLATILE * volatile_flag)));
3553
3554 set_lineno (gnat_entity, 0);
3555
3556 /* If there was no specified Interface_Name and the external and
3557 internal names of the subprogram are the same, only use the
3558 internal name to allow disambiguation of nested subprograms. */
3559 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
3560 gnu_ext_name = 0;
3561
3562 /* If we are defining the subprogram and it has an Address clause
3563 we must get the address expression from the saved GCC tree for the
3564 subprogram if it has a Freeze_Node. Otherwise, we elaborate
3565 the address expression here since the front-end has guaranteed
3566 in that case that the elaboration has no effects. If there is
3567 an Address clause and we are not defining the object, just
3568 make it a constant. */
3569 if (Present (Address_Clause (gnat_entity)))
3570 {
3571 tree gnu_address = 0;
3572
3573 if (definition)
3574 gnu_address
3575 = (present_gnu_tree (gnat_entity)
3576 ? get_gnu_tree (gnat_entity)
3577 : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
3578
3579 save_gnu_tree (gnat_entity, NULL_TREE, 0);
3580
3581 gnu_type = build_reference_type (gnu_type);
3582 if (gnu_address != 0)
3583 gnu_address = convert (gnu_type, gnu_address);
3584
3585 gnu_decl
3586 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
3587 gnu_address, 0, Is_Public (gnat_entity),
3588 extern_flag, 0, 0);
3589 DECL_BY_REF_P (gnu_decl) = 1;
3590 }
3591
3592 else if (kind == E_Subprogram_Type)
3593 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3594 ! Comes_From_Source (gnat_entity),
3595 debug_info_p);
3596 else
3597 {
3598 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
3599 gnu_type, gnu_param_list,
3600 inline_flag, public_flag,
3601 extern_flag, attr_list);
3602 DECL_STUBBED_P (gnu_decl)
3603 = Convention (gnat_entity) == Convention_Stubbed;
3604 }
3605 }
3606 break;
3607
3608 case E_Incomplete_Type:
3609 case E_Private_Type:
3610 case E_Limited_Private_Type:
3611 case E_Record_Type_With_Private:
3612 case E_Private_Subtype:
3613 case E_Limited_Private_Subtype:
3614 case E_Record_Subtype_With_Private:
3615
3616 /* If this type does not have a full view in the unit we are
3617 compiling, then just get the type from its Etype. */
3618 if (No (Full_View (gnat_entity)))
3619 {
3620 /* If this is an incomplete type with no full view, it must
3621 be a Taft Amendement type, so just return a dummy type. */
3622 if (kind == E_Incomplete_Type)
3623 gnu_type = make_dummy_type (gnat_entity);
3624
3625 else if (Present (Underlying_Full_View (gnat_entity)))
3626 gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
3627 NULL_TREE, 0);
3628 else
3629 {
3630 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
3631 NULL_TREE, 0);
3632 maybe_present = 1;
3633 }
3634
3635 break;
3636 }
3637
3638 /* Otherwise, if we are not defining the type now, get the
3639 type from the full view. But always get the type from the full
3640 view for define on use types, since otherwise we won't see them! */
3641
3642 else if (! definition
3643 || (Is_Itype (Full_View (gnat_entity))
3644 && No (Freeze_Node (gnat_entity)))
3645 || (Is_Itype (gnat_entity)
3646 && No (Freeze_Node (Full_View (gnat_entity)))))
3647 {
3648 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
3649 NULL_TREE, 0);
3650 maybe_present = 1;
3651 break;
3652 }
3653
3654 /* For incomplete types, make a dummy type entry which will be
3655 replaced later. */
3656 gnu_type = make_dummy_type (gnat_entity);
3657
3658 /* Save this type as the full declaration's type so we can do any needed
3659 updates when we see it. */
3660 set_lineno (gnat_entity, 0);
3661 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3662 ! Comes_From_Source (gnat_entity),
3663 debug_info_p);
3664 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
3665 break;
3666
3667 /* Simple class_wide types are always viewed as their root_type
3668 by Gigi unless an Equivalent_Type is specified. */
3669 case E_Class_Wide_Type:
3670 if (Present (Equivalent_Type (gnat_entity)))
3671 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
3672 else
3673 gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity));
3674
3675 maybe_present = 1;
3676 break;
3677
3678 case E_Task_Type:
3679 case E_Task_Subtype:
3680 case E_Protected_Type:
3681 case E_Protected_Subtype:
3682 if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity)))
3683 gnu_type = void_type_node;
3684 else
3685 gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity));
3686
3687 maybe_present = 1;
3688 break;
3689
3690 case E_Label:
3691 gnu_decl = create_label_decl (gnu_entity_id);
3692 break;
3693
3694 case E_Block:
3695 case E_Loop:
3696 /* Nothing at all to do here, so just return an ERROR_MARK and claim
3697 we've already saved it, so we don't try to. */
3698 gnu_decl = error_mark_node;
3699 saved = 1;
3700 break;
3701
3702 default:
3703 gigi_abort (113);
3704 }
3705
3706 /* If we had a case where we evaluated another type and it might have
3707 defined this one, handle it here. */
3708 if (maybe_present && present_gnu_tree (gnat_entity))
3709 {
3710 gnu_decl = get_gnu_tree (gnat_entity);
3711 saved = 1;
3712 }
3713
3714 /* If we are processing a type and there is either no decl for it or
3715 we just made one, do some common processing for the type, such as
3716 handling alignment and possible padding. */
3717
3718 if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind))
3719 {
3720 if (Is_Tagged_Type (gnat_entity)
3721 || Is_Class_Wide_Equivalent_Type (gnat_entity))
3722 TYPE_ALIGN_OK (gnu_type) = 1;
3723
3724 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
3725 TYPE_BY_REFERENCE_P (gnu_type) = 1;
3726
3727 /* ??? Don't set the size for a String_Literal since it is either
3728 confirming or we don't handle it properly (if the low bound is
3729 non-constant). */
3730 if (gnu_size == 0 && kind != E_String_Literal_Subtype)
3731 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
3732 TYPE_DECL, 0, Has_Size_Clause (gnat_entity));
3733
3734 /* If a size was specified, see if we can make a new type of that size
3735 by rearranging the type, for example from a fat to a thin pointer. */
3736 if (gnu_size != 0)
3737 {
3738 gnu_type
3739 = make_type_from_size (gnu_type, gnu_size,
3740 Has_Biased_Representation (gnat_entity));
3741
3742 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
3743 && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
3744 gnu_size = 0;
3745 }
3746
3747 /* If the alignment hasn't already been processed and this is
3748 not an unconstrained array, see if an alignment is specified.
3749 If not, we pick a default alignment for atomic objects. */
3750 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3751 ;
3752 else if (Known_Alignment (gnat_entity))
3753 align = validate_alignment (Alignment (gnat_entity), gnat_entity,
3754 TYPE_ALIGN (gnu_type));
3755 else if (Is_Atomic (gnat_entity) && gnu_size == 0
3756 && host_integerp (TYPE_SIZE (gnu_type), 1)
3757 && integer_pow2p (TYPE_SIZE (gnu_type)))
3758 align = MIN (BIGGEST_ALIGNMENT,
3759 tree_low_cst (TYPE_SIZE (gnu_type), 1));
3760 else if (Is_Atomic (gnat_entity) && gnu_size != 0
3761 && host_integerp (gnu_size, 1)
3762 && integer_pow2p (gnu_size))
3763 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
3764
3765 /* See if we need to pad the type. If we did, and made a record,
3766 the name of the new type may be changed. So get it back for
3767 us when we make the new TYPE_DECL below. */
3768 gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
3769 gnat_entity, "PAD", 1, definition, 0);
3770 if (TREE_CODE (gnu_type) == RECORD_TYPE
3771 && TYPE_IS_PADDING_P (gnu_type))
3772 {
3773 gnu_entity_id = TYPE_NAME (gnu_type);
3774 if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
3775 gnu_entity_id = DECL_NAME (gnu_entity_id);
3776 }
3777
3778 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
3779
3780 /* If we are at global level, GCC will have applied variable_size to
3781 the type, but that won't have done anything. So, if it's not
3782 a constant or self-referential, call elaborate_expression_1 to
3783 make a variable for the size rather than calculating it each time.
3784 Handle both the RM size and the actual size. */
3785 if (global_bindings_p ()
3786 && TYPE_SIZE (gnu_type) != 0
3787 && ! TREE_CONSTANT (TYPE_SIZE (gnu_type))
3788 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
3789 {
3790 if (TREE_CODE (gnu_type) == RECORD_TYPE
3791 && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
3792 TYPE_SIZE (gnu_type), 0))
3793 {
3794 TYPE_SIZE (gnu_type)
3795 = elaborate_expression_1 (gnat_entity, gnat_entity,
3796 TYPE_SIZE (gnu_type),
3797 get_identifier ("SIZE"),
3798 definition, 0);
3799 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
3800 }
3801 else
3802 {
3803 TYPE_SIZE (gnu_type)
3804 = elaborate_expression_1 (gnat_entity, gnat_entity,
3805 TYPE_SIZE (gnu_type),
3806 get_identifier ("SIZE"),
3807 definition, 0);
3808
3809 /* ??? For now, store the size as a multiple of the alignment
3810 in bytes so that we can see the alignment from the tree. */
3811 TYPE_SIZE_UNIT (gnu_type)
3812 = build_binary_op
3813 (MULT_EXPR, sizetype,
3814 elaborate_expression_1
3815 (gnat_entity, gnat_entity,
3816 build_binary_op (EXACT_DIV_EXPR, sizetype,
3817 TYPE_SIZE_UNIT (gnu_type),
3818 size_int (TYPE_ALIGN (gnu_type)
3819 / BITS_PER_UNIT)),
3820 get_identifier ("SIZE_A_UNIT"),
3821 definition, 0),
3822 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3823
3824 if (TREE_CODE (gnu_type) == RECORD_TYPE)
3825 SET_TYPE_ADA_SIZE (gnu_type,
3826 elaborate_expression_1 (gnat_entity, gnat_entity,
3827 TYPE_ADA_SIZE (gnu_type),
3828 get_identifier ("RM_SIZE"),
3829 definition, 0));
3830 }
3831 }
3832
3833 /* If this is a record type or subtype, call elaborate_expression_1 on
3834 any field position. Do this for both global and local types.
3835 Skip any fields that we haven't made trees for to avoid problems with
3836 class wide types. */
3837 if (IN (kind, Record_Kind))
3838 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
3839 gnat_temp = Next_Entity (gnat_temp))
3840 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
3841 {
3842 tree gnu_field = get_gnu_tree (gnat_temp);
3843
3844 /* ??? Unfortunately, GCC needs to be able to prove the
3845 alignment of this offset and if it's a variable, it can't.
3846 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
3847 right now, we have to put in an explicit multiply and
3848 divide by that value. */
3849 if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
3850 DECL_FIELD_OFFSET (gnu_field)
3851 = build_binary_op
3852 (MULT_EXPR, sizetype,
3853 elaborate_expression_1
3854 (gnat_temp, gnat_temp,
3855 build_binary_op (EXACT_DIV_EXPR, sizetype,
3856 DECL_FIELD_OFFSET (gnu_field),
3857 size_int (DECL_OFFSET_ALIGN (gnu_field)
3858 / BITS_PER_UNIT)),
3859 get_identifier ("OFFSET"),
3860 definition, 0),
3861 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
3862 }
3863
3864 gnu_type = build_qualified_type (gnu_type,
3865 (TYPE_QUALS (gnu_type)
3866 | (TYPE_QUAL_VOLATILE
3867 * Treat_As_Volatile (gnat_entity))));
3868
3869 if (Is_Atomic (gnat_entity))
3870 check_ok_for_atomic (gnu_type, gnat_entity, 0);
3871
3872 if (Known_Alignment (gnat_entity))
3873 TYPE_USER_ALIGN (gnu_type) = 1;
3874
3875 if (gnu_decl == 0)
3876 {
3877 set_lineno (gnat_entity, 0);
3878 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
3879 ! Comes_From_Source (gnat_entity),
3880 debug_info_p);
3881 }
3882 else
3883 TREE_TYPE (gnu_decl) = gnu_type;
3884 }
3885
3886 if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
3887 {
3888 gnu_type = TREE_TYPE (gnu_decl);
3889
3890 /* Back-annotate the Alignment of the type if not already in the
3891 tree. Likewise for sizes. */
3892 if (Unknown_Alignment (gnat_entity))
3893 Set_Alignment (gnat_entity,
3894 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
3895
3896 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0)
3897 {
3898 /* If the size is self-referential, we annotate the maximum
3899 value of that size. */
3900 tree gnu_size = TYPE_SIZE (gnu_type);
3901
3902 if (CONTAINS_PLACEHOLDER_P (gnu_size))
3903 gnu_size = max_size (gnu_size, 1);
3904
3905 Set_Esize (gnat_entity, annotate_value (gnu_size));
3906
3907 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
3908 {
3909 /* In this mode the tag and the parent components are not
3910 generated by the front-end, so the sizes must be adjusted
3911 explicitly now. */
3912
3913 int size_offset;
3914 int new_size;
3915
3916 if (Is_Derived_Type (gnat_entity))
3917 {
3918 size_offset
3919 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
3920 Set_Alignment (gnat_entity,
3921 Alignment (Etype (Base_Type (gnat_entity))));
3922 }
3923 else
3924 size_offset = POINTER_SIZE;
3925
3926 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
3927 Set_Esize (gnat_entity,
3928 UI_From_Int (((new_size + (POINTER_SIZE - 1))
3929 / POINTER_SIZE) * POINTER_SIZE));
3930 Set_RM_Size (gnat_entity, Esize (gnat_entity));
3931 }
3932 }
3933
3934 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0)
3935 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
3936 }
3937
3938 if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
3939 DECL_ARTIFICIAL (gnu_decl) = 1;
3940
3941 if (! debug_info_p && DECL_P (gnu_decl)
3942 && TREE_CODE (gnu_decl) != FUNCTION_DECL)
3943 DECL_IGNORED_P (gnu_decl) = 1;
3944
3945 /* If this decl is really indirect, adjust it. */
3946 if (TREE_CODE (gnu_decl) == VAR_DECL)
3947 adjust_decl_rtl (gnu_decl);
3948
3949 /* If we haven't already, associate the ..._DECL node that we just made with
3950 the input GNAT entity node. */
3951 if (! saved)
3952 save_gnu_tree (gnat_entity, gnu_decl, 0);
3953
3954 /* If this is an enumeral or floating-point type, we were not able to set
3955 the bounds since they refer to the type. These bounds are always static.
3956
3957 For enumeration types, also write debugging information and declare the
3958 enumeration literal table, if needed. */
3959
3960 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
3961 || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity)))
3962 {
3963 tree gnu_scalar_type = gnu_type;
3964
3965 /* If this is a padded type, we need to use the underlying type. */
3966 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
3967 && TYPE_IS_PADDING_P (gnu_scalar_type))
3968 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
3969
3970 /* If this is a floating point type and we haven't set a floating
3971 point type yet, use this in the evaluation of the bounds. */
3972 if (longest_float_type_node == 0 && kind == E_Floating_Point_Type)
3973 longest_float_type_node = gnu_type;
3974
3975 TYPE_MIN_VALUE (gnu_scalar_type)
3976 = gnat_to_gnu (Type_Low_Bound (gnat_entity));
3977 TYPE_MAX_VALUE (gnu_scalar_type)
3978 = gnat_to_gnu (Type_High_Bound (gnat_entity));
3979
3980 if (kind == E_Enumeration_Type)
3981 {
3982 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
3983
3984 /* Since this has both a typedef and a tag, avoid outputting
3985 the name twice. */
3986 DECL_ARTIFICIAL (gnu_decl) = 1;
3987 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
3988 }
3989 }
3990
3991 /* If we deferred processing of incomplete types, re-enable it. If there
3992 were no other disables and we have some to process, do so. */
3993 if (this_deferred && --defer_incomplete_level == 0
3994 && defer_incomplete_list != 0)
3995 {
3996 struct incomplete *incp = defer_incomplete_list;
3997 struct incomplete *next;
3998
3999 defer_incomplete_list = 0;
4000 for (; incp; incp = next)
4001 {
4002 next = incp->next;
4003
4004 if (incp->old_type != 0)
4005 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4006 gnat_to_gnu_type (incp->full_type));
4007 free (incp);
4008 }
4009 }
4010
4011 /* If we are not defining this type, see if it's in the incomplete list.
4012 If so, handle that list entry now. */
4013 else if (! definition)
4014 {
4015 struct incomplete *incp;
4016
4017 for (incp = defer_incomplete_list; incp; incp = incp->next)
4018 if (incp->old_type != 0 && incp->full_type == gnat_entity)
4019 {
4020 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
4021 TREE_TYPE (gnu_decl));
4022 incp->old_type = 0;
4023 }
4024 }
4025
4026 if (this_global)
4027 force_global--;
4028
4029 if (Is_Packed_Array_Type (gnat_entity)
4030 && Is_Itype (Associated_Node_For_Itype (gnat_entity))
4031 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
4032 && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
4033 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
4034
4035 return gnu_decl;
4036 }
4037
4038 /* Given GNAT_ENTITY, elaborate all expressions that are required to
4039 be elaborated at the point of its definition, but do nothing else. */
4040
4041 void
elaborate_entity(Entity_Id gnat_entity)4042 elaborate_entity (Entity_Id gnat_entity)
4043 {
4044 switch (Ekind (gnat_entity))
4045 {
4046 case E_Signed_Integer_Subtype:
4047 case E_Modular_Integer_Subtype:
4048 case E_Enumeration_Subtype:
4049 case E_Ordinary_Fixed_Point_Subtype:
4050 case E_Decimal_Fixed_Point_Subtype:
4051 case E_Floating_Point_Subtype:
4052 {
4053 Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
4054 Node_Id gnat_hb = Type_High_Bound (gnat_entity);
4055
4056 /* ??? Tests for avoiding static constaint error expression
4057 is needed until the front stops generating bogus conversions
4058 on bounds of real types. */
4059
4060 if (! Raises_Constraint_Error (gnat_lb))
4061 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
4062 1, 0, Needs_Debug_Info (gnat_entity));
4063 if (! Raises_Constraint_Error (gnat_hb))
4064 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
4065 1, 0, Needs_Debug_Info (gnat_entity));
4066 break;
4067 }
4068
4069 case E_Record_Type:
4070 {
4071 Node_Id full_definition = Declaration_Node (gnat_entity);
4072 Node_Id record_definition = Type_Definition (full_definition);
4073
4074 /* If this is a record extension, go a level further to find the
4075 record definition. */
4076 if (Nkind (record_definition) == N_Derived_Type_Definition)
4077 record_definition = Record_Extension_Part (record_definition);
4078 }
4079 break;
4080
4081 case E_Record_Subtype:
4082 case E_Private_Subtype:
4083 case E_Limited_Private_Subtype:
4084 case E_Record_Subtype_With_Private:
4085 if (Is_Constrained (gnat_entity)
4086 && Has_Discriminants (Base_Type (gnat_entity))
4087 && Present (Discriminant_Constraint (gnat_entity)))
4088 {
4089 Node_Id gnat_discriminant_expr;
4090 Entity_Id gnat_field;
4091
4092 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
4093 gnat_discriminant_expr
4094 = First_Elmt (Discriminant_Constraint (gnat_entity));
4095 Present (gnat_field);
4096 gnat_field = Next_Discriminant (gnat_field),
4097 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
4098 /* ??? For now, ignore access discriminants. */
4099 if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
4100 elaborate_expression (Node (gnat_discriminant_expr),
4101 gnat_entity,
4102 get_entity_name (gnat_field), 1, 0, 0);
4103 }
4104 break;
4105
4106 }
4107 }
4108
4109 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
4110 any entities on its entity chain similarly. */
4111
4112 void
mark_out_of_scope(Entity_Id gnat_entity)4113 mark_out_of_scope (Entity_Id gnat_entity)
4114 {
4115 Entity_Id gnat_sub_entity;
4116 unsigned int kind = Ekind (gnat_entity);
4117
4118 /* If this has an entity list, process all in the list. */
4119 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
4120 || IN (kind, Private_Kind)
4121 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
4122 || kind == E_Function || kind == E_Generic_Function
4123 || kind == E_Generic_Package || kind == E_Generic_Procedure
4124 || kind == E_Loop || kind == E_Operator || kind == E_Package
4125 || kind == E_Package_Body || kind == E_Procedure
4126 || kind == E_Record_Type || kind == E_Record_Subtype
4127 || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
4128 for (gnat_sub_entity = First_Entity (gnat_entity);
4129 Present (gnat_sub_entity);
4130 gnat_sub_entity = Next_Entity (gnat_sub_entity))
4131 if (Scope (gnat_sub_entity) == gnat_entity
4132 && gnat_sub_entity != gnat_entity)
4133 mark_out_of_scope (gnat_sub_entity);
4134
4135 /* Now clear this if it has been defined, but only do so if it isn't
4136 a subprogram or parameter. We could refine this, but it isn't
4137 worth it. If this is statically allocated, it is supposed to
4138 hang around out of cope. */
4139 if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity)
4140 && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind))
4141 {
4142 save_gnu_tree (gnat_entity, NULL_TREE, 1);
4143 save_gnu_tree (gnat_entity, error_mark_node, 1);
4144 }
4145 }
4146
4147 /* Return a TREE_LIST describing the substitutions needed to reflect
4148 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
4149 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
4150 of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE
4151 gives the tree for the discriminant and TREE_VALUES is the replacement
4152 value. They are in the form of operands to substitute_in_expr.
4153 DEFINITION is as in gnat_to_gnu_entity. */
4154
4155 static tree
substitution_list(Entity_Id gnat_subtype,Entity_Id gnat_type,tree gnu_list,int definition)4156 substitution_list (Entity_Id gnat_subtype,
4157 Entity_Id gnat_type,
4158 tree gnu_list,
4159 int definition)
4160 {
4161 Entity_Id gnat_discrim;
4162 Node_Id gnat_value;
4163
4164 if (No (gnat_type))
4165 gnat_type = Implementation_Base_Type (gnat_subtype);
4166
4167 if (Has_Discriminants (gnat_type))
4168 for (gnat_discrim = First_Stored_Discriminant (gnat_type),
4169 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
4170 Present (gnat_discrim);
4171 gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
4172 gnat_value = Next_Elmt (gnat_value))
4173 /* Ignore access discriminants. */
4174 if (! Is_Access_Type (Etype (Node (gnat_value))))
4175 gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0),
4176 elaborate_expression
4177 (Node (gnat_value), gnat_subtype,
4178 get_entity_name (gnat_discrim), definition,
4179 1, 0),
4180 gnu_list);
4181
4182 return gnu_list;
4183 }
4184
4185 /* For the following two functions: for each GNAT entity, the GCC
4186 tree node used as a dummy for that entity, if any. */
4187
4188 static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
4189
4190 /* Initialize the above table. */
4191
4192 void
init_dummy_type(void)4193 init_dummy_type (void)
4194 {
4195 Node_Id gnat_node;
4196
4197 dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
4198
4199 for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
4200 dummy_node_table[gnat_node] = NULL_TREE;
4201
4202 dummy_node_table -= First_Node_Id;
4203 }
4204
4205 /* Make a dummy type corresponding to GNAT_TYPE. */
4206
4207 tree
make_dummy_type(Entity_Id gnat_type)4208 make_dummy_type (Entity_Id gnat_type)
4209 {
4210 Entity_Id gnat_underlying;
4211 tree gnu_type;
4212
4213 /* Find a full type for GNAT_TYPE, taking into account any class wide
4214 types. */
4215 if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
4216 gnat_type = Equivalent_Type (gnat_type);
4217 else if (Ekind (gnat_type) == E_Class_Wide_Type)
4218 gnat_type = Root_Type (gnat_type);
4219
4220 for (gnat_underlying = gnat_type;
4221 (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
4222 && Present (Full_View (gnat_underlying)));
4223 gnat_underlying = Full_View (gnat_underlying))
4224 ;
4225
4226 /* If it there already a dummy type, use that one. Else make one. */
4227 if (dummy_node_table[gnat_underlying])
4228 return dummy_node_table[gnat_underlying];
4229
4230 /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
4231 it a VOID_TYPE. */
4232 if (Is_Record_Type (gnat_underlying))
4233 gnu_type = make_node (Is_Unchecked_Union (gnat_underlying)
4234 ? UNION_TYPE : RECORD_TYPE);
4235 else
4236 gnu_type = make_node (ENUMERAL_TYPE);
4237
4238 TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
4239 if (AGGREGATE_TYPE_P (gnu_type))
4240 TYPE_STUB_DECL (gnu_type)
4241 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
4242
4243 TYPE_DUMMY_P (gnu_type) = 1;
4244 dummy_node_table[gnat_underlying] = gnu_type;
4245
4246 return gnu_type;
4247 }
4248
4249 /* Return 1 if the size represented by GNU_SIZE can be handled by an
4250 allocation. If STATIC_P is non-zero, consider only what can be
4251 done with a static allocation. */
4252
4253 static int
allocatable_size_p(tree gnu_size,int static_p)4254 allocatable_size_p (tree gnu_size, int static_p)
4255 {
4256 HOST_WIDE_INT our_size;
4257
4258 /* If this is not a static allocation, the only case we want to forbid
4259 is an overflowing size. That will be converted into a raise a
4260 Storage_Error. */
4261 if (! static_p)
4262 return ! (TREE_CODE (gnu_size) == INTEGER_CST
4263 && TREE_CONSTANT_OVERFLOW (gnu_size));
4264
4265 /* Otherwise, we need to deal with both variable sizes and constant
4266 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
4267 since assemblers may not like very large sizes. */
4268 if (!host_integerp (gnu_size, 1))
4269 return 0;
4270
4271 our_size = tree_low_cst (gnu_size, 1);
4272 return (int) our_size == our_size;
4273 }
4274
4275 /* Return a list of attributes for GNAT_ENTITY, if any. */
4276
4277 static struct attrib *
build_attr_list(Entity_Id gnat_entity)4278 build_attr_list (Entity_Id gnat_entity)
4279 {
4280 struct attrib *attr_list = 0;
4281 Node_Id gnat_temp;
4282
4283 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
4284 gnat_temp = Next_Rep_Item (gnat_temp))
4285 if (Nkind (gnat_temp) == N_Pragma)
4286 {
4287 struct attrib *attr;
4288 tree gnu_arg0 = 0, gnu_arg1 = 0;
4289 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
4290 enum attr_type etype;
4291
4292 if (Present (gnat_assoc) && Present (First (gnat_assoc))
4293 && Present (Next (First (gnat_assoc)))
4294 && (Nkind (Expression (Next (First (gnat_assoc))))
4295 == N_String_Literal))
4296 {
4297 gnu_arg0 = get_identifier (TREE_STRING_POINTER
4298 (gnat_to_gnu
4299 (Expression (Next
4300 (First (gnat_assoc))))));
4301 if (Present (Next (Next (First (gnat_assoc))))
4302 && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
4303 == N_String_Literal))
4304 gnu_arg1 = get_identifier (TREE_STRING_POINTER
4305 (gnat_to_gnu
4306 (Expression
4307 (Next (Next
4308 (First (gnat_assoc)))))));
4309 }
4310
4311 switch (Get_Pragma_Id (Chars (gnat_temp)))
4312 {
4313 case Pragma_Machine_Attribute:
4314 etype = ATTR_MACHINE_ATTRIBUTE;
4315 break;
4316
4317 case Pragma_Linker_Alias:
4318 etype = ATTR_LINK_ALIAS;
4319 break;
4320
4321 case Pragma_Linker_Section:
4322 etype = ATTR_LINK_SECTION;
4323 break;
4324
4325 case Pragma_Weak_External:
4326 etype = ATTR_WEAK_EXTERNAL;
4327 break;
4328
4329 default:
4330 continue;
4331 }
4332
4333 attr = (struct attrib *) xmalloc (sizeof (struct attrib));
4334 attr->next = attr_list;
4335 attr->type = etype;
4336 attr->name = gnu_arg0;
4337 attr->arg = gnu_arg1;
4338 attr->error_point
4339 = Present (Next (First (gnat_assoc)))
4340 ? Expression (Next (First (gnat_assoc))) : gnat_temp;
4341 attr_list = attr;
4342 }
4343
4344 return attr_list;
4345 }
4346
4347 /* Get the unpadded version of a GNAT type. */
4348
4349 tree
get_unpadded_type(Entity_Id gnat_entity)4350 get_unpadded_type (Entity_Id gnat_entity)
4351 {
4352 tree type = gnat_to_gnu_type (gnat_entity);
4353
4354 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4355 type = TREE_TYPE (TYPE_FIELDS (type));
4356
4357 return type;
4358 }
4359
4360 /* Called when we need to protect a variable object using a save_expr. */
4361
4362 tree
maybe_variable(tree gnu_operand,Node_Id gnat_node)4363 maybe_variable (tree gnu_operand, Node_Id gnat_node)
4364 {
4365 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
4366 || TREE_CODE (gnu_operand) == SAVE_EXPR
4367 || TREE_CODE (gnu_operand) == NULL_EXPR)
4368 return gnu_operand;
4369
4370 /* If we will be generating code, make sure we are at the proper
4371 line number. */
4372 if (! global_bindings_p () && ! CONTAINS_PLACEHOLDER_P (gnu_operand))
4373 set_lineno (gnat_node, 1);
4374
4375 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
4376 return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
4377 variable_size (TREE_OPERAND (gnu_operand, 0)));
4378 else
4379 return variable_size (gnu_operand);
4380 }
4381
4382 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
4383 type definition (either a bound or a discriminant value) for GNAT_ENTITY,
4384 return the GCC tree to use for that expression. GNU_NAME is the
4385 qualification to use if an external name is appropriate and DEFINITION is
4386 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
4387 we need a result. Otherwise, we are just elaborating this for
4388 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
4389 purposes even if it isn't needed for code generation. */
4390
4391 static tree
elaborate_expression(Node_Id gnat_expr,Entity_Id gnat_entity,tree gnu_name,int definition,int need_value,int need_debug)4392 elaborate_expression (Node_Id gnat_expr,
4393 Entity_Id gnat_entity,
4394 tree gnu_name,
4395 int definition,
4396 int need_value,
4397 int need_debug)
4398 {
4399 tree gnu_expr;
4400
4401 /* If we already elaborated this expression (e.g., it was involved
4402 in the definition of a private type), use the old value. */
4403 if (present_gnu_tree (gnat_expr))
4404 return get_gnu_tree (gnat_expr);
4405
4406 /* If we don't need a value and this is static or a discriment, we
4407 don't need to do anything. */
4408 else if (! need_value
4409 && (Is_OK_Static_Expression (gnat_expr)
4410 || (Nkind (gnat_expr) == N_Identifier
4411 && Ekind (Entity (gnat_expr)) == E_Discriminant)))
4412 return 0;
4413
4414 /* Otherwise, convert this tree to its GCC equivalant. */
4415 gnu_expr
4416 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
4417 gnu_name, definition, need_debug);
4418
4419 /* Save the expression in case we try to elaborate this entity again.
4420 Since this is not a DECL, don't check it. If this is a constant,
4421 don't save it since GNAT_EXPR might be used more than once. Also,
4422 don't save if it's a discriminant. */
4423 if (! CONTAINS_PLACEHOLDER_P (gnu_expr))
4424 save_gnu_tree (gnat_expr, gnu_expr, 1);
4425
4426 return need_value ? gnu_expr : error_mark_node;
4427 }
4428
4429 /* Similar, but take a GNU expression. */
4430
4431 static tree
elaborate_expression_1(Node_Id gnat_expr,Entity_Id gnat_entity,tree gnu_expr,tree gnu_name,int definition,int need_debug)4432 elaborate_expression_1 (Node_Id gnat_expr,
4433 Entity_Id gnat_entity,
4434 tree gnu_expr,
4435 tree gnu_name,
4436 int definition,
4437 int need_debug)
4438 {
4439 tree gnu_decl = 0;
4440 /* Strip any conversions to see if the expression is a readonly variable.
4441 ??? This really should remain readonly, but we have to think about
4442 the typing of the tree here. */
4443 tree gnu_inner_expr = remove_conversions (gnu_expr, 1);
4444 int expr_global = Is_Public (gnat_entity) || global_bindings_p ();
4445 int expr_variable;
4446
4447 /* In most cases, we won't see a naked FIELD_DECL here because a
4448 discriminant reference will have been replaced with a COMPONENT_REF
4449 when the type is being elaborated. However, there are some cases
4450 involving child types where we will. So convert it to a COMPONENT_REF
4451 here. We have to hope it will be at the highest level of the
4452 expression in these cases. */
4453 if (TREE_CODE (gnu_expr) == FIELD_DECL)
4454 gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
4455 build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
4456 gnu_expr);
4457
4458 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
4459 that is a constant, make a variable that is initialized to contain the
4460 bound when the package containing the definition is elaborated. If
4461 this entity is defined at top level and a bound or discriminant value
4462 isn't a constant or a reference to a discriminant, replace the bound
4463 by the variable; otherwise use a SAVE_EXPR if needed. Note that we
4464 rely here on the fact that an expression cannot contain both the
4465 discriminant and some other variable. */
4466
4467 expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c'
4468 && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL
4469 && TREE_READONLY (gnu_inner_expr))
4470 && ! CONTAINS_PLACEHOLDER_P (gnu_expr));
4471
4472 /* If this is a static expression or contains a discriminant, we don't
4473 need the variable for debugging (and can't elaborate anyway if a
4474 discriminant). */
4475 if (need_debug
4476 && (Is_OK_Static_Expression (gnat_expr)
4477 || CONTAINS_PLACEHOLDER_P (gnu_expr)))
4478 need_debug = 0;
4479
4480 /* Now create the variable if we need it. */
4481 if (need_debug || (expr_variable && expr_global))
4482 {
4483 set_lineno (gnat_entity, ! global_bindings_p ());
4484 gnu_decl
4485 = create_var_decl (create_concat_name (gnat_entity,
4486 IDENTIFIER_POINTER (gnu_name)),
4487 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
4488 Is_Public (gnat_entity), ! definition, 0, 0);
4489 }
4490
4491 /* We only need to use this variable if we are in global context since GCC
4492 can do the right thing in the local case. */
4493 if (expr_global && expr_variable)
4494 return gnu_decl;
4495 else if (! expr_variable)
4496 return gnu_expr;
4497 else
4498 return maybe_variable (gnu_expr, gnat_expr);
4499 }
4500
4501 /* Create a record type that contains a field of TYPE with a starting bit
4502 position so that it is aligned to ALIGN bits and is SIZE bytes long. */
4503
4504 tree
make_aligning_type(tree type,int align,tree size)4505 make_aligning_type (tree type, int align, tree size)
4506 {
4507 tree record_type = make_node (RECORD_TYPE);
4508 tree place = build (PLACEHOLDER_EXPR, record_type);
4509 tree size_addr_place = convert (sizetype,
4510 build_unary_op (ADDR_EXPR, NULL_TREE,
4511 place));
4512 tree name = TYPE_NAME (type);
4513 tree pos, field;
4514
4515 if (TREE_CODE (name) == TYPE_DECL)
4516 name = DECL_NAME (name);
4517
4518 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
4519
4520 /* The bit position is obtained by "and"ing the alignment minus 1
4521 with the two's complement of the address and multiplying
4522 by the number of bits per unit. Do all this in sizetype. */
4523
4524 pos = size_binop (MULT_EXPR,
4525 convert (bitsizetype,
4526 size_binop (BIT_AND_EXPR,
4527 size_diffop (size_zero_node,
4528 size_addr_place),
4529 ssize_int ((align / BITS_PER_UNIT)
4530 - 1))),
4531 bitsize_unit_node);
4532
4533 field = create_field_decl (get_identifier ("F"), type, record_type,
4534 1, size, pos, 1);
4535 DECL_BIT_FIELD (field) = 0;
4536
4537 finish_record_type (record_type, field, 1, 0);
4538 TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
4539 TYPE_SIZE (record_type)
4540 = size_binop (PLUS_EXPR,
4541 size_binop (MULT_EXPR, convert (bitsizetype, size),
4542 bitsize_unit_node),
4543 bitsize_int (align));
4544 TYPE_SIZE_UNIT (record_type)
4545 = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
4546 TYPE_ALIAS_SET (record_type) = get_alias_set (type);
4547 return record_type;
4548 }
4549
4550 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
4551 being used as the field type of a packed record. See if we can rewrite it
4552 as a record that has a non-BLKmode type, which we can pack tighter. If so,
4553 return the new type. If not, return the original type. */
4554
4555 static tree
make_packable_type(tree type)4556 make_packable_type (tree type)
4557 {
4558 tree new_type = make_node (TREE_CODE (type));
4559 tree field_list = NULL_TREE;
4560 tree old_field;
4561
4562 /* Copy the name and flags from the old type to that of the new and set
4563 the alignment to try for an integral type. For QUAL_UNION_TYPE,
4564 also copy the size. */
4565 TYPE_NAME (new_type) = TYPE_NAME (type);
4566 TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
4567 = TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
4568 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
4569 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
4570 if (TREE_CODE (type) == QUAL_UNION_TYPE)
4571 {
4572 TYPE_SIZE (new_type) = TYPE_SIZE (type);
4573 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
4574 }
4575
4576 TYPE_ALIGN (new_type)
4577 = ((HOST_WIDE_INT) 1
4578 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
4579
4580 /* Now copy the fields, keeping the position and size. */
4581 for (old_field = TYPE_FIELDS (type); old_field != 0;
4582 old_field = TREE_CHAIN (old_field))
4583 {
4584 tree new_field_type = TREE_TYPE (old_field);
4585 tree new_field;
4586
4587 if (TYPE_MODE (new_field_type) == BLKmode
4588 && (TREE_CODE (new_field_type) == RECORD_TYPE
4589 || TREE_CODE (new_field_type) == UNION_TYPE
4590 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
4591 && host_integerp (TYPE_SIZE (new_field_type), 1))
4592 new_field_type = make_packable_type (new_field_type);
4593
4594 new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
4595 new_type, TYPE_PACKED (type),
4596 DECL_SIZE (old_field),
4597 bit_position (old_field),
4598 ! DECL_NONADDRESSABLE_P (old_field));
4599
4600 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
4601 SET_DECL_ORIGINAL_FIELD (new_field,
4602 (DECL_ORIGINAL_FIELD (old_field) != 0
4603 ? DECL_ORIGINAL_FIELD (old_field) : old_field));
4604
4605 if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
4606 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
4607
4608 TREE_CHAIN (new_field) = field_list;
4609 field_list = new_field;
4610 }
4611
4612 finish_record_type (new_type, nreverse (field_list), 1, 1);
4613 TYPE_ALIAS_SET (new_type) = get_alias_set (type);
4614 return TYPE_MODE (new_type) == BLKmode ? type : new_type;
4615 }
4616
4617 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
4618 if needed. We have already verified that SIZE and TYPE are large enough.
4619
4620 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
4621 to issue a warning.
4622
4623 IS_USER_TYPE is nonzero if we must be sure we complete the original type.
4624
4625 DEFINITION is nonzero if this type is being defined.
4626
4627 SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be
4628 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
4629 type. */
4630
4631 static tree
maybe_pad_type(tree type,tree size,unsigned int align,Entity_Id gnat_entity,const char * name_trailer,int is_user_type,int definition,int same_rm_size)4632 maybe_pad_type (tree type,
4633 tree size,
4634 unsigned int align,
4635 Entity_Id gnat_entity,
4636 const char *name_trailer,
4637 int is_user_type,
4638 int definition,
4639 int same_rm_size)
4640 {
4641 tree orig_size = TYPE_SIZE (type);
4642 tree record;
4643 tree field;
4644
4645 /* If TYPE is a padded type, see if it agrees with any size and alignment
4646 we were given. If so, return the original type. Otherwise, strip
4647 off the padding, since we will either be returning the inner type
4648 or repadding it. If no size or alignment is specified, use that of
4649 the original padded type. */
4650
4651 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4652 {
4653 if ((size == 0
4654 || operand_equal_p (round_up (size,
4655 MAX (align, TYPE_ALIGN (type))),
4656 round_up (TYPE_SIZE (type),
4657 MAX (align, TYPE_ALIGN (type))),
4658 0))
4659 && (align == 0 || align == TYPE_ALIGN (type)))
4660 return type;
4661
4662 if (size == 0)
4663 size = TYPE_SIZE (type);
4664 if (align == 0)
4665 align = TYPE_ALIGN (type);
4666
4667 type = TREE_TYPE (TYPE_FIELDS (type));
4668 orig_size = TYPE_SIZE (type);
4669 }
4670
4671 /* If the size is either not being changed or is being made smaller (which
4672 is not done here (and is only valid for bitfields anyway), show the size
4673 isn't changing. Likewise, clear the alignment if it isn't being
4674 changed. Then return if we aren't doing anything. */
4675
4676 if (size != 0
4677 && (operand_equal_p (size, orig_size, 0)
4678 || (TREE_CODE (orig_size) == INTEGER_CST
4679 && tree_int_cst_lt (size, orig_size))))
4680 size = 0;
4681
4682 if (align == TYPE_ALIGN (type))
4683 align = 0;
4684
4685 if (align == 0 && size == 0)
4686 return type;
4687
4688 /* We used to modify the record in place in some cases, but that could
4689 generate incorrect debugging information. So make a new record
4690 type and name. */
4691 record = make_node (RECORD_TYPE);
4692
4693 if (Present (gnat_entity))
4694 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
4695
4696 /* If we were making a type, complete the original type and give it a
4697 name. */
4698 if (is_user_type)
4699 create_type_decl (get_entity_name (gnat_entity), type,
4700 0, ! Comes_From_Source (gnat_entity),
4701 ! (TYPE_NAME (type) != 0
4702 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
4703 && DECL_IGNORED_P (TYPE_NAME (type))));
4704
4705 /* If we are changing the alignment and the input type is a record with
4706 BLKmode and a small constant size, try to make a form that has an
4707 integral mode. That might allow this record to have an integral mode,
4708 which will be much more efficient. There is no point in doing this if a
4709 size is specified unless it is also smaller than the biggest alignment
4710 and it is incorrect to do this if the size of the original type is not a
4711 multiple of the alignment. */
4712 if (align != 0
4713 && TREE_CODE (type) == RECORD_TYPE
4714 && TYPE_MODE (type) == BLKmode
4715 && host_integerp (orig_size, 1)
4716 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
4717 && (size == 0
4718 || (TREE_CODE (size) == INTEGER_CST
4719 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
4720 && tree_low_cst (orig_size, 1) % align == 0)
4721 type = make_packable_type (type);
4722
4723 field = create_field_decl (get_identifier ("F"), type, record, 0,
4724 NULL_TREE, bitsize_zero_node, 1);
4725
4726 DECL_INTERNAL_P (field) = 1;
4727 TYPE_SIZE (record) = size != 0 ? size : orig_size;
4728 TYPE_SIZE_UNIT (record)
4729 = convert (sizetype,
4730 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
4731 bitsize_unit_node));
4732 TYPE_ALIGN (record) = align;
4733 TYPE_IS_PADDING_P (record) = 1;
4734 TYPE_VOLATILE (record)
4735 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
4736 finish_record_type (record, field, 1, 0);
4737
4738 /* Keep the RM_Size of the padded record as that of the old record
4739 if requested. */
4740 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
4741
4742 /* Unless debugging information isn't being written for the input type,
4743 write a record that shows what we are a subtype of and also make a
4744 variable that indicates our size, if variable. */
4745 if (TYPE_NAME (record) != 0
4746 && AGGREGATE_TYPE_P (type)
4747 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
4748 || ! DECL_IGNORED_P (TYPE_NAME (type))))
4749 {
4750 tree marker = make_node (RECORD_TYPE);
4751 tree name = DECL_NAME (TYPE_NAME (record));
4752 tree orig_name = TYPE_NAME (type);
4753
4754 if (TREE_CODE (orig_name) == TYPE_DECL)
4755 orig_name = DECL_NAME (orig_name);
4756
4757 TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
4758 finish_record_type (marker,
4759 create_field_decl (orig_name, integer_type_node,
4760 marker, 0, NULL_TREE, NULL_TREE,
4761 0),
4762 0, 0);
4763
4764 if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
4765 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
4766 sizetype, TYPE_SIZE (record), 0, 0, 0, 0,
4767 0);
4768 }
4769
4770 type = record;
4771
4772 if (CONTAINS_PLACEHOLDER_P (orig_size))
4773 orig_size = max_size (orig_size, 1);
4774
4775 /* If the size was widened explicitly, maybe give a warning. */
4776 if (size != 0 && Present (gnat_entity)
4777 && ! operand_equal_p (size, orig_size, 0)
4778 && ! (TREE_CODE (size) == INTEGER_CST
4779 && TREE_CODE (orig_size) == INTEGER_CST
4780 && tree_int_cst_lt (size, orig_size)))
4781 {
4782 Node_Id gnat_error_node = Empty;
4783
4784 if (Is_Packed_Array_Type (gnat_entity))
4785 gnat_entity = Associated_Node_For_Itype (gnat_entity);
4786
4787 if ((Ekind (gnat_entity) == E_Component
4788 || Ekind (gnat_entity) == E_Discriminant)
4789 && Present (Component_Clause (gnat_entity)))
4790 gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
4791 else if (Present (Size_Clause (gnat_entity)))
4792 gnat_error_node = Expression (Size_Clause (gnat_entity));
4793
4794 /* Generate message only for entities that come from source, since
4795 if we have an entity created by expansion, the message will be
4796 generated for some other corresponding source entity. */
4797 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
4798 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
4799 gnat_entity,
4800 size_diffop (size, orig_size));
4801
4802 else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity))
4803 post_error_ne_tree ("component of& padded{ by ^ bits}?",
4804 gnat_entity, gnat_entity,
4805 size_diffop (size, orig_size));
4806 }
4807
4808 return type;
4809 }
4810
4811 /* Given a GNU tree and a GNAT list of choices, generate an expression to test
4812 the value passed against the list of choices. */
4813
4814 tree
choices_to_gnu(tree operand,Node_Id choices)4815 choices_to_gnu (tree operand, Node_Id choices)
4816 {
4817 Node_Id choice;
4818 Node_Id gnat_temp;
4819 tree result = integer_zero_node;
4820 tree this_test, low = 0, high = 0, single = 0;
4821
4822 for (choice = First (choices); Present (choice); choice = Next (choice))
4823 {
4824 switch (Nkind (choice))
4825 {
4826 case N_Range:
4827 low = gnat_to_gnu (Low_Bound (choice));
4828 high = gnat_to_gnu (High_Bound (choice));
4829
4830 /* There's no good type to use here, so we might as well use
4831 integer_type_node. */
4832 this_test
4833 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4834 build_binary_op (GE_EXPR, integer_type_node,
4835 operand, low),
4836 build_binary_op (LE_EXPR, integer_type_node,
4837 operand, high));
4838
4839 break;
4840
4841 case N_Subtype_Indication:
4842 gnat_temp = Range_Expression (Constraint (choice));
4843 low = gnat_to_gnu (Low_Bound (gnat_temp));
4844 high = gnat_to_gnu (High_Bound (gnat_temp));
4845
4846 this_test
4847 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4848 build_binary_op (GE_EXPR, integer_type_node,
4849 operand, low),
4850 build_binary_op (LE_EXPR, integer_type_node,
4851 operand, high));
4852 break;
4853
4854 case N_Identifier:
4855 case N_Expanded_Name:
4856 /* This represents either a subtype range, an enumeration
4857 literal, or a constant Ekind says which. If an enumeration
4858 literal or constant, fall through to the next case. */
4859 if (Ekind (Entity (choice)) != E_Enumeration_Literal
4860 && Ekind (Entity (choice)) != E_Constant)
4861 {
4862 tree type = gnat_to_gnu_type (Entity (choice));
4863
4864 low = TYPE_MIN_VALUE (type);
4865 high = TYPE_MAX_VALUE (type);
4866
4867 this_test
4868 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
4869 build_binary_op (GE_EXPR, integer_type_node,
4870 operand, low),
4871 build_binary_op (LE_EXPR, integer_type_node,
4872 operand, high));
4873 break;
4874 }
4875 /* ... fall through ... */
4876 case N_Character_Literal:
4877 case N_Integer_Literal:
4878 single = gnat_to_gnu (choice);
4879 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
4880 single);
4881 break;
4882
4883 case N_Others_Choice:
4884 this_test = integer_one_node;
4885 break;
4886
4887 default:
4888 gigi_abort (114);
4889 }
4890
4891 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
4892 result, this_test);
4893 }
4894
4895 return result;
4896 }
4897
4898 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be
4899 placed in GNU_RECORD_TYPE.
4900
4901 PACKED is 1 if the enclosing record is packed and -1 if the enclosing
4902 record has a Component_Alignment of Storage_Unit.
4903
4904 DEFINITION is nonzero if this field is for a record being defined. */
4905
4906 static tree
gnat_to_gnu_field(Entity_Id gnat_field,tree gnu_record_type,int packed,int definition)4907 gnat_to_gnu_field (Entity_Id gnat_field,
4908 tree gnu_record_type,
4909 int packed,
4910 int definition)
4911 {
4912 tree gnu_field_id = get_entity_name (gnat_field);
4913 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
4914 tree gnu_orig_field_type = gnu_field_type;
4915 tree gnu_pos = 0;
4916 tree gnu_size = 0;
4917 tree gnu_field;
4918 int needs_strict_alignment
4919 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
4920 || Treat_As_Volatile (gnat_field));
4921
4922 /* If this field requires strict alignment or contains an item of
4923 variable sized, pretend it isn't packed. */
4924 if (needs_strict_alignment || is_variable_size (gnu_field_type))
4925 packed = 0;
4926
4927 /* For packed records, this is one of the few occasions on which we use
4928 the official RM size for discrete or fixed-point components, instead
4929 of the normal GNAT size stored in Esize. See description in Einfo:
4930 "Handling of Type'Size Values" for further details. */
4931
4932 if (packed == 1)
4933 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
4934 gnat_field, FIELD_DECL, 0, 1);
4935
4936 if (Known_Static_Esize (gnat_field))
4937 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
4938 gnat_field, FIELD_DECL, 0, 1);
4939
4940 /* If the field's type is left-justified modular, the wrapper can prevent
4941 packing so we make the field the type of the inner object unless the
4942 situation forbids it. We may not do that when the field is addressable_p,
4943 typically because in that case this field may later be passed by-ref for
4944 a formal argument expecting the left justification. The condition below
4945 is then matching the addressable_p code for COMPONENT_REF. */
4946 if (! Is_Aliased (gnat_field) && flag_strict_aliasing
4947 && TREE_CODE (gnu_field_type) == RECORD_TYPE
4948 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
4949 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
4950
4951 /* If we are packing this record or we have a specified size that's
4952 smaller than that of the field type and the field type is also a record
4953 that's BLKmode and with a small constant size, see if we can get a
4954 better form of the type that allows more packing. If we can, show
4955 a size was specified for it if there wasn't one so we know to
4956 make this a bitfield and avoid making things wider. */
4957 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
4958 && TYPE_MODE (gnu_field_type) == BLKmode
4959 && host_integerp (TYPE_SIZE (gnu_field_type), 1)
4960 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
4961 && (packed
4962 || (gnu_size != 0 && tree_int_cst_lt (gnu_size,
4963 TYPE_SIZE (gnu_field_type)))))
4964 {
4965 gnu_field_type = make_packable_type (gnu_field_type);
4966
4967 if (gnu_field_type != gnu_orig_field_type && gnu_size == 0)
4968 gnu_size = rm_size (gnu_field_type);
4969 }
4970
4971 /* If we are packing the record and the field is BLKmode, round the
4972 size up to a byte boundary. */
4973 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0)
4974 gnu_size = round_up (gnu_size, BITS_PER_UNIT);
4975
4976 if (Present (Component_Clause (gnat_field)))
4977 {
4978 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
4979 gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
4980 gnat_field, FIELD_DECL, 0, 1);
4981
4982 /* Ensure the position does not overlap with the parent subtype,
4983 if there is one. */
4984 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
4985 {
4986 tree gnu_parent
4987 = gnat_to_gnu_type (Parent_Subtype
4988 (Underlying_Type (Scope (gnat_field))));
4989
4990 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
4991 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
4992 {
4993 post_error_ne_tree
4994 ("offset of& must be beyond parent{, minimum allowed is ^}",
4995 First_Bit (Component_Clause (gnat_field)), gnat_field,
4996 TYPE_SIZE_UNIT (gnu_parent));
4997 }
4998 }
4999
5000 /* If this field needs strict alignment, ensure the record is
5001 sufficiently aligned and that that position and size are
5002 consistent with the alignment. */
5003 if (needs_strict_alignment)
5004 {
5005 tree gnu_min_size = round_up (rm_size (gnu_field_type),
5006 TYPE_ALIGN (gnu_field_type));
5007
5008 TYPE_ALIGN (gnu_record_type)
5009 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
5010
5011 /* If Atomic, the size must match exactly and if aliased, the size
5012 must not be less than the rounded size. */
5013 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
5014 && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
5015 {
5016 post_error_ne_tree
5017 ("atomic field& must be natural size of type{ (^)}",
5018 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5019 TYPE_SIZE (gnu_field_type));
5020
5021 gnu_size = 0;
5022 }
5023
5024 else if (Is_Aliased (gnat_field)
5025 && gnu_size != 0
5026 && tree_int_cst_lt (gnu_size, gnu_min_size))
5027 {
5028 post_error_ne_tree
5029 ("size of aliased field& too small{, minimum required is ^}",
5030 Last_Bit (Component_Clause (gnat_field)), gnat_field,
5031 gnu_min_size);
5032 gnu_size = 0;
5033 }
5034
5035 if (! integer_zerop (size_binop
5036 (TRUNC_MOD_EXPR, gnu_pos,
5037 bitsize_int (TYPE_ALIGN (gnu_field_type)))))
5038 {
5039 if (Is_Aliased (gnat_field))
5040 post_error_ne_num
5041 ("position of aliased field& must be multiple of ^ bits",
5042 First_Bit (Component_Clause (gnat_field)), gnat_field,
5043 TYPE_ALIGN (gnu_field_type));
5044
5045 else if (Treat_As_Volatile (gnat_field))
5046 post_error_ne_num
5047 ("position of volatile field& must be multiple of ^ bits",
5048 First_Bit (Component_Clause (gnat_field)), gnat_field,
5049 TYPE_ALIGN (gnu_field_type));
5050
5051 else if (Strict_Alignment (Etype (gnat_field)))
5052 post_error_ne_num
5053 ("position of & with aliased or tagged components not multiple of ^ bits",
5054 First_Bit (Component_Clause (gnat_field)), gnat_field,
5055 TYPE_ALIGN (gnu_field_type));
5056 else
5057 gigi_abort (124);
5058
5059 gnu_pos = 0;
5060 }
5061
5062 /* If an error set the size to zero, show we have no position
5063 either. */
5064 if (gnu_size == 0)
5065 gnu_pos = 0;
5066 }
5067
5068 if (Is_Atomic (gnat_field))
5069 check_ok_for_atomic (gnu_field_type, gnat_field, 0);
5070 }
5071
5072 /* If the record has rep clauses and this is the tag field, make a rep
5073 clause for it as well. */
5074 else if (Has_Specified_Layout (Scope (gnat_field))
5075 && Chars (gnat_field) == Name_uTag)
5076 {
5077 gnu_pos = bitsize_zero_node;
5078 gnu_size = TYPE_SIZE (gnu_field_type);
5079 }
5080
5081 /* We need to make the size the maximum for the type if it is
5082 self-referential and an unconstrained type. In that case, we can't
5083 pack the field since we can't make a copy to align it. */
5084 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5085 && gnu_size == 0
5086 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
5087 && ! Is_Constrained (Underlying_Type (Etype (gnat_field))))
5088 {
5089 gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1);
5090 packed = 0;
5091 }
5092
5093 /* If no size is specified (or if there was an error), don't specify a
5094 position. */
5095 if (gnu_size == 0)
5096 gnu_pos = 0;
5097 else
5098 {
5099 /* Unless this field is aliased, we can remove any left-justified
5100 modular type since it's only needed in the unchecked conversion
5101 case, which doesn't apply here. */
5102 if (! needs_strict_alignment
5103 && TREE_CODE (gnu_field_type) == RECORD_TYPE
5104 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
5105 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
5106
5107 gnu_field_type
5108 = make_type_from_size (gnu_field_type, gnu_size,
5109 Has_Biased_Representation (gnat_field));
5110 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0,
5111 gnat_field, "PAD", 0, definition, 1);
5112 }
5113
5114 if (TREE_CODE (gnu_field_type) == RECORD_TYPE
5115 && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
5116 gigi_abort (118);
5117
5118 /* Now create the decl for the field. */
5119 set_lineno (gnat_field, 0);
5120 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
5121 packed, gnu_size, gnu_pos,
5122 Is_Aliased (gnat_field));
5123
5124 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
5125
5126 if (Ekind (gnat_field) == E_Discriminant)
5127 DECL_DISCRIMINANT_NUMBER (gnu_field)
5128 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
5129
5130 return gnu_field;
5131 }
5132
5133 /* Return 1 if TYPE is a type with variable size, a padding type with a field
5134 of variable size or is a record that has a field such a field. */
5135
5136 static int
is_variable_size(tree type)5137 is_variable_size (tree type)
5138 {
5139 tree field;
5140
5141 /* We need not be concerned about this at all if we don't have
5142 strict alignment. */
5143 if (! STRICT_ALIGNMENT)
5144 return 0;
5145 else if (! TREE_CONSTANT (TYPE_SIZE (type)))
5146 return 1;
5147 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
5148 && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
5149 return 1;
5150 else if (TREE_CODE (type) != RECORD_TYPE
5151 && TREE_CODE (type) != UNION_TYPE
5152 && TREE_CODE (type) != QUAL_UNION_TYPE)
5153 return 0;
5154
5155 for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field))
5156 if (is_variable_size (TREE_TYPE (field)))
5157 return 1;
5158
5159 return 0;
5160 }
5161
5162 /* Return a GCC tree for a record type given a GNAT Component_List and a chain
5163 of GCC trees for fields that are in the record and have already been
5164 processed. When called from gnat_to_gnu_entity during the processing of a
5165 record type definition, the GCC nodes for the discriminants will be on
5166 the chain. The other calls to this function are recursive calls from
5167 itself for the Component_List of a variant and the chain is empty.
5168
5169 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is
5170 for a record type with "pragma component_alignment (storage_unit)".
5171
5172 FINISH_RECORD is nonzero if this call will supply all of the remaining
5173 fields of the record.
5174
5175 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
5176 with a rep clause is to be added. If it is nonzero, that is all that
5177 should be done with such fields.
5178
5179 CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed
5180 before laying out the record. This means the alignment only serves
5181 to force fields to be bitfields, but not require the record to be
5182 that aligned. This is used for variants.
5183
5184 ALL_REP, if nonzero, means that a rep clause was found for all the
5185 fields. This simplifies the logic since we know we're not in the mixed
5186 case.
5187
5188 The processing of the component list fills in the chain with all of the
5189 fields of the record and then the record type is finished. */
5190
5191 static void
components_to_record(tree gnu_record_type,Node_Id component_list,tree gnu_field_list,int packed,int definition,tree * p_gnu_rep_list,int cancel_alignment,int all_rep)5192 components_to_record (tree gnu_record_type,
5193 Node_Id component_list,
5194 tree gnu_field_list,
5195 int packed,
5196 int definition,
5197 tree *p_gnu_rep_list,
5198 int cancel_alignment,
5199 int all_rep)
5200 {
5201 Node_Id component_decl;
5202 Entity_Id gnat_field;
5203 Node_Id variant_part;
5204 Node_Id variant;
5205 tree gnu_our_rep_list = NULL_TREE;
5206 tree gnu_field, gnu_last;
5207 int layout_with_rep = 0;
5208 int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0;
5209
5210 /* For each variable within each component declaration create a GCC field
5211 and add it to the list, skipping any pragmas in the list. */
5212
5213 if (Present (Component_Items (component_list)))
5214 for (component_decl = First_Non_Pragma (Component_Items (component_list));
5215 Present (component_decl);
5216 component_decl = Next_Non_Pragma (component_decl))
5217 {
5218 gnat_field = Defining_Entity (component_decl);
5219
5220 if (Chars (gnat_field) == Name_uParent)
5221 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
5222 else
5223 {
5224 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
5225 packed, definition);
5226
5227 /* If this is the _Tag field, put it before any discriminants,
5228 instead of after them as is the case for all other fields.
5229 Ignore field of void type if only annotating. */
5230 if (Chars (gnat_field) == Name_uTag)
5231 gnu_field_list = chainon (gnu_field_list, gnu_field);
5232 else
5233 {
5234 TREE_CHAIN (gnu_field) = gnu_field_list;
5235 gnu_field_list = gnu_field;
5236 }
5237 }
5238
5239 save_gnu_tree (gnat_field, gnu_field, 0);
5240 }
5241
5242 /* At the end of the component list there may be a variant part. */
5243 variant_part = Variant_Part (component_list);
5244
5245 /* If this is an unchecked union, each variant must have exactly one
5246 component, each of which becomes one component of this union. */
5247 if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part))
5248 for (variant = First_Non_Pragma (Variants (variant_part));
5249 Present (variant);
5250 variant = Next_Non_Pragma (variant))
5251 {
5252 component_decl
5253 = First_Non_Pragma (Component_Items (Component_List (variant)));
5254 gnat_field = Defining_Entity (component_decl);
5255 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
5256 definition);
5257 TREE_CHAIN (gnu_field) = gnu_field_list;
5258 gnu_field_list = gnu_field;
5259 save_gnu_tree (gnat_field, gnu_field, 0);
5260 }
5261
5262 /* We create a QUAL_UNION_TYPE for the variant part since the variants are
5263 mutually exclusive and should go in the same memory. To do this we need
5264 to treat each variant as a record whose elements are created from the
5265 component list for the variant. So here we create the records from the
5266 lists for the variants and put them all into the QUAL_UNION_TYPE. */
5267 else if (Present (variant_part))
5268 {
5269 tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
5270 Node_Id variant;
5271 tree gnu_union_type = make_node (QUAL_UNION_TYPE);
5272 tree gnu_union_field;
5273 tree gnu_variant_list = NULL_TREE;
5274 tree gnu_name = TYPE_NAME (gnu_record_type);
5275 tree gnu_var_name
5276 = concat_id_with_name
5277 (get_identifier (Get_Name_String (Chars (Name (variant_part)))),
5278 "XVN");
5279
5280 if (TREE_CODE (gnu_name) == TYPE_DECL)
5281 gnu_name = DECL_NAME (gnu_name);
5282
5283 TYPE_NAME (gnu_union_type)
5284 = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
5285 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
5286
5287 for (variant = First_Non_Pragma (Variants (variant_part));
5288 Present (variant);
5289 variant = Next_Non_Pragma (variant))
5290 {
5291 tree gnu_variant_type = make_node (RECORD_TYPE);
5292 tree gnu_inner_name;
5293 tree gnu_qual;
5294
5295 Get_Variant_Encoding (variant);
5296 gnu_inner_name = get_identifier (Name_Buffer);
5297 TYPE_NAME (gnu_variant_type)
5298 = concat_id_with_name (TYPE_NAME (gnu_union_type),
5299 IDENTIFIER_POINTER (gnu_inner_name));
5300
5301 /* Set the alignment of the inner type in case we need to make
5302 inner objects into bitfields, but then clear it out
5303 so the record actually gets only the alignment required. */
5304 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
5305 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
5306
5307 /* Similarly, if the outer record has a size specified and all fields
5308 have record rep clauses, we can propagate the size into the
5309 variant part. */
5310 if (all_rep_and_size)
5311 {
5312 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
5313 TYPE_SIZE_UNIT (gnu_variant_type)
5314 = TYPE_SIZE_UNIT (gnu_record_type);
5315 }
5316
5317 components_to_record (gnu_variant_type, Component_List (variant),
5318 NULL_TREE, packed, definition,
5319 &gnu_our_rep_list, !all_rep_and_size, all_rep);
5320
5321 gnu_qual = choices_to_gnu (gnu_discriminant,
5322 Discrete_Choices (variant));
5323
5324 Set_Present_Expr (variant, annotate_value (gnu_qual));
5325 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
5326 gnu_union_type, 0,
5327 (all_rep_and_size
5328 ? TYPE_SIZE (gnu_record_type) : 0),
5329 (all_rep_and_size
5330 ? bitsize_zero_node : 0),
5331 1);
5332
5333 DECL_INTERNAL_P (gnu_field) = 1;
5334 DECL_QUALIFIER (gnu_field) = gnu_qual;
5335 TREE_CHAIN (gnu_field) = gnu_variant_list;
5336 gnu_variant_list = gnu_field;
5337 }
5338
5339 /* We use to delete the empty variants from the end. However,
5340 we no longer do that because we need them to generate complete
5341 debugging information for the variant record. Otherwise,
5342 the union type definition will be missing the fields associated
5343 to these empty variants. */
5344
5345 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
5346 if (gnu_variant_list != 0)
5347 {
5348 if (all_rep_and_size)
5349 {
5350 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
5351 TYPE_SIZE_UNIT (gnu_union_type)
5352 = TYPE_SIZE_UNIT (gnu_record_type);
5353 }
5354
5355 finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
5356 all_rep_and_size, 0);
5357
5358 gnu_union_field
5359 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
5360 packed,
5361 all_rep ? TYPE_SIZE (gnu_union_type) : 0,
5362 all_rep ? bitsize_zero_node : 0, 1);
5363
5364 DECL_INTERNAL_P (gnu_union_field) = 1;
5365 TREE_CHAIN (gnu_union_field) = gnu_field_list;
5366 gnu_field_list = gnu_union_field;
5367 }
5368 }
5369
5370 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
5371 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
5372 in a separate pass since we want to handle the discriminants but can't
5373 play with them until we've used them in debugging data above.
5374
5375 ??? Note: if we then reorder them, debugging information will be wrong,
5376 but there's nothing that can be done about this at the moment. */
5377
5378 for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; )
5379 {
5380 if (DECL_FIELD_OFFSET (gnu_field) != 0)
5381 {
5382 tree gnu_next = TREE_CHAIN (gnu_field);
5383
5384 if (gnu_last == 0)
5385 gnu_field_list = gnu_next;
5386 else
5387 TREE_CHAIN (gnu_last) = gnu_next;
5388
5389 TREE_CHAIN (gnu_field) = gnu_our_rep_list;
5390 gnu_our_rep_list = gnu_field;
5391 gnu_field = gnu_next;
5392 }
5393 else
5394 {
5395 gnu_last = gnu_field;
5396 gnu_field = TREE_CHAIN (gnu_field);
5397 }
5398 }
5399
5400 /* If we have any items in our rep'ed field list, it is not the case that all
5401 the fields in the record have rep clauses, and P_REP_LIST is nonzero,
5402 set it and ignore the items. Otherwise, sort the fields by bit position
5403 and put them into their own record if we have any fields without
5404 rep clauses. */
5405 if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep)
5406 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
5407 else if (gnu_our_rep_list != 0)
5408 {
5409 tree gnu_rep_type
5410 = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE);
5411 int len = list_length (gnu_our_rep_list);
5412 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
5413 int i;
5414
5415 /* Set DECL_SECTION_NAME to increasing integers so we have a
5416 stable sort. */
5417 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
5418 gnu_field = TREE_CHAIN (gnu_field), i++)
5419 {
5420 gnu_arr[i] = gnu_field;
5421 DECL_SECTION_NAME (gnu_field) = size_int (i);
5422 }
5423
5424 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
5425
5426 /* Put the fields in the list in order of increasing position, which
5427 means we start from the end. */
5428 gnu_our_rep_list = NULL_TREE;
5429 for (i = len - 1; i >= 0; i--)
5430 {
5431 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
5432 gnu_our_rep_list = gnu_arr[i];
5433 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
5434 DECL_SECTION_NAME (gnu_arr[i]) = 0;
5435 }
5436
5437 if (gnu_field_list != 0)
5438 {
5439 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0);
5440 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
5441 gnu_record_type, 0, 0, 0, 1);
5442 DECL_INTERNAL_P (gnu_field) = 1;
5443 gnu_field_list = chainon (gnu_field_list, gnu_field);
5444 }
5445 else
5446 {
5447 layout_with_rep = 1;
5448 gnu_field_list = nreverse (gnu_our_rep_list);
5449 }
5450 }
5451
5452 if (cancel_alignment)
5453 TYPE_ALIGN (gnu_record_type) = 0;
5454
5455 finish_record_type (gnu_record_type, nreverse (gnu_field_list),
5456 layout_with_rep, 0);
5457 }
5458
5459 /* Called via qsort from the above. Returns -1, 1, depending on the
5460 bit positions and ordinals of the two fields. */
5461
5462 static int
compare_field_bitpos(const PTR rt1,const PTR rt2)5463 compare_field_bitpos (const PTR rt1, const PTR rt2)
5464 {
5465 tree *t1 = (tree *) rt1;
5466 tree *t2 = (tree *) rt2;
5467
5468 if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
5469 return
5470 (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2))
5471 ? -1 : 1);
5472 else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
5473 return -1;
5474 else
5475 return 1;
5476 }
5477
5478 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
5479 placed into an Esize, Component_Bit_Offset, or Component_Size value
5480 in the GNAT tree. */
5481
5482 static Uint
annotate_value(tree gnu_size)5483 annotate_value (tree gnu_size)
5484 {
5485 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
5486 TCode tcode;
5487 Node_Ref_Or_Val ops[3], ret;
5488 int i;
5489 int size;
5490
5491 /* If back annotation is suppressed by the front end, return No_Uint */
5492 if (!Back_Annotate_Rep_Info)
5493 return No_Uint;
5494
5495 /* See if we've already saved the value for this node. */
5496 if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size)))
5497 && TREE_COMPLEXITY (gnu_size) != 0)
5498 return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
5499
5500 /* If we do not return inside this switch, TCODE will be set to the
5501 code to use for a Create_Node operand and LEN (set above) will be
5502 the number of recursive calls for us to make. */
5503
5504 switch (TREE_CODE (gnu_size))
5505 {
5506 case INTEGER_CST:
5507 if (TREE_OVERFLOW (gnu_size))
5508 return No_Uint;
5509
5510 /* This may have come from a conversion from some smaller type,
5511 so ensure this is in bitsizetype. */
5512 gnu_size = convert (bitsizetype, gnu_size);
5513
5514 /* For negative values, use NEGATE_EXPR of the supplied value. */
5515 if (tree_int_cst_sgn (gnu_size) < 0)
5516 {
5517 /* The rediculous code below is to handle the case of the largest
5518 negative integer. */
5519 tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
5520 int adjust = 0;
5521 tree temp;
5522
5523 if (TREE_CONSTANT_OVERFLOW (negative_size))
5524 {
5525 negative_size
5526 = size_binop (MINUS_EXPR, bitsize_zero_node,
5527 size_binop (PLUS_EXPR, gnu_size,
5528 bitsize_one_node));
5529 adjust = 1;
5530 }
5531
5532 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
5533 if (adjust)
5534 temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
5535
5536 return annotate_value (temp);
5537 }
5538
5539 if (! host_integerp (gnu_size, 1))
5540 return No_Uint;
5541
5542 size = tree_low_cst (gnu_size, 1);
5543
5544 /* This peculiar test is to make sure that the size fits in an int
5545 on machines where HOST_WIDE_INT is not "int". */
5546 if (tree_low_cst (gnu_size, 1) == size)
5547 return UI_From_Int (size);
5548 else
5549 return No_Uint;
5550
5551 case COMPONENT_REF:
5552 /* The only case we handle here is a simple discriminant reference. */
5553 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
5554 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
5555 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0)
5556 return Create_Node (Discrim_Val,
5557 annotate_value (DECL_DISCRIMINANT_NUMBER
5558 (TREE_OPERAND (gnu_size, 1))),
5559 No_Uint, No_Uint);
5560 else
5561 return No_Uint;
5562
5563 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
5564 return annotate_value (TREE_OPERAND (gnu_size, 0));
5565
5566 /* Now just list the operations we handle. */
5567 case COND_EXPR: tcode = Cond_Expr; break;
5568 case PLUS_EXPR: tcode = Plus_Expr; break;
5569 case MINUS_EXPR: tcode = Minus_Expr; break;
5570 case MULT_EXPR: tcode = Mult_Expr; break;
5571 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
5572 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
5573 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
5574 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
5575 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
5576 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
5577 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
5578 case NEGATE_EXPR: tcode = Negate_Expr; break;
5579 case MIN_EXPR: tcode = Min_Expr; break;
5580 case MAX_EXPR: tcode = Max_Expr; break;
5581 case ABS_EXPR: tcode = Abs_Expr; break;
5582 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
5583 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
5584 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
5585 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
5586 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
5587 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
5588 case LT_EXPR: tcode = Lt_Expr; break;
5589 case LE_EXPR: tcode = Le_Expr; break;
5590 case GT_EXPR: tcode = Gt_Expr; break;
5591 case GE_EXPR: tcode = Ge_Expr; break;
5592 case EQ_EXPR: tcode = Eq_Expr; break;
5593 case NE_EXPR: tcode = Ne_Expr; break;
5594
5595 default:
5596 return No_Uint;
5597 }
5598
5599 /* Now get each of the operands that's relevant for this code. If any
5600 cannot be expressed as a repinfo node, say we can't. */
5601 for (i = 0; i < 3; i++)
5602 ops[i] = No_Uint;
5603
5604 for (i = 0; i < len; i++)
5605 {
5606 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
5607 if (ops[i] == No_Uint)
5608 return No_Uint;
5609 }
5610
5611 ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
5612 TREE_COMPLEXITY (gnu_size) = ret;
5613 return ret;
5614 }
5615
5616 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
5617 GCC type, set Component_Bit_Offset and Esize to the position and size
5618 used by Gigi. */
5619
5620 static void
annotate_rep(Entity_Id gnat_entity,tree gnu_type)5621 annotate_rep (Entity_Id gnat_entity, tree gnu_type)
5622 {
5623 tree gnu_list;
5624 tree gnu_entry;
5625 Entity_Id gnat_field;
5626
5627 /* We operate by first making a list of all field and their positions
5628 (we can get the sizes easily at any time) by a recursive call
5629 and then update all the sizes into the tree. */
5630 gnu_list = compute_field_positions (gnu_type, NULL_TREE,
5631 size_zero_node, bitsize_zero_node,
5632 BIGGEST_ALIGNMENT);
5633
5634 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
5635 gnat_field = Next_Entity (gnat_field))
5636 if ((Ekind (gnat_field) == E_Component
5637 || (Ekind (gnat_field) == E_Discriminant
5638 && ! Is_Unchecked_Union (Scope (gnat_field)))))
5639 {
5640 tree parent_offset = bitsize_zero_node;
5641
5642 gnu_entry
5643 = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0),
5644 gnu_list);
5645
5646 if (gnu_entry)
5647 {
5648 if (type_annotate_only && Is_Tagged_Type (gnat_entity))
5649 {
5650 /* In this mode the tag and parent components have not been
5651 generated, so we add the appropriate offset to each
5652 component. For a component appearing in the current
5653 extension, the offset is the size of the parent. */
5654 if (Is_Derived_Type (gnat_entity)
5655 && Original_Record_Component (gnat_field) == gnat_field)
5656 parent_offset
5657 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
5658 bitsizetype);
5659 else
5660 parent_offset = bitsize_int (POINTER_SIZE);
5661 }
5662
5663 Set_Component_Bit_Offset
5664 (gnat_field,
5665 annotate_value
5666 (size_binop (PLUS_EXPR,
5667 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
5668 TREE_VALUE (TREE_VALUE
5669 (TREE_VALUE (gnu_entry)))),
5670 parent_offset)));
5671
5672 Set_Esize (gnat_field,
5673 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
5674 }
5675 else if (type_annotate_only
5676 && Is_Tagged_Type (gnat_entity)
5677 && Is_Derived_Type (gnat_entity))
5678 {
5679 /* If there is no gnu_entry, this is an inherited component whose
5680 position is the same as in the parent type. */
5681 Set_Component_Bit_Offset
5682 (gnat_field,
5683 Component_Bit_Offset (Original_Record_Component (gnat_field)));
5684 Set_Esize (gnat_field,
5685 Esize (Original_Record_Component (gnat_field)));
5686 }
5687 }
5688 }
5689
5690 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
5691 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
5692 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
5693 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
5694 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
5695 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
5696 so far. */
5697
5698 static tree
compute_field_positions(tree gnu_type,tree gnu_list,tree gnu_pos,tree gnu_bitpos,unsigned int offset_align)5699 compute_field_positions (tree gnu_type,
5700 tree gnu_list,
5701 tree gnu_pos,
5702 tree gnu_bitpos,
5703 unsigned int offset_align)
5704 {
5705 tree gnu_field;
5706 tree gnu_result = gnu_list;
5707
5708 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
5709 gnu_field = TREE_CHAIN (gnu_field))
5710 {
5711 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
5712 DECL_FIELD_BIT_OFFSET (gnu_field));
5713 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
5714 DECL_FIELD_OFFSET (gnu_field));
5715 unsigned int our_offset_align
5716 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
5717
5718 gnu_result
5719 = tree_cons (gnu_field,
5720 tree_cons (gnu_our_offset,
5721 tree_cons (size_int (our_offset_align),
5722 gnu_our_bitpos, NULL_TREE),
5723 NULL_TREE),
5724 gnu_result);
5725
5726 if (DECL_INTERNAL_P (gnu_field))
5727 gnu_result
5728 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
5729 gnu_our_offset, gnu_our_bitpos,
5730 our_offset_align);
5731 }
5732
5733 return gnu_result;
5734 }
5735
5736 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
5737 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
5738 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
5739 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
5740 for the size of a field. COMPONENT_P is true if we are being called
5741 to process the Component_Size of GNAT_OBJECT. This is used for error
5742 message handling and to indicate to use the object size of GNU_TYPE.
5743 ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero,
5744 it means that a size of zero should be treated as an unspecified size. */
5745
5746 static tree
validate_size(Uint uint_size,tree gnu_type,Entity_Id gnat_object,enum tree_code kind,int component_p,int zero_ok)5747 validate_size (Uint uint_size,
5748 tree gnu_type,
5749 Entity_Id gnat_object,
5750 enum tree_code kind,
5751 int component_p,
5752 int zero_ok)
5753 {
5754 Node_Id gnat_error_node;
5755 tree type_size
5756 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
5757 tree size;
5758
5759 /* Find the node to use for errors. */
5760 if ((Ekind (gnat_object) == E_Component
5761 || Ekind (gnat_object) == E_Discriminant)
5762 && Present (Component_Clause (gnat_object)))
5763 gnat_error_node = Last_Bit (Component_Clause (gnat_object));
5764 else if (Present (Size_Clause (gnat_object)))
5765 gnat_error_node = Expression (Size_Clause (gnat_object));
5766 else
5767 gnat_error_node = gnat_object;
5768
5769 /* Return 0 if no size was specified, either because Esize was not Present or
5770 the specified size was zero. */
5771 if (No (uint_size) || uint_size == No_Uint)
5772 return 0;
5773
5774 /* Get the size as a tree. Give an error if a size was specified, but cannot
5775 be represented as in sizetype. */
5776 size = UI_To_gnu (uint_size, bitsizetype);
5777 if (TREE_OVERFLOW (size))
5778 {
5779 post_error_ne (component_p ? "component size of & is too large"
5780 : "size of & is too large",
5781 gnat_error_node, gnat_object);
5782 return 0;
5783 }
5784 /* Ignore a negative size since that corresponds to our back-annotation.
5785 Also ignore a zero size unless a size clause exists. */
5786 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok))
5787 return 0;
5788
5789 /* The size of objects is always a multiple of a byte. */
5790 if (kind == VAR_DECL
5791 && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size,
5792 bitsize_unit_node)))
5793 {
5794 if (component_p)
5795 post_error_ne ("component size for& is not a multiple of Storage_Unit",
5796 gnat_error_node, gnat_object);
5797 else
5798 post_error_ne ("size for& is not a multiple of Storage_Unit",
5799 gnat_error_node, gnat_object);
5800 return 0;
5801 }
5802
5803 /* If this is an integral type or a packed array type, the front-end has
5804 verified the size, so we need not do it here (which would entail
5805 checking against the bounds). However, if this is an aliased object, it
5806 may not be smaller than the type of the object. */
5807 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
5808 && ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
5809 return size;
5810
5811 /* If the object is a record that contains a template, add the size of
5812 the template to the specified size. */
5813 if (TREE_CODE (gnu_type) == RECORD_TYPE
5814 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
5815 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
5816
5817 /* Modify the size of the type to be that of the maximum size if it has a
5818 discriminant or the size of a thin pointer if this is a fat pointer. */
5819 if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size))
5820 type_size = max_size (type_size, 1);
5821 else if (TYPE_FAT_POINTER_P (gnu_type))
5822 type_size = bitsize_int (POINTER_SIZE);
5823
5824 /* If the size of the object is a constant, the new size must not be
5825 smaller. */
5826 if (TREE_CODE (type_size) != INTEGER_CST
5827 || TREE_OVERFLOW (type_size)
5828 || tree_int_cst_lt (size, type_size))
5829 {
5830 if (component_p)
5831 post_error_ne_tree
5832 ("component size for& too small{, minimum allowed is ^}",
5833 gnat_error_node, gnat_object, type_size);
5834 else
5835 post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
5836 gnat_error_node, gnat_object, type_size);
5837
5838 if (kind == VAR_DECL && ! component_p
5839 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
5840 && ! tree_int_cst_lt (size, rm_size (gnu_type)))
5841 post_error_ne_tree_2
5842 ("\\size of ^ is not a multiple of alignment (^ bits)",
5843 gnat_error_node, gnat_object, rm_size (gnu_type),
5844 TYPE_ALIGN (gnu_type));
5845
5846 else if (INTEGRAL_TYPE_P (gnu_type))
5847 post_error_ne ("\\size would be legal if & were not aliased!",
5848 gnat_error_node, gnat_object);
5849
5850 return 0;
5851 }
5852
5853 return size;
5854 }
5855
5856 /* Similarly, but both validate and process a value of RM_Size. This
5857 routine is only called for types. */
5858
5859 static void
set_rm_size(Uint uint_size,tree gnu_type,Entity_Id gnat_entity)5860 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
5861 {
5862 /* Only give an error if a Value_Size clause was explicitly given.
5863 Otherwise, we'd be duplicating an error on the Size clause. */
5864 Node_Id gnat_attr_node
5865 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
5866 tree old_size = rm_size (gnu_type);
5867 tree size;
5868
5869 /* Get the size as a tree. Do nothing if none was specified, either
5870 because RM_Size was not Present or if the specified size was zero.
5871 Give an error if a size was specified, but cannot be represented as
5872 in sizetype. */
5873 if (No (uint_size) || uint_size == No_Uint)
5874 return;
5875
5876 size = UI_To_gnu (uint_size, bitsizetype);
5877 if (TREE_OVERFLOW (size))
5878 {
5879 if (Present (gnat_attr_node))
5880 post_error_ne ("Value_Size of & is too large", gnat_attr_node,
5881 gnat_entity);
5882
5883 return;
5884 }
5885
5886 /* Ignore a negative size since that corresponds to our back-annotation.
5887 Also ignore a zero size unless a size clause exists, a Value_Size
5888 clause exists, or this is an integer type, in which case the
5889 front end will have always set it. */
5890 else if (tree_int_cst_sgn (size) < 0
5891 || (integer_zerop (size) && No (gnat_attr_node)
5892 && ! Has_Size_Clause (gnat_entity)
5893 && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
5894 return;
5895
5896 /* If the old size is self-referential, get the maximum size. */
5897 if (CONTAINS_PLACEHOLDER_P (old_size))
5898 old_size = max_size (old_size, 1);
5899
5900 /* If the size of the object is a constant, the new size must not be
5901 smaller (the front end checks this for scalar types). */
5902 if (TREE_CODE (old_size) != INTEGER_CST
5903 || TREE_OVERFLOW (old_size)
5904 || (AGGREGATE_TYPE_P (gnu_type)
5905 && tree_int_cst_lt (size, old_size)))
5906 {
5907 if (Present (gnat_attr_node))
5908 post_error_ne_tree
5909 ("Value_Size for& too small{, minimum allowed is ^}",
5910 gnat_attr_node, gnat_entity, old_size);
5911
5912 return;
5913 }
5914
5915 /* Otherwise, set the RM_Size. */
5916 if (TREE_CODE (gnu_type) == INTEGER_TYPE
5917 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
5918 TYPE_RM_SIZE_INT (gnu_type) = size;
5919 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
5920 SET_TYPE_RM_SIZE_ENUM (gnu_type, size);
5921 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
5922 || TREE_CODE (gnu_type) == UNION_TYPE
5923 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
5924 && ! TYPE_IS_FAT_POINTER_P (gnu_type))
5925 SET_TYPE_ADA_SIZE (gnu_type, size);
5926 }
5927
5928 /* Given a type TYPE, return a new type whose size is appropriate for SIZE.
5929 If TYPE is the best type, return it. Otherwise, make a new type. We
5930 only support new integral and pointer types. BIASED_P is nonzero if
5931 we are making a biased type. */
5932
5933 static tree
make_type_from_size(tree type,tree size_tree,int biased_p)5934 make_type_from_size (tree type, tree size_tree, int biased_p)
5935 {
5936 tree new_type;
5937 unsigned HOST_WIDE_INT size;
5938
5939 /* If size indicates an error, just return TYPE to avoid propagating the
5940 error. Likewise if it's too large to represent. */
5941 if (size_tree == 0 || ! host_integerp (size_tree, 1))
5942 return type;
5943
5944 size = tree_low_cst (size_tree, 1);
5945 switch (TREE_CODE (type))
5946 {
5947 case INTEGER_TYPE:
5948 case ENUMERAL_TYPE:
5949 /* Only do something if the type is not already the proper size and is
5950 not a packed array type. */
5951 if (TYPE_PACKED_ARRAY_TYPE_P (type)
5952 || (TYPE_PRECISION (type) == size
5953 && biased_p == (TREE_CODE (type) == INTEGER_CST
5954 && TYPE_BIASED_REPRESENTATION_P (type))))
5955 break;
5956
5957 size = MIN (size, LONG_LONG_TYPE_SIZE);
5958 new_type = make_signed_type (size);
5959 TREE_TYPE (new_type)
5960 = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type;
5961 TYPE_MIN_VALUE (new_type)
5962 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
5963 TYPE_MAX_VALUE (new_type)
5964 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
5965 TYPE_BIASED_REPRESENTATION_P (new_type)
5966 = ((TREE_CODE (type) == INTEGER_TYPE
5967 && TYPE_BIASED_REPRESENTATION_P (type))
5968 || biased_p);
5969 TREE_UNSIGNED (new_type)
5970 = TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type);
5971 TYPE_RM_SIZE_INT (new_type) = bitsize_int (size);
5972 return new_type;
5973
5974 case RECORD_TYPE:
5975 /* Do something if this is a fat pointer, in which case we
5976 may need to return the thin pointer. */
5977 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
5978 return
5979 build_pointer_type
5980 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
5981 break;
5982
5983 case POINTER_TYPE:
5984 /* Only do something if this is a thin pointer, in which case we
5985 may need to return the fat pointer. */
5986 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
5987 return
5988 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
5989
5990 break;
5991
5992 default:
5993 break;
5994 }
5995
5996 return type;
5997 }
5998
5999 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
6000 a type or object whose present alignment is ALIGN. If this alignment is
6001 valid, return it. Otherwise, give an error and return ALIGN. */
6002
6003 static unsigned int
validate_alignment(Uint alignment,Entity_Id gnat_entity,unsigned int align)6004 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
6005 {
6006 Node_Id gnat_error_node = gnat_entity;
6007 unsigned int new_align;
6008
6009 #ifndef MAX_OFILE_ALIGNMENT
6010 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
6011 #endif
6012
6013 if (Present (Alignment_Clause (gnat_entity)))
6014 gnat_error_node = Expression (Alignment_Clause (gnat_entity));
6015
6016 /* Don't worry about checking alignment if alignment was not specified
6017 by the source program and we already posted an error for this entity. */
6018
6019 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
6020 return align;
6021
6022 /* Within GCC, an alignment is an integer, so we must make sure a
6023 value is specified that fits in that range. Also, alignments of
6024 more than MAX_OFILE_ALIGNMENT can't be supported. */
6025
6026 if (! UI_Is_In_Int_Range (alignment)
6027 || ((new_align = UI_To_Int (alignment))
6028 > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT))
6029 post_error_ne_num ("largest supported alignment for& is ^",
6030 gnat_error_node, gnat_entity,
6031 MAX_OFILE_ALIGNMENT / BITS_PER_UNIT);
6032 else if (! (Present (Alignment_Clause (gnat_entity))
6033 && From_At_Mod (Alignment_Clause (gnat_entity)))
6034 && new_align * BITS_PER_UNIT < align)
6035 post_error_ne_num ("alignment for& must be at least ^",
6036 gnat_error_node, gnat_entity,
6037 align / BITS_PER_UNIT);
6038 else
6039 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
6040
6041 return align;
6042 }
6043
6044 /* Verify that OBJECT, a type or decl, is something we can implement
6045 atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero
6046 if we require atomic components. */
6047
6048 static void
check_ok_for_atomic(tree object,Entity_Id gnat_entity,int comp_p)6049 check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p)
6050 {
6051 Node_Id gnat_error_point = gnat_entity;
6052 Node_Id gnat_node;
6053 enum machine_mode mode;
6054 unsigned int align;
6055 tree size;
6056
6057 /* There are three case of what OBJECT can be. It can be a type, in which
6058 case we take the size, alignment and mode from the type. It can be a
6059 declaration that was indirect, in which case the relevant values are
6060 that of the type being pointed to, or it can be a normal declaration,
6061 in which case the values are of the decl. The code below assumes that
6062 OBJECT is either a type or a decl. */
6063 if (TYPE_P (object))
6064 {
6065 mode = TYPE_MODE (object);
6066 align = TYPE_ALIGN (object);
6067 size = TYPE_SIZE (object);
6068 }
6069 else if (DECL_BY_REF_P (object))
6070 {
6071 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
6072 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
6073 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
6074 }
6075 else
6076 {
6077 mode = DECL_MODE (object);
6078 align = DECL_ALIGN (object);
6079 size = DECL_SIZE (object);
6080 }
6081
6082 /* Consider all floating-point types atomic and any types that that are
6083 represented by integers no wider than a machine word. */
6084 if (GET_MODE_CLASS (mode) == MODE_FLOAT
6085 || ((GET_MODE_CLASS (mode) == MODE_INT
6086 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
6087 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
6088 return;
6089
6090 /* For the moment, also allow anything that has an alignment equal
6091 to its size and which is smaller than a word. */
6092 if (size != 0 && TREE_CODE (size) == INTEGER_CST
6093 && compare_tree_int (size, align) == 0
6094 && align <= BITS_PER_WORD)
6095 return;
6096
6097 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
6098 gnat_node = Next_Rep_Item (gnat_node))
6099 {
6100 if (! comp_p && Nkind (gnat_node) == N_Pragma
6101 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
6102 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6103 else if (comp_p && Nkind (gnat_node) == N_Pragma
6104 && (Get_Pragma_Id (Chars (gnat_node))
6105 == Pragma_Atomic_Components))
6106 gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
6107 }
6108
6109 if (comp_p)
6110 post_error_ne ("atomic access to component of & cannot be guaranteed",
6111 gnat_error_point, gnat_entity);
6112 else
6113 post_error_ne ("atomic access to & cannot be guaranteed",
6114 gnat_error_point, gnat_entity);
6115 }
6116
6117 /* Given a type T, a FIELD_DECL F, and a replacement value R,
6118 return a new type with all size expressions that contain F
6119 updated by replacing F with R. This is identical to GCC's
6120 substitute_in_type except that it knows about TYPE_INDEX_TYPE.
6121 If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has
6122 changed. */
6123
6124 tree
gnat_substitute_in_type(tree t,tree f,tree r)6125 gnat_substitute_in_type (tree t, tree f, tree r)
6126 {
6127 tree new = t;
6128 tree tem;
6129
6130 switch (TREE_CODE (t))
6131 {
6132 case INTEGER_TYPE:
6133 case ENUMERAL_TYPE:
6134 case BOOLEAN_TYPE:
6135 case CHAR_TYPE:
6136 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
6137 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
6138 {
6139 tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6140 tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6141
6142 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6143 return t;
6144
6145 new = build_range_type (TREE_TYPE (t), low, high);
6146 if (TYPE_INDEX_TYPE (t))
6147 SET_TYPE_INDEX_TYPE (new,
6148 gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
6149 return new;
6150 }
6151
6152 return t;
6153
6154 case REAL_TYPE:
6155 if ((TYPE_MIN_VALUE (t) != 0
6156 && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)))
6157 || (TYPE_MAX_VALUE (t) != 0
6158 && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))))
6159 {
6160 tree low = 0, high = 0;
6161
6162 if (TYPE_MIN_VALUE (t))
6163 low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
6164 if (TYPE_MAX_VALUE (t))
6165 high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
6166
6167 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
6168 return t;
6169
6170 t = copy_type (t);
6171 TYPE_MIN_VALUE (t) = low;
6172 TYPE_MAX_VALUE (t) = high;
6173 }
6174 return t;
6175
6176 case COMPLEX_TYPE:
6177 tem = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6178 if (tem == TREE_TYPE (t))
6179 return t;
6180
6181 return build_complex_type (tem);
6182
6183 case OFFSET_TYPE:
6184 case METHOD_TYPE:
6185 case FILE_TYPE:
6186 case SET_TYPE:
6187 case FUNCTION_TYPE:
6188 case LANG_TYPE:
6189 /* Don't know how to do these yet. */
6190 abort ();
6191
6192 case ARRAY_TYPE:
6193 {
6194 tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r);
6195 tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r);
6196
6197 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
6198 return t;
6199
6200 new = build_array_type (component, domain);
6201 TYPE_SIZE (new) = 0;
6202 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
6203 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
6204 layout_type (new);
6205 TYPE_ALIGN (new) = TYPE_ALIGN (t);
6206 return new;
6207 }
6208
6209 case RECORD_TYPE:
6210 case UNION_TYPE:
6211 case QUAL_UNION_TYPE:
6212 {
6213 tree field;
6214 int changed_field
6215 = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t)));
6216 int field_has_rep = 0;
6217 tree last_field = 0;
6218
6219 tree new = copy_type (t);
6220
6221 /* Start out with no fields, make new fields, and chain them
6222 in. If we haven't actually changed the type of any field,
6223 discard everything we've done and return the old type. */
6224
6225 TYPE_FIELDS (new) = 0;
6226 TYPE_SIZE (new) = 0;
6227
6228 for (field = TYPE_FIELDS (t); field;
6229 field = TREE_CHAIN (field))
6230 {
6231 tree new_field = copy_node (field);
6232
6233 TREE_TYPE (new_field)
6234 = gnat_substitute_in_type (TREE_TYPE (new_field), f, r);
6235
6236 if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field))
6237 field_has_rep = 1;
6238 else if (TREE_TYPE (new_field) != TREE_TYPE (field))
6239 changed_field = 1;
6240
6241 /* If this is an internal field and the type of this field is
6242 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
6243 the type just has one element, treat that as the field.
6244 But don't do this if we are processing a QUAL_UNION_TYPE. */
6245 if (TREE_CODE (t) != QUAL_UNION_TYPE
6246 && DECL_INTERNAL_P (new_field)
6247 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
6248 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
6249 {
6250 if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0)
6251 continue;
6252
6253 if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0)
6254 {
6255 tree next_new_field
6256 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
6257
6258 /* Make sure omitting the union doesn't change
6259 the layout. */
6260 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
6261 new_field = next_new_field;
6262 }
6263 }
6264
6265 DECL_CONTEXT (new_field) = new;
6266 SET_DECL_ORIGINAL_FIELD (new_field,
6267 (DECL_ORIGINAL_FIELD (field) != 0
6268 ? DECL_ORIGINAL_FIELD (field) : field));
6269
6270 /* If the size of the old field was set at a constant,
6271 propagate the size in case the type's size was variable.
6272 (This occurs in the case of a variant or discriminated
6273 record with a default size used as a field of another
6274 record.) */
6275 DECL_SIZE (new_field)
6276 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
6277 ? DECL_SIZE (field) : 0;
6278 DECL_SIZE_UNIT (new_field)
6279 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
6280 ? DECL_SIZE_UNIT (field) : 0;
6281
6282 if (TREE_CODE (t) == QUAL_UNION_TYPE)
6283 {
6284 tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r);
6285
6286 if (new_q != DECL_QUALIFIER (new_field))
6287 changed_field = 1;
6288
6289 /* Do the substitution inside the qualifier and if we find
6290 that this field will not be present, omit it. */
6291 DECL_QUALIFIER (new_field) = new_q;
6292
6293 if (integer_zerop (DECL_QUALIFIER (new_field)))
6294 continue;
6295 }
6296
6297 if (last_field == 0)
6298 TYPE_FIELDS (new) = new_field;
6299 else
6300 TREE_CHAIN (last_field) = new_field;
6301
6302 last_field = new_field;
6303
6304 /* If this is a qualified type and this field will always be
6305 present, we are done. */
6306 if (TREE_CODE (t) == QUAL_UNION_TYPE
6307 && integer_onep (DECL_QUALIFIER (new_field)))
6308 break;
6309 }
6310
6311 /* If this used to be a qualified union type, but we now know what
6312 field will be present, make this a normal union. */
6313 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
6314 && (TYPE_FIELDS (new) == 0
6315 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
6316 TREE_SET_CODE (new, UNION_TYPE);
6317 else if (! changed_field)
6318 return t;
6319
6320 if (field_has_rep)
6321 gigi_abort (117);
6322
6323 layout_type (new);
6324
6325 /* If the size was originally a constant use it. */
6326 if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
6327 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
6328 {
6329 TYPE_SIZE (new) = TYPE_SIZE (t);
6330 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
6331 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
6332 }
6333
6334 return new;
6335 }
6336
6337 default:
6338 return t;
6339 }
6340 }
6341
6342 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits
6343 needed to represent the object. */
6344
6345 tree
rm_size(tree gnu_type)6346 rm_size (tree gnu_type)
6347 {
6348 /* For integer types, this is the precision. For record types, we store
6349 the size explicitly. For other types, this is just the size. */
6350
6351 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0)
6352 return TYPE_RM_SIZE (gnu_type);
6353 else if (TREE_CODE (gnu_type) == RECORD_TYPE
6354 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
6355 /* Return the rm_size of the actual data plus the size of the template. */
6356 return
6357 size_binop (PLUS_EXPR,
6358 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
6359 DECL_SIZE (TYPE_FIELDS (gnu_type)));
6360 else if ((TREE_CODE (gnu_type) == RECORD_TYPE
6361 || TREE_CODE (gnu_type) == UNION_TYPE
6362 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
6363 && ! TYPE_IS_FAT_POINTER_P (gnu_type)
6364 && TYPE_ADA_SIZE (gnu_type) != 0)
6365 return TYPE_ADA_SIZE (gnu_type);
6366 else
6367 return TYPE_SIZE (gnu_type);
6368 }
6369
6370 /* Return an identifier representing the external name to be used for
6371 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
6372 and the specified suffix. */
6373
6374 tree
create_concat_name(Entity_Id gnat_entity,const char * suffix)6375 create_concat_name (Entity_Id gnat_entity, const char *suffix)
6376 {
6377 const char *str = (suffix == 0 ? "" : suffix);
6378 String_Template temp = {1, strlen (str)};
6379 Fat_Pointer fp = {str, &temp};
6380
6381 Get_External_Name_With_Suffix (gnat_entity, fp);
6382
6383 #ifdef _WIN32
6384 /* A variable using the Stdcall convention (meaning we are running
6385 on a Windows box) live in a DLL. Here we adjust its name to use
6386 the jump-table, the _imp__NAME contains the address for the NAME
6387 variable. */
6388
6389 {
6390 Entity_Kind kind = Ekind (gnat_entity);
6391 const char *prefix = "_imp__";
6392 int plen = strlen (prefix);
6393
6394 if ((kind == E_Variable || kind == E_Constant)
6395 && Convention (gnat_entity) == Convention_Stdcall)
6396 {
6397 int k;
6398 for (k = 0; k <= Name_Len; k++)
6399 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
6400 strncpy (Name_Buffer, prefix, plen);
6401 }
6402 }
6403 #endif
6404
6405 return get_identifier (Name_Buffer);
6406 }
6407
6408 /* Return the name to be used for GNAT_ENTITY. If a type, create a
6409 fully-qualified name, possibly with type information encoding.
6410 Otherwise, return the name. */
6411
6412 tree
get_entity_name(Entity_Id gnat_entity)6413 get_entity_name (Entity_Id gnat_entity)
6414 {
6415 Get_Encoded_Name (gnat_entity);
6416 return get_identifier (Name_Buffer);
6417 }
6418
6419 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
6420 string, return a new IDENTIFIER_NODE that is the concatenation of
6421 the name in GNU_ID and SUFFIX. */
6422
6423 tree
concat_id_with_name(tree gnu_id,const char * suffix)6424 concat_id_with_name (tree gnu_id, const char *suffix)
6425 {
6426 int len = IDENTIFIER_LENGTH (gnu_id);
6427
6428 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
6429 IDENTIFIER_LENGTH (gnu_id));
6430 strncpy (Name_Buffer + len, "___", 3);
6431 len += 3;
6432 strcpy (Name_Buffer + len, suffix);
6433 return get_identifier (Name_Buffer);
6434 }
6435
6436 #include "gt-ada-decl.h"
6437