1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2003, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
54 #ifndef MAX_FIXED_MODE_SIZE
55 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
58 #ifndef MAX_BITS_PER_WORD
59 #define MAX_BITS_PER_WORD BITS_PER_WORD
62 /* If nonzero, pretend we are allocating at global level. */
65 /* Tree nodes for the various types and decls we create. */
66 tree gnat_std_decls
[(int) ADT_LAST
];
68 /* Functions to call for each of the possible raise reasons. */
69 tree gnat_raise_decls
[(int) LAST_REASON_CODE
+ 1];
71 /* Associates a GNAT tree node to a GCC tree node. It is used in
72 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
73 of `save_gnu_tree' for more info. */
74 static GTY((length ("max_gnat_nodes"))) tree
*associate_gnat_to_gnu
;
76 /* This listhead is used to record any global objects that need elaboration.
77 TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
78 initial value to assign. */
80 static GTY(()) tree pending_elaborations
;
82 /* This stack allows us to momentarily switch to generating elaboration
83 lists for an inner context. */
85 struct e_stack
GTY(()) {
89 static GTY(()) struct e_stack
*elist_stack
;
91 /* This variable keeps a table for types for each precision so that we only
92 allocate each of them once. Signed and unsigned types are kept separate.
94 Note that these types are only used when fold-const requests something
95 special. Perhaps we should NOT share these types; we'll see how it
97 static GTY(()) tree signed_and_unsigned_types
[2 * MAX_BITS_PER_WORD
+ 1][2];
99 /* Likewise for float types, but record these by mode. */
100 static GTY(()) tree float_types
[NUM_MACHINE_MODES
];
102 /* For each binding contour we allocate a binding_level structure which records
103 the entities defined or declared in that contour. Contours include:
106 one for each subprogram definition
107 one for each compound statement (declare block)
109 Binding contours are used to create GCC tree BLOCK nodes. */
111 struct binding_level
GTY(())
113 /* A chain of ..._DECL nodes for all variables, constants, functions,
114 parameters and type declarations. These ..._DECL nodes are chained
115 through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
116 in the reverse of the order supplied to be compatible with the
119 /* For each level (except the global one), a chain of BLOCK nodes for all
120 the levels that were entered and exited one level down from this one. */
122 /* The BLOCK node for this level, if one has been preallocated.
123 If 0, the BLOCK is allocated (if needed) when the level is popped. */
125 /* The binding level containing this one (the enclosing binding level). */
126 struct binding_level
*level_chain
;
129 /* The binding level currently in effect. */
130 static GTY(()) struct binding_level
*current_binding_level
;
132 /* A chain of binding_level structures awaiting reuse. */
133 static GTY((deletable (""))) struct binding_level
*free_binding_level
;
135 /* The outermost binding level. This binding level is created when the
136 compiler is started and it will exist through the entire compilation. */
137 static struct binding_level
*global_binding_level
;
139 /* Binding level structures are initialized by copying this one. */
140 static struct binding_level clear_binding_level
= {NULL
, NULL
, NULL
, NULL
};
142 struct language_function
GTY(())
147 static tree merge_sizes
PARAMS ((tree
, tree
, tree
, int, int));
148 static tree compute_related_constant
PARAMS ((tree
, tree
));
149 static tree split_plus
PARAMS ((tree
, tree
*));
150 static int value_zerop
PARAMS ((tree
));
151 static tree float_type_for_size
PARAMS ((int, enum machine_mode
));
152 static tree convert_to_fat_pointer
PARAMS ((tree
, tree
));
153 static tree convert_to_thin_pointer
PARAMS ((tree
, tree
));
154 static tree make_descriptor_field
PARAMS ((const char *,tree
, tree
,
156 static int value_factor_p
PARAMS ((tree
, int));
157 static int potential_alignment_gap
PARAMS ((tree
, tree
, tree
));
159 /* Initialize the association of GNAT nodes to GCC trees. */
164 associate_gnat_to_gnu
165 = (tree
*) ggc_alloc_cleared (max_gnat_nodes
* sizeof (tree
));
167 pending_elaborations
= build_tree_list (NULL_TREE
, NULL_TREE
);
170 /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
171 which is to be associated with GNAT_ENTITY. Such GCC tree node is always
172 a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
174 If GNU_DECL is zero, a previous association is to be reset. */
177 save_gnu_tree (gnat_entity
, gnu_decl
, no_check
)
178 Entity_Id gnat_entity
;
182 /* Check that GNAT_ENTITY is not already defined and that it is being set
183 to something which is a decl. Raise gigi 401 if not. Usually, this
184 means GNAT_ENTITY is defined twice, but occasionally is due to some
187 && (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]
188 || (! no_check
&& ! DECL_P (gnu_decl
))))
191 associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] = gnu_decl
;
194 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
195 Return the ..._DECL node that was associated with it. If there is no tree
196 node associated with GNAT_ENTITY, abort.
198 In some cases, such as delayed elaboration or expressions that need to
199 be elaborated only once, GNAT_ENTITY is really not an entity. */
202 get_gnu_tree (gnat_entity
)
203 Entity_Id gnat_entity
;
205 if (! associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
])
208 return associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
];
211 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
214 present_gnu_tree (gnat_entity
)
215 Entity_Id gnat_entity
;
217 return (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] != NULL_TREE
);
221 /* Return non-zero if we are currently in the global binding level. */
226 return (force_global
!= 0 || current_binding_level
== global_binding_level
230 /* Return the list of declarations in the current level. Note that this list
231 is in reverse order (it has to be so for back-end compatibility). */
236 return current_binding_level
->names
;
239 /* Nonzero if the current level needs to have a BLOCK made. */
244 return (current_binding_level
->names
!= 0);
247 /* Enter a new binding level. The input parameter is ignored, but has to be
248 specified for back-end compatibility. */
252 int ignore ATTRIBUTE_UNUSED
;
254 struct binding_level
*newlevel
= NULL
;
256 /* Reuse a struct for this binding level, if there is one. */
257 if (free_binding_level
)
259 newlevel
= free_binding_level
;
260 free_binding_level
= free_binding_level
->level_chain
;
264 = (struct binding_level
*) ggc_alloc (sizeof (struct binding_level
));
266 *newlevel
= clear_binding_level
;
268 /* Add this level to the front of the chain (stack) of levels that are
270 newlevel
->level_chain
= current_binding_level
;
271 current_binding_level
= newlevel
;
274 /* Exit a binding level.
275 Pop the level off, and restore the state of the identifier-decl mappings
276 that were in effect when this level was entered.
278 If KEEP is nonzero, this level had explicit declarations, so
279 and create a "block" (a BLOCK node) for the level
280 to record its declarations and subblocks for symbol table output.
282 If FUNCTIONBODY is nonzero, this level is the body of a function,
283 so create a block as if KEEP were set and also clear out all
286 If REVERSE is nonzero, reverse the order of decls before putting
287 them into the BLOCK. */
290 poplevel (keep
, reverse
, functionbody
)
295 /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
296 binding level that we are about to exit and which is returned by this
298 tree block
= NULL_TREE
;
301 tree subblock_chain
= current_binding_level
->blocks
;
303 int block_previously_created
;
305 /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL
306 nodes chained through the `names' field of current_binding_level are in
307 reverse order except for PARM_DECL node, which are explicitly stored in
309 current_binding_level
->names
310 = decl_chain
= (reverse
) ? nreverse (current_binding_level
->names
)
311 : current_binding_level
->names
;
313 /* Output any nested inline functions within this block which must be
314 compiled because their address is needed. */
315 for (decl_node
= decl_chain
; decl_node
; decl_node
= TREE_CHAIN (decl_node
))
316 if (TREE_CODE (decl_node
) == FUNCTION_DECL
317 && ! TREE_ASM_WRITTEN (decl_node
) && TREE_ADDRESSABLE (decl_node
)
318 && DECL_INITIAL (decl_node
) != 0)
320 push_function_context ();
321 output_inline_function (decl_node
);
322 pop_function_context ();
326 block_previously_created
= (current_binding_level
->this_block
!= 0);
327 if (block_previously_created
)
328 block
= current_binding_level
->this_block
;
329 else if (keep
|| functionbody
)
330 block
= make_node (BLOCK
);
333 BLOCK_VARS (block
) = keep
? decl_chain
: 0;
334 BLOCK_SUBBLOCKS (block
) = subblock_chain
;
337 /* Record the BLOCK node just built as the subblock its enclosing scope. */
338 for (subblock_node
= subblock_chain
; subblock_node
;
339 subblock_node
= TREE_CHAIN (subblock_node
))
340 BLOCK_SUPERCONTEXT (subblock_node
) = block
;
342 /* Clear out the meanings of the local variables of this level. */
344 for (subblock_node
= decl_chain
; subblock_node
;
345 subblock_node
= TREE_CHAIN (subblock_node
))
346 if (DECL_NAME (subblock_node
) != 0)
347 /* If the identifier was used or addressed via a local extern decl,
348 don't forget that fact. */
349 if (DECL_EXTERNAL (subblock_node
))
351 if (TREE_USED (subblock_node
))
352 TREE_USED (DECL_NAME (subblock_node
)) = 1;
353 if (TREE_ADDRESSABLE (subblock_node
))
354 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node
)) = 1;
358 /* Pop the current level, and free the structure for reuse. */
359 struct binding_level
*level
= current_binding_level
;
360 current_binding_level
= current_binding_level
->level_chain
;
361 level
->level_chain
= free_binding_level
;
362 free_binding_level
= level
;
367 /* This is the top level block of a function. The ..._DECL chain stored
368 in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
369 leave them in the BLOCK because they are found in the FUNCTION_DECL
371 DECL_INITIAL (current_function_decl
) = block
;
372 BLOCK_VARS (block
) = 0;
376 if (!block_previously_created
)
377 current_binding_level
->blocks
378 = chainon (current_binding_level
->blocks
, block
);
381 /* If we did not make a block for the level just exited, any blocks made for
382 inner levels (since they cannot be recorded as subblocks in that level)
383 must be carried forward so they will later become subblocks of something
385 else if (subblock_chain
)
386 current_binding_level
->blocks
387 = chainon (current_binding_level
->blocks
, subblock_chain
);
389 TREE_USED (block
) = 1;
394 /* Insert BLOCK at the end of the list of subblocks of the
395 current binding level. This is used when a BIND_EXPR is expanded,
396 to handle the BLOCK node inside the BIND_EXPR. */
402 TREE_USED (block
) = 1;
403 current_binding_level
->blocks
404 = chainon (current_binding_level
->blocks
, block
);
407 /* Set the BLOCK node for the innermost scope
408 (the one we are currently in). */
414 current_binding_level
->this_block
= block
;
415 current_binding_level
->names
= chainon (current_binding_level
->names
,
417 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
418 BLOCK_SUBBLOCKS (block
));
421 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
422 Returns the ..._DECL node. */
428 struct binding_level
*b
;
430 /* If at top level, there is no context. But PARM_DECLs always go in the
431 level of its function. */
432 if (global_bindings_p () && TREE_CODE (decl
) != PARM_DECL
)
434 b
= global_binding_level
;
435 DECL_CONTEXT (decl
) = 0;
439 b
= current_binding_level
;
440 DECL_CONTEXT (decl
) = current_function_decl
;
443 /* Put the declaration on the list. The list of declarations is in reverse
444 order. The list will be reversed later if necessary. This needs to be
445 this way for compatibility with the back-end.
447 Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They
448 will cause trouble with the debugger and aren't needed anyway. */
449 if (TREE_CODE (decl
) != TYPE_DECL
450 || TREE_CODE (TREE_TYPE (decl
)) != UNCONSTRAINED_ARRAY_TYPE
)
452 TREE_CHAIN (decl
) = b
->names
;
456 /* For the declaration of a type, set its name if it either is not already
457 set, was set to an IDENTIFIER_NODE, indicating an internal name,
458 or if the previous type name was not derived from a source name.
459 We'd rather have the type named with a real name and all the pointer
460 types to the same object have the same POINTER_TYPE node. Code in this
461 function in c-decl.c makes a copy of the type node here, but that may
462 cause us trouble with incomplete types, so let's not try it (at least
465 if (TREE_CODE (decl
) == TYPE_DECL
466 && DECL_NAME (decl
) != 0
467 && (TYPE_NAME (TREE_TYPE (decl
)) == 0
468 || TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == IDENTIFIER_NODE
469 || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == TYPE_DECL
470 && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl
)))
471 && ! DECL_ARTIFICIAL (decl
))))
472 TYPE_NAME (TREE_TYPE (decl
)) = decl
;
477 /* Do little here. Set up the standard declarations later after the
478 front end has been run. */
481 gnat_init_decl_processing ()
485 /* Make the binding_level structure for global names. */
486 current_function_decl
= 0;
487 current_binding_level
= 0;
488 free_binding_level
= 0;
490 global_binding_level
= current_binding_level
;
492 build_common_tree_nodes (0);
494 /* In Ada, we use a signed type for SIZETYPE. Use the signed type
495 corresponding to the size of Pmode. In most cases when ptr_mode and
496 Pmode differ, C will use the width of ptr_mode as sizetype. But we get
497 far better code using the width of Pmode. Make this here since we need
498 this before we can expand the GNAT types. */
499 set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (Pmode
), 0));
500 build_common_tree_nodes_2 (0);
502 pushdecl (build_decl (TYPE_DECL
, get_identifier (SIZE_TYPE
), sizetype
));
504 /* We need to make the integer type before doing anything else.
505 We stitch this in to the appropriate GNAT type later. */
506 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
508 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
511 ptr_void_type_node
= build_pointer_type (void_type_node
);
515 /* Create the predefined scalar types such as `integer_type_node' needed
516 in the gcc back-end and initialize the global binding level. */
519 init_gigi_decls (long_long_float_type
, exception_type
)
520 tree long_long_float_type
, exception_type
;
525 /* Set the types that GCC and Gigi use from the front end. We would like
526 to do this for char_type_node, but it needs to correspond to the C
528 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
530 /* In this case, the builtin floating point types are VAX float,
531 so make up a type for use. */
532 longest_float_type_node
= make_node (REAL_TYPE
);
533 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
534 layout_type (longest_float_type_node
);
535 pushdecl (build_decl (TYPE_DECL
, get_identifier ("longest float type"),
536 longest_float_type_node
));
539 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
541 except_type_node
= TREE_TYPE (exception_type
);
543 unsigned_type_node
= gnat_type_for_size (INT_TYPE_SIZE
, 1);
544 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
545 unsigned_type_node
));
548 = pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
551 void_ftype
= build_function_type (void_type_node
, NULL_TREE
);
552 ptr_void_ftype
= build_pointer_type (void_ftype
);
554 /* Now declare runtime functions. */
555 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
557 /* malloc is a function declaration tree for a function to allocate
559 malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"),
561 build_function_type (ptr_void_type_node
,
562 tree_cons (NULL_TREE
,
565 NULL_TREE
, 0, 1, 1, 0);
567 /* free is a function declaration tree for a function to free memory. */
569 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
570 build_function_type (void_type_node
,
571 tree_cons (NULL_TREE
,
574 NULL_TREE
, 0, 1, 1, 0);
576 /* Make the types and functions used for exception processing. */
578 = build_array_type (gnat_type_for_mode (Pmode
, 0),
579 build_index_type (build_int_2 (5, 0)));
580 pushdecl (build_decl (TYPE_DECL
, get_identifier ("JMPBUF_T"), jmpbuf_type
));
581 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
583 /* Functions to get and set the jumpbuf pointer for the current thread. */
585 = create_subprog_decl
586 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
587 NULL_TREE
, build_function_type (jmpbuf_ptr_type
, NULL_TREE
),
588 NULL_TREE
, 0, 1, 1, 0);
591 = create_subprog_decl
592 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
594 build_function_type (void_type_node
,
595 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
596 NULL_TREE
, 0, 1, 1, 0);
598 /* Function to get the current exception. */
600 = create_subprog_decl
601 (get_identifier ("system__soft_links__get_gnat_exception"),
603 build_function_type (build_pointer_type (except_type_node
), NULL_TREE
),
604 NULL_TREE
, 0, 1, 1, 0);
606 /* Functions that raise exceptions. */
608 = create_subprog_decl
609 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
610 build_function_type (void_type_node
,
611 tree_cons (NULL_TREE
,
612 build_pointer_type (except_type_node
),
614 NULL_TREE
, 0, 1, 1, 0);
616 /* Hooks to call when entering/leaving an exception handler. */
618 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
619 build_function_type (void_type_node
,
620 tree_cons (NULL_TREE
,
623 NULL_TREE
, 0, 1, 1, 0);
626 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
627 build_function_type (void_type_node
,
628 tree_cons (NULL_TREE
,
631 NULL_TREE
, 0, 1, 1, 0);
633 /* If in no exception handlers mode, all raise statements are redirected to
634 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
635 this procedure will never be called in this mode. */
636 if (No_Exception_Handlers_Set ())
639 = create_subprog_decl
640 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
641 build_function_type (void_type_node
,
642 tree_cons (NULL_TREE
,
643 build_pointer_type (char_type_node
),
644 tree_cons (NULL_TREE
,
647 NULL_TREE
, 0, 1, 1, 0);
649 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
650 gnat_raise_decls
[i
] = decl
;
653 /* Otherwise, make one decl for each exception reason. */
654 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
658 sprintf (name
, "__gnat_rcheck_%.2d", i
);
660 = create_subprog_decl
661 (get_identifier (name
), NULL_TREE
,
662 build_function_type (void_type_node
,
663 tree_cons (NULL_TREE
,
666 tree_cons (NULL_TREE
,
669 NULL_TREE
, 0, 1, 1, 0);
672 /* Indicate that these never return. */
673 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
674 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
675 TREE_TYPE (raise_nodefer_decl
)
676 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
679 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
681 TREE_THIS_VOLATILE (gnat_raise_decls
[i
]) = 1;
682 TREE_SIDE_EFFECTS (gnat_raise_decls
[i
]) = 1;
683 TREE_TYPE (gnat_raise_decls
[i
])
684 = build_qualified_type (TREE_TYPE (gnat_raise_decls
[i
]),
688 /* setjmp returns an integer and has one operand, which is a pointer to
691 = create_subprog_decl
692 (get_identifier ("setjmp"), NULL_TREE
,
693 build_function_type (integer_type_node
,
694 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
695 NULL_TREE
, 0, 1, 1, 0);
697 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
698 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
700 main_identifier_node
= get_identifier ("main");
703 /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
704 nodes (FIELDLIST), finish constructing the record or union type.
705 If HAS_REP is nonzero, this record has a rep clause; don't call
706 layout_type but merely set the size and alignment ourselves.
707 If DEFER_DEBUG is nonzero, do not call the debugging routines
708 on this type; it will be done later. */
711 finish_record_type (record_type
, fieldlist
, has_rep
, defer_debug
)
717 enum tree_code code
= TREE_CODE (record_type
);
718 tree ada_size
= bitsize_zero_node
;
719 tree size
= bitsize_zero_node
;
720 tree size_unit
= size_zero_node
;
724 TYPE_FIELDS (record_type
) = fieldlist
;
726 if (TYPE_NAME (record_type
) != 0
727 && TREE_CODE (TYPE_NAME (record_type
)) == TYPE_DECL
)
728 TYPE_STUB_DECL (record_type
) = TYPE_NAME (record_type
);
730 TYPE_STUB_DECL (record_type
)
731 = pushdecl (build_decl (TYPE_DECL
, TYPE_NAME (record_type
),
734 /* We don't need both the typedef name and the record name output in
735 the debugging information, since they are the same. */
736 DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type
)) = 1;
738 /* Globally initialize the record first. If this is a rep'ed record,
739 that just means some initializations; otherwise, layout the record. */
743 TYPE_ALIGN (record_type
) = MAX (BITS_PER_UNIT
, TYPE_ALIGN (record_type
));
744 TYPE_MODE (record_type
) = BLKmode
;
745 if (TYPE_SIZE (record_type
) == 0)
747 TYPE_SIZE (record_type
) = bitsize_zero_node
;
748 TYPE_SIZE_UNIT (record_type
) = size_zero_node
;
750 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
751 out just like a UNION_TYPE, since the size will be fixed. */
752 else if (code
== QUAL_UNION_TYPE
)
757 /* Ensure there isn't a size already set. There can be in an error
758 case where there is a rep clause but all fields have errors and
759 no longer have a position. */
760 TYPE_SIZE (record_type
) = 0;
761 layout_type (record_type
);
764 /* At this point, the position and size of each field is known. It was
765 either set before entry by a rep clause, or by laying out the type
766 above. We now make a pass through the fields (in reverse order for
767 QUAL_UNION_TYPEs) to compute the Ada size; the GCC size and alignment
768 (for rep'ed records that are not padding types); and the mode (for
771 if (code
== QUAL_UNION_TYPE
)
772 fieldlist
= nreverse (fieldlist
);
774 for (field
= fieldlist
; field
; field
= TREE_CHAIN (field
))
776 tree type
= TREE_TYPE (field
);
777 tree this_size
= DECL_SIZE (field
);
778 tree this_size_unit
= DECL_SIZE_UNIT (field
);
779 tree this_ada_size
= DECL_SIZE (field
);
781 /* We need to make an XVE/XVU record if any field has variable size,
782 whether or not the record does. For example, if we have an union,
783 it may be that all fields, rounded up to the alignment, have the
784 same size, in which case we'll use that size. But the debug
785 output routines (except Dwarf2) won't be able to output the fields,
786 so we need to make the special record. */
787 if (TREE_CODE (this_size
) != INTEGER_CST
)
790 if ((TREE_CODE (type
) == RECORD_TYPE
|| TREE_CODE (type
) == UNION_TYPE
791 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
792 && ! TYPE_IS_FAT_POINTER_P (type
)
793 && ! TYPE_CONTAINS_TEMPLATE_P (type
)
794 && TYPE_ADA_SIZE (type
) != 0)
795 this_ada_size
= TYPE_ADA_SIZE (type
);
797 if (has_rep
&& ! DECL_BIT_FIELD (field
))
798 TYPE_ALIGN (record_type
)
799 = MAX (TYPE_ALIGN (record_type
), DECL_ALIGN (field
));
804 ada_size
= size_binop (MAX_EXPR
, ada_size
, this_ada_size
);
805 size
= size_binop (MAX_EXPR
, size
, this_size
);
806 size_unit
= size_binop (MAX_EXPR
, size_unit
, this_size_unit
);
809 case QUAL_UNION_TYPE
:
811 = fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
812 this_ada_size
, ada_size
));
813 size
= fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
815 size_unit
= fold (build (COND_EXPR
, sizetype
, DECL_QUALIFIER (field
),
816 this_size_unit
, size_unit
));
820 /* Since we know here that all fields are sorted in order of
821 increasing bit position, the size of the record is one
822 higher than the ending bit of the last field processed
823 unless we have a rep clause, since in that case we might
824 have a field outside a QUAL_UNION_TYPE that has a higher ending
825 position. So use a MAX in that case. Also, if this field is a
826 QUAL_UNION_TYPE, we need to take into account the previous size in
827 the case of empty variants. */
829 = merge_sizes (ada_size
, bit_position (field
), this_ada_size
,
830 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
831 size
= merge_sizes (size
, bit_position (field
), this_size
,
832 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
834 = merge_sizes (size_unit
, byte_position (field
), this_size_unit
,
835 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
843 if (code
== QUAL_UNION_TYPE
)
844 nreverse (fieldlist
);
846 /* If this is a padding record, we never want to make the size smaller than
847 what was specified in it, if any. */
848 if (TREE_CODE (record_type
) == RECORD_TYPE
849 && TYPE_IS_PADDING_P (record_type
) && TYPE_SIZE (record_type
) != 0)
851 size
= TYPE_SIZE (record_type
);
852 size_unit
= TYPE_SIZE_UNIT (record_type
);
855 /* Now set any of the values we've just computed that apply. */
856 if (! TYPE_IS_FAT_POINTER_P (record_type
)
857 && ! TYPE_CONTAINS_TEMPLATE_P (record_type
))
858 SET_TYPE_ADA_SIZE (record_type
, ada_size
);
862 if (! (TREE_CODE (record_type
) == RECORD_TYPE
863 && TYPE_IS_PADDING_P (record_type
)
864 && CONTAINS_PLACEHOLDER_P (size
)))
866 TYPE_SIZE (record_type
) = round_up (size
, TYPE_ALIGN (record_type
));
867 TYPE_SIZE_UNIT (record_type
)
868 = round_up (size_unit
,
869 TYPE_ALIGN (record_type
) / BITS_PER_UNIT
);
872 compute_record_mode (record_type
);
877 /* If this record is of variable size, rename it so that the
878 debugger knows it is and make a new, parallel, record
879 that tells the debugger how the record is laid out. See
880 exp_dbug.ads. But don't do this for records that are padding
881 since they confuse GDB. */
883 && ! (TREE_CODE (record_type
) == RECORD_TYPE
884 && TYPE_IS_PADDING_P (record_type
)))
887 = make_node (TREE_CODE (record_type
) == QUAL_UNION_TYPE
888 ? UNION_TYPE
: TREE_CODE (record_type
));
889 tree orig_id
= DECL_NAME (TYPE_STUB_DECL (record_type
));
891 = concat_id_with_name (orig_id
,
892 TREE_CODE (record_type
) == QUAL_UNION_TYPE
894 tree last_pos
= bitsize_zero_node
;
896 tree prev_old_field
= 0;
898 TYPE_NAME (new_record_type
) = new_id
;
899 TYPE_ALIGN (new_record_type
) = BIGGEST_ALIGNMENT
;
900 TYPE_STUB_DECL (new_record_type
)
901 = pushdecl (build_decl (TYPE_DECL
, new_id
, new_record_type
));
902 DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type
)) = 1;
903 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type
))
904 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type
));
905 TYPE_SIZE (new_record_type
) = size_int (TYPE_ALIGN (record_type
));
907 /* Now scan all the fields, replacing each field with a new
908 field corresponding to the new encoding. */
909 for (old_field
= TYPE_FIELDS (record_type
); old_field
!= 0;
910 old_field
= TREE_CHAIN (old_field
))
912 tree field_type
= TREE_TYPE (old_field
);
913 tree field_name
= DECL_NAME (old_field
);
915 tree curpos
= bit_position (old_field
);
917 unsigned int align
= 0;
920 /* See how the position was modified from the last position.
922 There are two basic cases we support: a value was added
923 to the last position or the last position was rounded to
924 a boundary and they something was added. Check for the
925 first case first. If not, see if there is any evidence
926 of rounding. If so, round the last position and try
929 If this is a union, the position can be taken as zero. */
931 if (TREE_CODE (new_record_type
) == UNION_TYPE
)
932 pos
= bitsize_zero_node
, align
= 0;
934 pos
= compute_related_constant (curpos
, last_pos
);
936 if (pos
== 0 && TREE_CODE (curpos
) == MULT_EXPR
937 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
)
939 align
= TREE_INT_CST_LOW (TREE_OPERAND (curpos
, 1));
940 pos
= compute_related_constant (curpos
,
941 round_up (last_pos
, align
));
943 else if (pos
== 0 && TREE_CODE (curpos
) == PLUS_EXPR
944 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
945 && TREE_CODE (TREE_OPERAND (curpos
, 0)) == MULT_EXPR
946 && host_integerp (TREE_OPERAND
947 (TREE_OPERAND (curpos
, 0), 1),
952 (TREE_OPERAND (TREE_OPERAND (curpos
, 0), 1), 1);
953 pos
= compute_related_constant (curpos
,
954 round_up (last_pos
, align
));
956 else if (potential_alignment_gap (prev_old_field
, old_field
,
959 align
= TYPE_ALIGN (field_type
);
960 pos
= compute_related_constant (curpos
,
961 round_up (last_pos
, align
));
964 /* If we can't compute a position, set it to zero.
966 ??? We really should abort here, but it's too much work
967 to get this correct for all cases. */
970 pos
= bitsize_zero_node
;
972 /* See if this type is variable-size and make a new type
973 and indicate the indirection if so. */
974 if (TREE_CODE (DECL_SIZE (old_field
)) != INTEGER_CST
)
976 field_type
= build_pointer_type (field_type
);
980 /* Make a new field name, if necessary. */
981 if (var
|| align
!= 0)
986 sprintf (suffix
, "XV%c%u", var
? 'L' : 'A',
987 align
/ BITS_PER_UNIT
);
989 strcpy (suffix
, "XVL");
991 field_name
= concat_id_with_name (field_name
, suffix
);
994 new_field
= create_field_decl (field_name
, field_type
,
996 DECL_SIZE (old_field
), pos
, 0);
997 TREE_CHAIN (new_field
) = TYPE_FIELDS (new_record_type
);
998 TYPE_FIELDS (new_record_type
) = new_field
;
1000 /* If old_field is a QUAL_UNION_TYPE, take its size as being
1001 zero. The only time it's not the last field of the record
1002 is when there are other components at fixed positions after
1003 it (meaning there was a rep clause for every field) and we
1004 want to be able to encode them. */
1005 last_pos
= size_binop (PLUS_EXPR
, bit_position (old_field
),
1006 (TREE_CODE (TREE_TYPE (old_field
))
1009 : DECL_SIZE (old_field
));
1010 prev_old_field
= old_field
;
1013 TYPE_FIELDS (new_record_type
)
1014 = nreverse (TYPE_FIELDS (new_record_type
));
1016 rest_of_type_compilation (new_record_type
, global_bindings_p ());
1019 rest_of_type_compilation (record_type
, global_bindings_p ());
1023 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1024 with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
1025 if this represents a QUAL_UNION_TYPE in which case we must look for
1026 COND_EXPRs and replace a value of zero with the old size. If HAS_REP
1027 is nonzero, we must take the MAX of the end position of this field
1028 with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
1030 We return an expression for the size. */
1033 merge_sizes (last_size
, first_bit
, size
, special
, has_rep
)
1035 tree first_bit
, size
;
1039 tree type
= TREE_TYPE (last_size
);
1042 if (! special
|| TREE_CODE (size
) != COND_EXPR
)
1044 new = size_binop (PLUS_EXPR
, first_bit
, size
);
1046 new = size_binop (MAX_EXPR
, last_size
, new);
1050 new = fold (build (COND_EXPR
, type
, TREE_OPERAND (size
, 0),
1051 integer_zerop (TREE_OPERAND (size
, 1))
1052 ? last_size
: merge_sizes (last_size
, first_bit
,
1053 TREE_OPERAND (size
, 1),
1055 integer_zerop (TREE_OPERAND (size
, 2))
1056 ? last_size
: merge_sizes (last_size
, first_bit
,
1057 TREE_OPERAND (size
, 2),
1060 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1061 when fed through substitute_in_expr) into thinking that a constant
1062 size is not constant. */
1063 while (TREE_CODE (new) == NON_LVALUE_EXPR
)
1064 new = TREE_OPERAND (new, 0);
1069 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1070 related by the addition of a constant. Return that constant if so. */
1073 compute_related_constant (op0
, op1
)
1076 tree op0_var
, op1_var
;
1077 tree op0_con
= split_plus (op0
, &op0_var
);
1078 tree op1_con
= split_plus (op1
, &op1_var
);
1079 tree result
= size_binop (MINUS_EXPR
, op0_con
, op1_con
);
1081 if (operand_equal_p (op0_var
, op1_var
, 0))
1083 else if (operand_equal_p (op0
, size_binop (PLUS_EXPR
, op1_var
, result
), 0))
1089 /* Utility function of above to split a tree OP which may be a sum, into a
1090 constant part, which is returned, and a variable part, which is stored
1091 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
1095 split_plus (in
, pvar
)
1099 /* Strip NOPS in order to ease the tree traversal and maximize the
1100 potential for constant or plus/minus discovery. We need to be careful
1101 to always return and set *pvar to bitsizetype trees, but it's worth
1105 *pvar
= convert (bitsizetype
, in
);
1107 if (TREE_CODE (in
) == INTEGER_CST
)
1109 *pvar
= bitsize_zero_node
;
1110 return convert (bitsizetype
, in
);
1112 else if (TREE_CODE (in
) == PLUS_EXPR
|| TREE_CODE (in
) == MINUS_EXPR
)
1114 tree lhs_var
, rhs_var
;
1115 tree lhs_con
= split_plus (TREE_OPERAND (in
, 0), &lhs_var
);
1116 tree rhs_con
= split_plus (TREE_OPERAND (in
, 1), &rhs_var
);
1118 if (lhs_var
== TREE_OPERAND (in
, 0)
1119 && rhs_var
== TREE_OPERAND (in
, 1))
1120 return bitsize_zero_node
;
1122 *pvar
= size_binop (TREE_CODE (in
), lhs_var
, rhs_var
);
1123 return size_binop (TREE_CODE (in
), lhs_con
, rhs_con
);
1126 return bitsize_zero_node
;
1129 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1130 subprogram. If it is void_type_node, then we are dealing with a procedure,
1131 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1132 PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
1133 copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1134 RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
1135 object. RETURNS_BY_REF is nonzero if the function returns by reference.
1136 RETURNS_WITH_DSP is nonzero if the function is to return with a
1137 depressed stack pointer. */
1140 create_subprog_type (return_type
, param_decl_list
, cico_list
,
1141 returns_unconstrained
, returns_by_ref
, returns_with_dsp
)
1143 tree param_decl_list
;
1145 int returns_unconstrained
, returns_by_ref
, returns_with_dsp
;
1147 /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1148 the subprogram formal parameters. This list is generated by traversing the
1149 input list of PARM_DECL nodes. */
1150 tree param_type_list
= NULL
;
1154 for (param_decl
= param_decl_list
; param_decl
;
1155 param_decl
= TREE_CHAIN (param_decl
))
1156 param_type_list
= tree_cons (NULL_TREE
, TREE_TYPE (param_decl
),
1159 /* The list of the function parameter types has to be terminated by the void
1160 type to signal to the back-end that we are not dealing with a variable
1161 parameter subprogram, but that the subprogram has a fixed number of
1163 param_type_list
= tree_cons (NULL_TREE
, void_type_node
, param_type_list
);
1165 /* The list of argument types has been created in reverse
1167 param_type_list
= nreverse (param_type_list
);
1169 type
= build_function_type (return_type
, param_type_list
);
1171 /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
1172 or the new type should, make a copy of TYPE. Likewise for
1173 RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
1174 if (TYPE_CI_CO_LIST (type
) != 0 || cico_list
!= 0
1175 || TYPE_RETURNS_UNCONSTRAINED_P (type
) != returns_unconstrained
1176 || TYPE_RETURNS_BY_REF_P (type
) != returns_by_ref
)
1177 type
= copy_type (type
);
1179 SET_TYPE_CI_CO_LIST (type
, cico_list
);
1180 TYPE_RETURNS_UNCONSTRAINED_P (type
) = returns_unconstrained
;
1181 TYPE_RETURNS_STACK_DEPRESSED (type
) = returns_with_dsp
;
1182 TYPE_RETURNS_BY_REF_P (type
) = returns_by_ref
;
1186 /* Return a copy of TYPE but safe to modify in any way. */
1192 tree
new = copy_node (type
);
1194 /* copy_node clears this field instead of copying it, because it is
1195 aliased with TREE_CHAIN. */
1196 TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type
);
1198 TYPE_POINTER_TO (new) = 0;
1199 TYPE_REFERENCE_TO (new) = 0;
1200 TYPE_MAIN_VARIANT (new) = new;
1201 TYPE_NEXT_VARIANT (new) = 0;
1206 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1207 TYPE_INDEX_TYPE is INDEX. */
1210 create_index_type (min
, max
, index
)
1214 /* First build a type for the desired range. */
1215 tree type
= build_index_2_type (min
, max
);
1217 /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
1218 doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
1219 is set, but not to INDEX, make a copy of this type with the requested
1220 index type. Note that we have no way of sharing these types, but that's
1221 only a small hole. */
1222 if (TYPE_INDEX_TYPE (type
) == index
)
1224 else if (TYPE_INDEX_TYPE (type
) != 0)
1225 type
= copy_type (type
);
1227 SET_TYPE_INDEX_TYPE (type
, index
);
1231 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1232 string) and TYPE is a ..._TYPE node giving its data type.
1233 ARTIFICIAL_P is nonzero if this is a declaration that was generated
1234 by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
1235 information about this type. */
1238 create_type_decl (type_name
, type
, attr_list
, artificial_p
, debug_info_p
)
1241 struct attrib
*attr_list
;
1245 tree type_decl
= build_decl (TYPE_DECL
, type_name
, type
);
1246 enum tree_code code
= TREE_CODE (type
);
1248 DECL_ARTIFICIAL (type_decl
) = artificial_p
;
1249 pushdecl (type_decl
);
1250 process_attributes (type_decl
, attr_list
);
1252 /* Pass type declaration information to the debugger unless this is an
1253 UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1254 and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
1255 a dummy type, which will be completed later, or a type for which
1256 debugging information was not requested. */
1257 if (code
== UNCONSTRAINED_ARRAY_TYPE
|| TYPE_IS_DUMMY_P (type
)
1259 DECL_IGNORED_P (type_decl
) = 1;
1260 else if (code
!= ENUMERAL_TYPE
&& code
!= RECORD_TYPE
1261 && ! ((code
== POINTER_TYPE
|| code
== REFERENCE_TYPE
)
1262 && TYPE_IS_DUMMY_P (TREE_TYPE (type
))))
1263 rest_of_decl_compilation (type_decl
, NULL
, global_bindings_p (), 0);
1268 /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
1269 ASM_NAME is its assembler name (if provided). TYPE is its data type
1270 (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
1271 expression; NULL_TREE if none.
1273 CONST_FLAG is nonzero if this variable is constant.
1275 PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
1276 the current compilation unit. This flag should be set when processing the
1277 variable definitions in a package specification. EXTERN_FLAG is nonzero
1278 when processing an external variable declaration (as opposed to a
1279 definition: no storage is to be allocated for the variable here).
1281 STATIC_FLAG is only relevant when not at top level. In that case
1282 it indicates whether to always allocate storage to the variable. */
1285 create_var_decl (var_name
, asm_name
, type
, var_init
, const_flag
, public_flag
,
1286 extern_flag
, static_flag
, attr_list
)
1295 struct attrib
*attr_list
;
1300 : (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1301 && (global_bindings_p () || static_flag
1302 ? 0 != initializer_constant_valid_p (var_init
,
1303 TREE_TYPE (var_init
))
1304 : TREE_CONSTANT (var_init
))));
1306 = build_decl ((const_flag
&& init_const
1307 /* Only make a CONST_DECL for sufficiently-small objects.
1308 We consider complex double "sufficiently-small" */
1309 && TYPE_SIZE (type
) != 0
1310 && host_integerp (TYPE_SIZE_UNIT (type
), 1)
1311 && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type
),
1312 GET_MODE_SIZE (DCmode
)))
1313 ? CONST_DECL
: VAR_DECL
, var_name
, type
);
1314 tree assign_init
= 0;
1316 /* If this is external, throw away any initializations unless this is a
1317 CONST_DECL (meaning we have a constant); they will be done elsewhere. If
1318 we are defining a global here, leave a constant initialization and save
1319 any variable elaborations for the elaboration routine. Otherwise, if
1320 the initializing expression is not the same as TYPE, generate the
1321 initialization with an assignment statement, since it knows how
1322 to do the required adjustents. If we are just annotating types,
1323 throw away the initialization if it isn't a constant. */
1325 if ((extern_flag
&& TREE_CODE (var_decl
) != CONST_DECL
)
1326 || (type_annotate_only
&& var_init
!= 0 && ! TREE_CONSTANT (var_init
)))
1329 if (global_bindings_p () && var_init
!= 0 && ! init_const
)
1331 add_pending_elaborations (var_decl
, var_init
);
1335 else if (var_init
!= 0
1336 && ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1337 != TYPE_MAIN_VARIANT (type
))
1338 || (static_flag
&& ! init_const
)))
1339 assign_init
= var_init
, var_init
= 0;
1341 DECL_COMMON (var_decl
) = !flag_no_common
;
1342 DECL_INITIAL (var_decl
) = var_init
;
1343 TREE_READONLY (var_decl
) = const_flag
;
1344 DECL_EXTERNAL (var_decl
) = extern_flag
;
1345 TREE_PUBLIC (var_decl
) = public_flag
|| extern_flag
;
1346 TREE_CONSTANT (var_decl
) = TREE_CODE (var_decl
) == CONST_DECL
;
1347 TREE_THIS_VOLATILE (var_decl
) = TREE_SIDE_EFFECTS (var_decl
)
1348 = TYPE_VOLATILE (type
);
1350 /* At the global binding level we need to allocate static storage for the
1351 variable if and only if its not external. If we are not at the top level
1352 we allocate automatic storage unless requested not to. */
1353 TREE_STATIC (var_decl
) = global_bindings_p () ? !extern_flag
: static_flag
;
1356 SET_DECL_ASSEMBLER_NAME (var_decl
, asm_name
);
1358 process_attributes (var_decl
, attr_list
);
1360 /* Add this decl to the current binding level and generate any
1361 needed code and RTL. */
1362 var_decl
= pushdecl (var_decl
);
1363 expand_decl (var_decl
);
1365 if (DECL_CONTEXT (var_decl
) != 0)
1366 expand_decl_init (var_decl
);
1368 /* If this is volatile, force it into memory. */
1369 if (TREE_SIDE_EFFECTS (var_decl
))
1370 gnat_mark_addressable (var_decl
);
1372 if (TREE_CODE (var_decl
) != CONST_DECL
)
1373 rest_of_decl_compilation (var_decl
, 0, global_bindings_p (), 0);
1375 if (assign_init
!= 0)
1377 /* If VAR_DECL has a padded type, convert it to the unpadded
1378 type so the assignment is done properly. */
1379 tree lhs
= var_decl
;
1381 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
1382 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
1383 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
1385 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, lhs
,
1392 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1393 type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
1394 this field is in a record type with a "pragma pack". If SIZE is nonzero
1395 it is the specified size for this field. If POS is nonzero, it is the bit
1396 position. If ADDRESSABLE is nonzero, it means we are allowed to take
1397 the address of this field for aliasing purposes. */
1400 create_field_decl (field_name
, field_type
, record_type
, packed
, size
, pos
,
1409 tree field_decl
= build_decl (FIELD_DECL
, field_name
, field_type
);
1411 DECL_CONTEXT (field_decl
) = record_type
;
1412 TREE_READONLY (field_decl
) = TREE_READONLY (field_type
);
1414 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1415 byte boundary since GCC cannot handle less-aligned BLKmode bitfields. */
1416 if (packed
&& TYPE_MODE (field_type
) == BLKmode
)
1417 DECL_ALIGN (field_decl
) = BITS_PER_UNIT
;
1419 /* If a size is specified, use it. Otherwise, see if we have a size
1420 to use that may differ from the natural size of the object. */
1422 size
= convert (bitsizetype
, size
);
1425 if (packed
== 1 && ! operand_equal_p (rm_size (field_type
),
1426 TYPE_SIZE (field_type
), 0))
1427 size
= rm_size (field_type
);
1429 /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1431 if (size
!= 0 && TREE_CODE (size
) == INTEGER_CST
1432 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) > 0)
1433 size
= round_up (size
, BITS_PER_UNIT
);
1436 /* Make a bitfield if a size is specified for two reasons: first if the size
1437 differs from the natural size. Second, if the alignment is insufficient.
1438 There are a number of ways the latter can be true. But never make a
1439 bitfield if the type of the field has a nonconstant size. */
1441 if (size
!= 0 && TREE_CODE (size
) == INTEGER_CST
1442 && TREE_CODE (TYPE_SIZE (field_type
)) == INTEGER_CST
1443 && (! operand_equal_p (TYPE_SIZE (field_type
), size
, 0)
1445 && ! value_zerop (size_binop (TRUNC_MOD_EXPR
, pos
,
1446 bitsize_int (TYPE_ALIGN
1449 || (TYPE_ALIGN (record_type
) != 0
1450 && TYPE_ALIGN (record_type
) < TYPE_ALIGN (field_type
))))
1452 DECL_BIT_FIELD (field_decl
) = 1;
1453 DECL_SIZE (field_decl
) = size
;
1454 if (! packed
&& pos
== 0)
1455 DECL_ALIGN (field_decl
)
1456 = (TYPE_ALIGN (record_type
) != 0
1457 ? MIN (TYPE_ALIGN (record_type
), TYPE_ALIGN (field_type
))
1458 : TYPE_ALIGN (field_type
));
1461 DECL_PACKED (field_decl
) = pos
!= 0 ? DECL_BIT_FIELD (field_decl
) : packed
;
1462 DECL_ALIGN (field_decl
)
1463 = MAX (DECL_ALIGN (field_decl
),
1464 DECL_BIT_FIELD (field_decl
) ? 1
1465 : packed
&& TYPE_MODE (field_type
) != BLKmode
? BITS_PER_UNIT
1466 : TYPE_ALIGN (field_type
));
1470 /* We need to pass in the alignment the DECL is known to have.
1471 This is the lowest-order bit set in POS, but no more than
1472 the alignment of the record, if one is specified. Note
1473 that an alignment of 0 is taken as infinite. */
1474 unsigned int known_align
;
1476 if (host_integerp (pos
, 1))
1477 known_align
= tree_low_cst (pos
, 1) & - tree_low_cst (pos
, 1);
1479 known_align
= BITS_PER_UNIT
;
1481 if (TYPE_ALIGN (record_type
)
1482 && (known_align
== 0 || known_align
> TYPE_ALIGN (record_type
)))
1483 known_align
= TYPE_ALIGN (record_type
);
1485 layout_decl (field_decl
, known_align
);
1486 SET_DECL_OFFSET_ALIGN (field_decl
,
1487 host_integerp (pos
, 1) ? BIGGEST_ALIGNMENT
1489 pos_from_bit (&DECL_FIELD_OFFSET (field_decl
),
1490 &DECL_FIELD_BIT_OFFSET (field_decl
),
1491 DECL_OFFSET_ALIGN (field_decl
), pos
);
1493 DECL_HAS_REP_P (field_decl
) = 1;
1496 /* If the field type is passed by reference, we will have pointers to the
1497 field, so it is addressable. */
1498 if (must_pass_by_ref (field_type
) || default_pass_by_ref (field_type
))
1501 /* ??? For now, we say that any field of aggregate type is addressable
1502 because the front end may take 'Reference of it. */
1503 if (AGGREGATE_TYPE_P (field_type
))
1506 /* Mark the decl as nonaddressable if it either is indicated so semantically
1507 or if it is a bit field. */
1508 DECL_NONADDRESSABLE_P (field_decl
)
1509 = ! addressable
|| DECL_BIT_FIELD (field_decl
);
1514 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1515 effects, has the value of zero. */
1521 if (TREE_CODE (exp
) == COMPOUND_EXPR
)
1522 return value_zerop (TREE_OPERAND (exp
, 1));
1524 return integer_zerop (exp
);
1527 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1528 PARAM_TYPE is its type. READONLY is nonzero if the parameter is
1529 readonly (either an IN parameter or an address of a pass-by-ref
1533 create_param_decl (param_name
, param_type
, readonly
)
1538 tree param_decl
= build_decl (PARM_DECL
, param_name
, param_type
);
1540 /* Honor the PROMOTE_PROTOTYPES target macro, as not doing so can
1541 lead to various ABI violations. */
1542 #ifdef PROMOTE_PROTOTYPES
1543 if ((TREE_CODE (param_type
) == INTEGER_TYPE
1544 || TREE_CODE (param_type
) == ENUMERAL_TYPE
)
1545 && TYPE_PRECISION (param_type
) < TYPE_PRECISION (integer_type_node
))
1547 /* We have to be careful about biased types here. Make a subtype
1548 of integer_type_node with the proper biasing. */
1549 if (TREE_CODE (param_type
) == INTEGER_TYPE
1550 && TYPE_BIASED_REPRESENTATION_P (param_type
))
1553 = copy_type (build_range_type (integer_type_node
,
1554 TYPE_MIN_VALUE (param_type
),
1555 TYPE_MAX_VALUE (param_type
)));
1557 TYPE_BIASED_REPRESENTATION_P (param_type
) = 1;
1560 param_type
= integer_type_node
;
1564 DECL_ARG_TYPE (param_decl
) = param_type
;
1565 DECL_ARG_TYPE_AS_WRITTEN (param_decl
) = param_type
;
1566 TREE_READONLY (param_decl
) = readonly
;
1570 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1573 process_attributes (decl
, attr_list
)
1575 struct attrib
*attr_list
;
1577 for (; attr_list
; attr_list
= attr_list
->next
)
1578 switch (attr_list
->type
)
1580 case ATTR_MACHINE_ATTRIBUTE
:
1581 decl_attributes (&decl
, tree_cons (attr_list
->name
, attr_list
->arg
,
1583 ATTR_FLAG_TYPE_IN_PLACE
);
1586 case ATTR_LINK_ALIAS
:
1587 TREE_STATIC (decl
) = 1;
1588 assemble_alias (decl
, attr_list
->name
);
1591 case ATTR_WEAK_EXTERNAL
:
1593 declare_weak (decl
);
1595 post_error ("?weak declarations not supported on this target",
1596 attr_list
->error_point
);
1599 case ATTR_LINK_SECTION
:
1600 #ifdef ASM_OUTPUT_SECTION_NAME
1601 DECL_SECTION_NAME (decl
)
1602 = build_string (IDENTIFIER_LENGTH (attr_list
->name
),
1603 IDENTIFIER_POINTER (attr_list
->name
));
1604 DECL_COMMON (decl
) = 0;
1606 post_error ("?section attributes are not supported for this target",
1607 attr_list
->error_point
);
1613 /* Add some pending elaborations on the list. */
1616 add_pending_elaborations (var_decl
, var_init
)
1621 Check_Elaboration_Code_Allowed (error_gnat_node
);
1623 pending_elaborations
1624 = chainon (pending_elaborations
, build_tree_list (var_decl
, var_init
));
1627 /* Obtain any pending elaborations and clear the old list. */
1630 get_pending_elaborations ()
1632 /* Each thing added to the list went on the end; we want it on the
1634 tree result
= TREE_CHAIN (pending_elaborations
);
1636 TREE_CHAIN (pending_elaborations
) = 0;
1640 /* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
1644 value_factor_p (value
, factor
)
1648 if (host_integerp (value
, 1))
1649 return tree_low_cst (value
, 1) % factor
== 0;
1651 if (TREE_CODE (value
) == MULT_EXPR
)
1652 return (value_factor_p (TREE_OPERAND (value
, 0), factor
)
1653 || value_factor_p (TREE_OPERAND (value
, 1), factor
));
1658 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1659 unless we can prove these 2 fields are laid out in such a way that no gap
1660 exist between the end of PREV_FIELD and the begining of CURR_FIELD. OFFSET
1661 is the distance in bits between the end of PREV_FIELD and the starting
1662 position of CURR_FIELD. It is ignored if null. */
1665 potential_alignment_gap (prev_field
, curr_field
, offset
)
1670 /* If this is the first field of the record, there cannot be any gap */
1674 /* If the previous field is a union type, then return False: The only
1675 time when such a field is not the last field of the record is when
1676 there are other components at fixed positions after it (meaning there
1677 was a rep clause for every field), in which case we don't want the
1678 alignment constraint to override them. */
1679 if (TREE_CODE (TREE_TYPE (prev_field
)) == QUAL_UNION_TYPE
)
1682 /* If the distance between the end of prev_field and the begining of
1683 curr_field is constant, then there is a gap if the value of this
1684 constant is not null. */
1685 if (offset
&& host_integerp (offset
, 1))
1686 return (!integer_zerop (offset
));
1688 /* If the size and position of the previous field are constant,
1689 then check the sum of this size and position. There will be a gap
1690 iff it is not multiple of the current field alignment. */
1691 if (host_integerp (DECL_SIZE (prev_field
), 1)
1692 && host_integerp (bit_position (prev_field
), 1))
1693 return ((tree_low_cst (bit_position (prev_field
), 1)
1694 + tree_low_cst (DECL_SIZE (prev_field
), 1))
1695 % DECL_ALIGN (curr_field
) != 0);
1697 /* If both the position and size of the previous field are multiples
1698 of the current field alignment, there can not be any gap. */
1699 if (value_factor_p (bit_position (prev_field
), DECL_ALIGN (curr_field
))
1700 && value_factor_p (DECL_SIZE (prev_field
), DECL_ALIGN (curr_field
)))
1703 /* Fallback, return that there may be a potential gap */
1707 /* Return nonzero if there are pending elaborations. */
1710 pending_elaborations_p ()
1712 return TREE_CHAIN (pending_elaborations
) != 0;
1715 /* Save a copy of the current pending elaboration list and make a new
1719 push_pending_elaborations ()
1721 struct e_stack
*p
= (struct e_stack
*) ggc_alloc (sizeof (struct e_stack
));
1723 p
->next
= elist_stack
;
1724 p
->elab_list
= pending_elaborations
;
1726 pending_elaborations
= build_tree_list (NULL_TREE
, NULL_TREE
);
1729 /* Pop the stack of pending elaborations. */
1732 pop_pending_elaborations ()
1734 struct e_stack
*p
= elist_stack
;
1736 pending_elaborations
= p
->elab_list
;
1737 elist_stack
= p
->next
;
1740 /* Return the current position in pending_elaborations so we can insert
1741 elaborations after that point. */
1744 get_elaboration_location ()
1746 return tree_last (pending_elaborations
);
1749 /* Insert the current elaborations after ELAB, which is in some elaboration
1753 insert_elaboration_list (elab
)
1756 tree next
= TREE_CHAIN (elab
);
1758 if (TREE_CHAIN (pending_elaborations
))
1760 TREE_CHAIN (elab
) = TREE_CHAIN (pending_elaborations
);
1761 TREE_CHAIN (tree_last (pending_elaborations
)) = next
;
1762 TREE_CHAIN (pending_elaborations
) = 0;
1766 /* Returns a LABEL_DECL node for LABEL_NAME. */
1769 create_label_decl (label_name
)
1772 tree label_decl
= build_decl (LABEL_DECL
, label_name
, void_type_node
);
1774 DECL_CONTEXT (label_decl
) = current_function_decl
;
1775 DECL_MODE (label_decl
) = VOIDmode
;
1776 DECL_SOURCE_LOCATION (label_decl
) = input_location
;
1781 /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1782 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1783 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1784 PARM_DECL nodes chained through the TREE_CHAIN field).
1786 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1787 appropriate fields in the FUNCTION_DECL. */
1790 create_subprog_decl (subprog_name
, asm_name
, subprog_type
, param_decl_list
,
1791 inline_flag
, public_flag
, extern_flag
, attr_list
)
1795 tree param_decl_list
;
1799 struct attrib
*attr_list
;
1801 tree return_type
= TREE_TYPE (subprog_type
);
1802 tree subprog_decl
= build_decl (FUNCTION_DECL
, subprog_name
, subprog_type
);
1804 /* If this is a function nested inside an inlined external function, it
1805 means we aren't going to compile the outer function unless it is
1806 actually inlined, so do the same for us. */
1807 if (current_function_decl
!= 0 && DECL_INLINE (current_function_decl
)
1808 && DECL_EXTERNAL (current_function_decl
))
1811 DECL_EXTERNAL (subprog_decl
) = extern_flag
;
1812 TREE_PUBLIC (subprog_decl
) = public_flag
;
1813 DECL_INLINE (subprog_decl
) = inline_flag
;
1814 TREE_READONLY (subprog_decl
) = TYPE_READONLY (subprog_type
);
1815 TREE_THIS_VOLATILE (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1816 TREE_SIDE_EFFECTS (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1817 DECL_ARGUMENTS (subprog_decl
) = param_decl_list
;
1818 DECL_RESULT (subprog_decl
) = build_decl (RESULT_DECL
, 0, return_type
);
1821 SET_DECL_ASSEMBLER_NAME (subprog_decl
, asm_name
);
1823 process_attributes (subprog_decl
, attr_list
);
1825 /* Add this decl to the current binding level. */
1826 subprog_decl
= pushdecl (subprog_decl
);
1828 /* Output the assembler code and/or RTL for the declaration. */
1829 rest_of_decl_compilation (subprog_decl
, 0, global_bindings_p (), 0);
1831 return subprog_decl
;
1834 /* Count how deep we are into nested functions. This is because
1835 we shouldn't call the backend function context routines unless we
1836 are in a nested function. */
1838 static int function_nesting_depth
;
1840 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1841 body. This routine needs to be invoked before processing the declarations
1842 appearing in the subprogram. */
1845 begin_subprog_body (subprog_decl
)
1848 tree param_decl_list
;
1852 if (function_nesting_depth
++ != 0)
1853 push_function_context ();
1855 announce_function (subprog_decl
);
1857 /* Make this field nonzero so further routines know that this is not
1858 tentative. error_mark_node is replaced below (in poplevel) with the
1860 DECL_INITIAL (subprog_decl
) = error_mark_node
;
1862 /* This function exists in static storage. This does not mean `static' in
1864 TREE_STATIC (subprog_decl
) = 1;
1866 /* Enter a new binding level. */
1867 current_function_decl
= subprog_decl
;
1870 /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
1871 subprogram body) so that they can be recognized as local variables in the
1874 The list of PARM_DECL nodes is stored in the right order in
1875 DECL_ARGUMENTS. Since ..._DECL nodes get stored in the reverse order in
1876 which they are transmitted to `pushdecl' we need to reverse the list of
1877 PARM_DECLs if we want it to be stored in the right order. The reason why
1878 we want to make sure the PARM_DECLs are stored in the correct order is
1879 that this list will be retrieved in a few lines with a call to `getdecl'
1880 to store it back into the DECL_ARGUMENTS field. */
1881 param_decl_list
= nreverse (DECL_ARGUMENTS (subprog_decl
));
1883 for (param_decl
= param_decl_list
; param_decl
; param_decl
= next_param
)
1885 next_param
= TREE_CHAIN (param_decl
);
1886 TREE_CHAIN (param_decl
) = NULL
;
1887 pushdecl (param_decl
);
1890 /* Store back the PARM_DECL nodes. They appear in the right order. */
1891 DECL_ARGUMENTS (subprog_decl
) = getdecls ();
1893 init_function_start (subprog_decl
);
1894 expand_function_start (subprog_decl
, 0);
1896 /* If this function is `main', emit a call to `__main'
1897 to run global initializers, etc. */
1898 if (DECL_ASSEMBLER_NAME (subprog_decl
) != 0
1899 && MAIN_NAME_P (DECL_ASSEMBLER_NAME (subprog_decl
))
1900 && DECL_CONTEXT (subprog_decl
) == NULL_TREE
)
1901 expand_main_function ();
1904 /* Finish the definition of the current subprogram and compile it all the way
1905 to assembler language output. */
1914 BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl
))
1915 = current_function_decl
;
1917 /* Mark the RESULT_DECL as being in this subprogram. */
1918 DECL_CONTEXT (DECL_RESULT (current_function_decl
)) = current_function_decl
;
1920 expand_function_end ();
1922 /* If this is a nested function, push a new GC context. That will keep
1923 local variables on the stack from being collected while we're doing
1924 the compilation of this function. */
1925 if (function_nesting_depth
> 1)
1926 ggc_push_context ();
1928 rest_of_compilation (current_function_decl
);
1930 if (function_nesting_depth
> 1)
1933 /* Throw away any VAR_DECLs we made for OUT parameters; they must
1934 not be seen when we call this function and will be in
1935 unallocated memory anyway. */
1936 for (cico_list
= TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl
));
1937 cico_list
!= 0; cico_list
= TREE_CHAIN (cico_list
))
1938 TREE_VALUE (cico_list
) = 0;
1940 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
1942 /* Throw away DECL_RTL in any PARM_DECLs unless this function
1943 was saved for inline, in which case the DECL_RTLs are in
1944 preserved memory. */
1945 for (decl
= DECL_ARGUMENTS (current_function_decl
);
1946 decl
!= 0; decl
= TREE_CHAIN (decl
))
1948 SET_DECL_RTL (decl
, 0);
1949 DECL_INCOMING_RTL (decl
) = 0;
1952 /* Similarly, discard DECL_RTL of the return value. */
1953 SET_DECL_RTL (DECL_RESULT (current_function_decl
), 0);
1955 /* But DECL_INITIAL must remain nonzero so we know this
1956 was an actual function definition unless toplev.c decided not
1958 if (DECL_INITIAL (current_function_decl
) != 0)
1959 DECL_INITIAL (current_function_decl
) = error_mark_node
;
1961 DECL_ARGUMENTS (current_function_decl
) = 0;
1964 /* If we are not at the bottom of the function nesting stack, pop up to
1965 the containing function. Otherwise show we aren't in any function. */
1966 if (--function_nesting_depth
!= 0)
1967 pop_function_context ();
1969 current_function_decl
= 0;
1972 /* Return a definition for a builtin function named NAME and whose data type
1973 is TYPE. TYPE should be a function type with argument types.
1974 FUNCTION_CODE tells later passes how to compile calls to this function.
1975 See tree.h for its possible values.
1977 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1978 the name to be called if we can't opencode the function. If
1979 ATTRS is nonzero, use that for the function attribute list. */
1982 builtin_function (name
, type
, function_code
, class, library_name
, attrs
)
1986 enum built_in_class
class;
1987 const char *library_name
;
1990 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
1992 DECL_EXTERNAL (decl
) = 1;
1993 TREE_PUBLIC (decl
) = 1;
1995 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
1998 DECL_BUILT_IN_CLASS (decl
) = class;
1999 DECL_FUNCTION_CODE (decl
) = function_code
;
2001 decl_attributes (&decl
, attrs
, ATTR_FLAG_BUILT_IN
);
2005 /* Return an integer type with the number of bits of precision given by
2006 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
2007 it is a signed type. */
2010 gnat_type_for_size (precision
, unsignedp
)
2017 if (precision
<= 2 * MAX_BITS_PER_WORD
2018 && signed_and_unsigned_types
[precision
][unsignedp
] != 0)
2019 return signed_and_unsigned_types
[precision
][unsignedp
];
2022 t
= make_unsigned_type (precision
);
2024 t
= make_signed_type (precision
);
2026 if (precision
<= 2 * MAX_BITS_PER_WORD
)
2027 signed_and_unsigned_types
[precision
][unsignedp
] = t
;
2029 if (TYPE_NAME (t
) == 0)
2031 sprintf (type_name
, "%sSIGNED_%d", unsignedp
? "UN" : "", precision
);
2032 TYPE_NAME (t
) = get_identifier (type_name
);
2038 /* Likewise for floating-point types. */
2041 float_type_for_size (precision
, mode
)
2043 enum machine_mode mode
;
2048 if (float_types
[(int) mode
] != 0)
2049 return float_types
[(int) mode
];
2051 float_types
[(int) mode
] = t
= make_node (REAL_TYPE
);
2052 TYPE_PRECISION (t
) = precision
;
2055 if (TYPE_MODE (t
) != mode
)
2058 if (TYPE_NAME (t
) == 0)
2060 sprintf (type_name
, "FLOAT_%d", precision
);
2061 TYPE_NAME (t
) = get_identifier (type_name
);
2067 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
2068 an unsigned type; otherwise a signed type is returned. */
2071 gnat_type_for_mode (mode
, unsignedp
)
2072 enum machine_mode mode
;
2075 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
2076 return float_type_for_size (GET_MODE_BITSIZE (mode
), mode
);
2078 return gnat_type_for_size (GET_MODE_BITSIZE (mode
), unsignedp
);
2081 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
2084 gnat_unsigned_type (type_node
)
2087 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 1);
2089 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
2091 type
= copy_node (type
);
2092 TREE_TYPE (type
) = type_node
;
2094 else if (TREE_TYPE (type_node
) != 0
2095 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
2096 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
2098 type
= copy_node (type
);
2099 TREE_TYPE (type
) = TREE_TYPE (type_node
);
2105 /* Return the signed version of a TYPE_NODE, a scalar type. */
2108 gnat_signed_type (type_node
)
2111 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 0);
2113 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
2115 type
= copy_node (type
);
2116 TREE_TYPE (type
) = type_node
;
2118 else if (TREE_TYPE (type_node
) != 0
2119 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
2120 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
2122 type
= copy_node (type
);
2123 TREE_TYPE (type
) = TREE_TYPE (type_node
);
2129 /* Return a type the same as TYPE except unsigned or signed according to
2133 gnat_signed_or_unsigned_type (unsignedp
, type
)
2137 if (! INTEGRAL_TYPE_P (type
) || TREE_UNSIGNED (type
) == unsignedp
)
2140 return gnat_type_for_size (TYPE_PRECISION (type
), unsignedp
);
2143 /* EXP is an expression for the size of an object. If this size contains
2144 discriminant references, replace them with the maximum (if MAX_P) or
2145 minimum (if ! MAX_P) possible value of the discriminant. */
2148 max_size (exp
, max_p
)
2152 enum tree_code code
= TREE_CODE (exp
);
2153 tree type
= TREE_TYPE (exp
);
2155 switch (TREE_CODE_CLASS (code
))
2162 if (code
== TREE_LIST
)
2163 return tree_cons (TREE_PURPOSE (exp
),
2164 max_size (TREE_VALUE (exp
), max_p
),
2165 TREE_CHAIN (exp
) != 0
2166 ? max_size (TREE_CHAIN (exp
), max_p
) : 0);
2170 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2171 modify. Otherwise, we treat it like a variable. */
2172 if (! CONTAINS_PLACEHOLDER_P (exp
))
2175 type
= TREE_TYPE (TREE_OPERAND (exp
, 1));
2177 max_size (max_p
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
), 1);
2180 return max_p
? size_one_node
: size_zero_node
;
2185 switch (TREE_CODE_LENGTH (code
))
2188 if (code
== NON_LVALUE_EXPR
)
2189 return max_size (TREE_OPERAND (exp
, 0), max_p
);
2192 fold (build1 (code
, type
,
2193 max_size (TREE_OPERAND (exp
, 0),
2194 code
== NEGATE_EXPR
? ! max_p
: max_p
)));
2197 if (code
== RTL_EXPR
)
2199 else if (code
== COMPOUND_EXPR
)
2200 return max_size (TREE_OPERAND (exp
, 1), max_p
);
2201 else if (code
== WITH_RECORD_EXPR
)
2205 tree lhs
= max_size (TREE_OPERAND (exp
, 0), max_p
);
2206 tree rhs
= max_size (TREE_OPERAND (exp
, 1),
2207 code
== MINUS_EXPR
? ! max_p
: max_p
);
2209 /* Special-case wanting the maximum value of a MIN_EXPR.
2210 In that case, if one side overflows, return the other.
2211 sizetype is signed, but we know sizes are non-negative.
2212 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2213 overflowing or the maximum possible value and the RHS
2215 if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (rhs
))
2217 else if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (lhs
))
2219 else if ((code
== MINUS_EXPR
|| code
== PLUS_EXPR
)
2220 && ((TREE_CONSTANT (lhs
) && TREE_OVERFLOW (lhs
))
2221 || operand_equal_p (lhs
, TYPE_MAX_VALUE (type
), 0))
2222 && ! TREE_CONSTANT (rhs
))
2225 return fold (build (code
, type
, lhs
, rhs
));
2229 if (code
== SAVE_EXPR
)
2231 else if (code
== COND_EXPR
)
2232 return fold (build (MAX_EXPR
, type
,
2233 max_size (TREE_OPERAND (exp
, 1), max_p
),
2234 max_size (TREE_OPERAND (exp
, 2), max_p
)));
2235 else if (code
== CALL_EXPR
&& TREE_OPERAND (exp
, 1) != 0)
2236 return build (CALL_EXPR
, type
, TREE_OPERAND (exp
, 0),
2237 max_size (TREE_OPERAND (exp
, 1), max_p
));
2244 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2245 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2246 Return a constructor for the template. */
2249 build_template (template_type
, array_type
, expr
)
2254 tree template_elts
= NULL_TREE
;
2255 tree bound_list
= NULL_TREE
;
2258 if (TREE_CODE (array_type
) == RECORD_TYPE
2259 && (TYPE_IS_PADDING_P (array_type
)
2260 || TYPE_LEFT_JUSTIFIED_MODULAR_P (array_type
)))
2261 array_type
= TREE_TYPE (TYPE_FIELDS (array_type
));
2263 if (TREE_CODE (array_type
) == ARRAY_TYPE
2264 || (TREE_CODE (array_type
) == INTEGER_TYPE
2265 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type
)))
2266 bound_list
= TYPE_ACTUAL_BOUNDS (array_type
);
2268 /* First make the list for a CONSTRUCTOR for the template. Go down the
2269 field list of the template instead of the type chain because this
2270 array might be an Ada array of arrays and we can't tell where the
2271 nested arrays stop being the underlying object. */
2273 for (field
= TYPE_FIELDS (template_type
); field
;
2275 ? (bound_list
= TREE_CHAIN (bound_list
))
2276 : (array_type
= TREE_TYPE (array_type
))),
2277 field
= TREE_CHAIN (TREE_CHAIN (field
)))
2279 tree bounds
, min
, max
;
2281 /* If we have a bound list, get the bounds from there. Likewise
2282 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2283 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2284 This will give us a maximum range. */
2285 if (bound_list
!= 0)
2286 bounds
= TREE_VALUE (bound_list
);
2287 else if (TREE_CODE (array_type
) == ARRAY_TYPE
)
2288 bounds
= TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type
));
2289 else if (expr
!= 0 && TREE_CODE (expr
) == PARM_DECL
2290 && DECL_BY_COMPONENT_PTR_P (expr
))
2291 bounds
= TREE_TYPE (field
);
2295 min
= convert (TREE_TYPE (TREE_CHAIN (field
)), TYPE_MIN_VALUE (bounds
));
2296 max
= convert (TREE_TYPE (field
), TYPE_MAX_VALUE (bounds
));
2298 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2299 surround them with a WITH_RECORD_EXPR giving EXPR as the
2301 if (CONTAINS_PLACEHOLDER_P (min
))
2302 min
= build (WITH_RECORD_EXPR
, TREE_TYPE (min
), min
, expr
);
2303 if (CONTAINS_PLACEHOLDER_P (max
))
2304 max
= build (WITH_RECORD_EXPR
, TREE_TYPE (max
), max
, expr
);
2306 template_elts
= tree_cons (TREE_CHAIN (field
), max
,
2307 tree_cons (field
, min
, template_elts
));
2310 return gnat_build_constructor (template_type
, nreverse (template_elts
));
2313 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2314 a descriptor type, and the GCC type of an object. Each FIELD_DECL
2315 in the type contains in its DECL_INITIAL the expression to use when
2316 a constructor is made for the type. GNAT_ENTITY is a gnat node used
2317 to print out an error message if the mechanism cannot be applied to
2318 an object of that type and also for the name. */
2321 build_vms_descriptor (type
, mech
, gnat_entity
)
2323 Mechanism_Type mech
;
2324 Entity_Id gnat_entity
;
2326 tree record_type
= make_node (RECORD_TYPE
);
2327 tree field_list
= 0;
2336 /* If TYPE is an unconstrained array, use the underlying array type. */
2337 if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
2338 type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type
))));
2340 /* If this is an array, compute the number of dimensions in the array,
2341 get the index types, and point to the inner type. */
2342 if (TREE_CODE (type
) != ARRAY_TYPE
)
2345 for (ndim
= 1, inner_type
= type
;
2346 TREE_CODE (TREE_TYPE (inner_type
)) == ARRAY_TYPE
2347 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type
));
2348 ndim
++, inner_type
= TREE_TYPE (inner_type
))
2351 idx_arr
= (tree
*) alloca (ndim
* sizeof (tree
));
2353 if (mech
!= By_Descriptor_NCA
2354 && TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type
))
2355 for (i
= ndim
- 1, inner_type
= type
;
2357 i
--, inner_type
= TREE_TYPE (inner_type
))
2358 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2360 for (i
= 0, inner_type
= type
;
2362 i
++, inner_type
= TREE_TYPE (inner_type
))
2363 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2365 /* Now get the DTYPE value. */
2366 switch (TREE_CODE (type
))
2370 if (TYPE_VAX_FLOATING_POINT_P (type
))
2371 switch ((int) TYPE_DIGITS_VALUE (type
))
2384 switch (GET_MODE_BITSIZE (TYPE_MODE (type
)))
2387 dtype
= TREE_UNSIGNED (type
) ? 2 : 6;
2390 dtype
= TREE_UNSIGNED (type
) ? 3 : 7;
2393 dtype
= TREE_UNSIGNED (type
) ? 4 : 8;
2396 dtype
= TREE_UNSIGNED (type
) ? 5 : 9;
2399 dtype
= TREE_UNSIGNED (type
) ? 25 : 26;
2405 dtype
= GET_MODE_BITSIZE (TYPE_MODE (type
)) == 32 ? 52 : 53;
2409 if (TREE_CODE (TREE_TYPE (type
)) == INTEGER_TYPE
2410 && TYPE_VAX_FLOATING_POINT_P (type
))
2411 switch ((int) TYPE_DIGITS_VALUE (type
))
2423 dtype
= GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type
))) == 32 ? 54: 55;
2434 /* Get the CLASS value. */
2437 case By_Descriptor_A
:
2440 case By_Descriptor_NCA
:
2443 case By_Descriptor_SB
:
2450 /* Make the type for a descriptor for VMS. The first four fields
2451 are the same for all types. */
2454 = chainon (field_list
,
2455 make_descriptor_field
2456 ("LENGTH", gnat_type_for_size (16, 1), record_type
,
2457 size_in_bytes (mech
== By_Descriptor_A
? inner_type
: type
)));
2459 field_list
= chainon (field_list
,
2460 make_descriptor_field ("DTYPE",
2461 gnat_type_for_size (8, 1),
2462 record_type
, size_int (dtype
)));
2463 field_list
= chainon (field_list
,
2464 make_descriptor_field ("CLASS",
2465 gnat_type_for_size (8, 1),
2466 record_type
, size_int (class)));
2469 = chainon (field_list
,
2470 make_descriptor_field ("POINTER",
2471 build_pointer_type (type
),
2474 build_pointer_type (type
),
2475 build (PLACEHOLDER_EXPR
,
2481 case By_Descriptor_S
:
2484 case By_Descriptor_SB
:
2486 = chainon (field_list
,
2487 make_descriptor_field
2488 ("SB_L1", gnat_type_for_size (32, 1), record_type
,
2489 TREE_CODE (type
) == ARRAY_TYPE
2490 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2492 = chainon (field_list
,
2493 make_descriptor_field
2494 ("SB_L2", gnat_type_for_size (32, 1), record_type
,
2495 TREE_CODE (type
) == ARRAY_TYPE
2496 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2499 case By_Descriptor_A
:
2500 case By_Descriptor_NCA
:
2501 field_list
= chainon (field_list
,
2502 make_descriptor_field ("SCALE",
2503 gnat_type_for_size (8, 1),
2507 field_list
= chainon (field_list
,
2508 make_descriptor_field ("DIGITS",
2509 gnat_type_for_size (8, 1),
2514 = chainon (field_list
,
2515 make_descriptor_field
2516 ("AFLAGS", gnat_type_for_size (8, 1), record_type
,
2517 size_int (mech
== By_Descriptor_NCA
2519 /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
2520 : (TREE_CODE (type
) == ARRAY_TYPE
2521 && TYPE_CONVENTION_FORTRAN_P (type
)
2524 field_list
= chainon (field_list
,
2525 make_descriptor_field ("DIMCT",
2526 gnat_type_for_size (8, 1),
2530 field_list
= chainon (field_list
,
2531 make_descriptor_field ("ARSIZE",
2532 gnat_type_for_size (32, 1),
2534 size_in_bytes (type
)));
2536 /* Now build a pointer to the 0,0,0... element. */
2537 tem
= build (PLACEHOLDER_EXPR
, type
);
2538 for (i
= 0, inner_type
= type
; i
< ndim
;
2539 i
++, inner_type
= TREE_TYPE (inner_type
))
2540 tem
= build (ARRAY_REF
, TREE_TYPE (inner_type
), tem
,
2541 convert (TYPE_DOMAIN (inner_type
), size_zero_node
));
2544 = chainon (field_list
,
2545 make_descriptor_field
2546 ("A0", build_pointer_type (inner_type
), record_type
,
2547 build1 (ADDR_EXPR
, build_pointer_type (inner_type
), tem
)));
2549 /* Next come the addressing coefficients. */
2551 for (i
= 0; i
< ndim
; i
++)
2555 = size_binop (MULT_EXPR
, tem
,
2556 size_binop (PLUS_EXPR
,
2557 size_binop (MINUS_EXPR
,
2558 TYPE_MAX_VALUE (idx_arr
[i
]),
2559 TYPE_MIN_VALUE (idx_arr
[i
])),
2562 fname
[0] = (mech
== By_Descriptor_NCA
? 'S' : 'M');
2563 fname
[1] = '0' + i
, fname
[2] = 0;
2565 = chainon (field_list
,
2566 make_descriptor_field (fname
,
2567 gnat_type_for_size (32, 1),
2568 record_type
, idx_length
));
2570 if (mech
== By_Descriptor_NCA
)
2574 /* Finally here are the bounds. */
2575 for (i
= 0; i
< ndim
; i
++)
2579 fname
[0] = 'L', fname
[1] = '0' + i
, fname
[2] = 0;
2581 = chainon (field_list
,
2582 make_descriptor_field
2583 (fname
, gnat_type_for_size (32, 1), record_type
,
2584 TYPE_MIN_VALUE (idx_arr
[i
])));
2588 = chainon (field_list
,
2589 make_descriptor_field
2590 (fname
, gnat_type_for_size (32, 1), record_type
,
2591 TYPE_MAX_VALUE (idx_arr
[i
])));
2596 post_error ("unsupported descriptor type for &", gnat_entity
);
2599 finish_record_type (record_type
, field_list
, 0, 1);
2600 pushdecl (build_decl (TYPE_DECL
, create_concat_name (gnat_entity
, "DESC"),
2606 /* Utility routine for above code to make a field. */
2609 make_descriptor_field (name
, type
, rec_type
, initial
)
2616 = create_field_decl (get_identifier (name
), type
, rec_type
, 0, 0, 0, 0);
2618 DECL_INITIAL (field
) = initial
;
2622 /* Build a type to be used to represent an aliased object whose nominal
2623 type is an unconstrained array. This consists of a RECORD_TYPE containing
2624 a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2625 ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
2626 is used to represent an arbitrary unconstrained object. Use NAME
2627 as the name of the record. */
2630 build_unc_object_type (template_type
, object_type
, name
)
2635 tree type
= make_node (RECORD_TYPE
);
2636 tree template_field
= create_field_decl (get_identifier ("BOUNDS"),
2637 template_type
, type
, 0, 0, 0, 1);
2638 tree array_field
= create_field_decl (get_identifier ("ARRAY"), object_type
,
2641 TYPE_NAME (type
) = name
;
2642 TYPE_CONTAINS_TEMPLATE_P (type
) = 1;
2643 finish_record_type (type
,
2644 chainon (chainon (NULL_TREE
, template_field
),
2651 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
2652 the normal case this is just two adjustments, but we have more to do
2653 if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
2656 update_pointer_to (old_type
, new_type
)
2660 tree ptr
= TYPE_POINTER_TO (old_type
);
2661 tree ref
= TYPE_REFERENCE_TO (old_type
);
2664 /* If this is the main variant, process all the other variants first. */
2665 if (TYPE_MAIN_VARIANT (old_type
) == old_type
)
2666 for (type
= TYPE_NEXT_VARIANT (old_type
); type
!= 0;
2667 type
= TYPE_NEXT_VARIANT (type
))
2668 update_pointer_to (type
, new_type
);
2670 /* If no pointer or reference, we are done. */
2671 if (ptr
== 0 && ref
== 0)
2674 /* Merge the old type qualifiers in the new type.
2676 Each old variant has qualifiers for specific reasons, and the new
2677 designated type as well. Each set of qualifiers represents useful
2678 information grabbed at some point, and merging the two simply unifies
2679 these inputs into the final type description.
2681 Consider for instance a volatile type frozen after an access to constant
2682 type designating it. After the designated type freeze, we get here with a
2683 volatile new_type and a dummy old_type with a readonly variant, created
2684 when the access type was processed. We shall make a volatile and readonly
2685 designated type, because that's what it really is.
2687 We might also get here for a non-dummy old_type variant with different
2688 qualifiers than the new_type ones, for instance in some cases of pointers
2689 to private record type elaboration (see the comments around the call to
2690 this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
2691 qualifiers in thoses cases too, to avoid accidentally discarding the
2692 initial set, and will often end up with old_type == new_type then. */
2693 new_type
= build_qualified_type (new_type
,
2694 TYPE_QUALS (old_type
)
2695 | TYPE_QUALS (new_type
));
2697 /* If the new type and the old one are identical, there is nothing to
2699 if (old_type
== new_type
)
2702 /* Otherwise, first handle the simple case. */
2703 if (TREE_CODE (new_type
) != UNCONSTRAINED_ARRAY_TYPE
)
2706 TREE_TYPE (ptr
) = new_type
;
2707 TYPE_POINTER_TO (new_type
) = ptr
;
2710 TREE_TYPE (ref
) = new_type
;
2711 TYPE_REFERENCE_TO (new_type
) = ref
;
2713 if (ptr
!= 0 && TYPE_NAME (ptr
) != 0
2714 && TREE_CODE (TYPE_NAME (ptr
)) == TYPE_DECL
2715 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2716 rest_of_decl_compilation (TYPE_NAME (ptr
), NULL
,
2717 global_bindings_p (), 0);
2718 if (ref
!= 0 && TYPE_NAME (ref
) != 0
2719 && TREE_CODE (TYPE_NAME (ref
)) == TYPE_DECL
2720 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2721 rest_of_decl_compilation (TYPE_NAME (ref
), NULL
,
2722 global_bindings_p (), 0);
2725 /* Now deal with the unconstrained array case. In this case the "pointer"
2726 is actually a RECORD_TYPE where the types of both fields are
2727 pointers to void. In that case, copy the field list from the
2728 old type to the new one and update the fields' context. */
2729 else if (TREE_CODE (ptr
) != RECORD_TYPE
|| ! TYPE_IS_FAT_POINTER_P (ptr
))
2734 tree new_obj_rec
= TYPE_OBJECT_RECORD_TYPE (new_type
);
2739 TYPE_FIELDS (ptr
) = TYPE_FIELDS (TYPE_POINTER_TO (new_type
));
2740 DECL_CONTEXT (TYPE_FIELDS (ptr
)) = ptr
;
2741 DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr
))) = ptr
;
2743 /* Rework the PLACEHOLDER_EXPR inside the reference to the
2746 ??? This is now the only use of gnat_substitute_in_type, which
2747 is now a very "heavy" routine to do this, so it should be replaced
2749 ptr_temp_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr
)));
2750 new_ref
= build (COMPONENT_REF
, ptr_temp_type
,
2751 build (PLACEHOLDER_EXPR
, ptr
),
2752 TREE_CHAIN (TYPE_FIELDS (ptr
)));
2755 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2756 gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2757 TREE_CHAIN (TYPE_FIELDS (ptr
)), new_ref
));
2759 for (var
= TYPE_MAIN_VARIANT (ptr
); var
; var
= TYPE_NEXT_VARIANT (var
))
2760 SET_TYPE_UNCONSTRAINED_ARRAY (var
, new_type
);
2762 TYPE_POINTER_TO (new_type
) = TYPE_REFERENCE_TO (new_type
)
2763 = TREE_TYPE (new_type
) = ptr
;
2765 /* Now handle updating the allocation record, what the thin pointer
2766 points to. Update all pointers from the old record into the new
2767 one, update the types of the fields, and recompute the size. */
2769 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type
), new_obj_rec
);
2771 TREE_TYPE (TYPE_FIELDS (new_obj_rec
)) = TREE_TYPE (ptr_temp_type
);
2772 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2773 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
)));
2774 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2775 = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2776 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2777 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2779 TYPE_SIZE (new_obj_rec
)
2780 = size_binop (PLUS_EXPR
,
2781 DECL_SIZE (TYPE_FIELDS (new_obj_rec
)),
2782 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2783 TYPE_SIZE_UNIT (new_obj_rec
)
2784 = size_binop (PLUS_EXPR
,
2785 DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec
)),
2786 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2787 rest_of_type_compilation (ptr
, global_bindings_p ());
2791 /* Convert a pointer to a constrained array into a pointer to a fat
2792 pointer. This involves making or finding a template. */
2795 convert_to_fat_pointer (type
, expr
)
2799 tree template_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
))));
2800 tree
template, template_addr
;
2801 tree etype
= TREE_TYPE (expr
);
2803 /* If EXPR is a constant of zero, we make a fat pointer that has a null
2804 pointer to the template and array. */
2805 if (integer_zerop (expr
))
2807 gnat_build_constructor
2809 tree_cons (TYPE_FIELDS (type
),
2810 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2811 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2812 convert (build_pointer_type (template_type
),
2816 /* If EXPR is a thin pointer, make the template and data from the record. */
2818 else if (TYPE_THIN_POINTER_P (etype
))
2820 tree fields
= TYPE_FIELDS (TREE_TYPE (etype
));
2822 expr
= save_expr (expr
);
2823 if (TREE_CODE (expr
) == ADDR_EXPR
)
2824 expr
= TREE_OPERAND (expr
, 0);
2826 expr
= build1 (INDIRECT_REF
, TREE_TYPE (etype
), expr
);
2828 template = build_component_ref (expr
, NULL_TREE
, fields
, 0);
2829 expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
2830 build_component_ref (expr
, NULL_TREE
,
2831 TREE_CHAIN (fields
), 0));
2834 /* Otherwise, build the constructor for the template. */
2835 template = build_template (template_type
, TREE_TYPE (etype
), expr
);
2837 template_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, template);
2839 /* The result is a CONSTRUCTOR for the fat pointer.
2841 If expr is an argument of a foreign convention subprogram, the type it
2842 points to is directly the component type. In this case, the expression
2843 type may not match the corresponding FIELD_DECL type at this point, so we
2844 call "convert" here to fix that up if necessary. This type consistency is
2845 required, for instance because it ensures that possible later folding of
2846 component_refs against this constructor always yields something of the
2847 same type as the initial reference.
2849 Note that the call to "build_template" above is still fine, because it
2850 will only refer to the provided template_type in this case. */
2852 gnat_build_constructor
2853 (type
, tree_cons (TYPE_FIELDS (type
),
2854 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2855 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2856 template_addr
, NULL_TREE
)));
2859 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
2860 is something that is a fat pointer, so convert to it first if it EXPR
2861 is not already a fat pointer. */
2864 convert_to_thin_pointer (type
, expr
)
2868 if (! TYPE_FAT_POINTER_P (TREE_TYPE (expr
)))
2870 = convert_to_fat_pointer
2871 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))), expr
);
2873 /* We get the pointer to the data and use a NOP_EXPR to make it the
2876 = build_component_ref (expr
, NULL_TREE
, TYPE_FIELDS (TREE_TYPE (expr
)), 0);
2877 expr
= build1 (NOP_EXPR
, type
, expr
);
2882 /* Create an expression whose value is that of EXPR,
2883 converted to type TYPE. The TREE_TYPE of the value
2884 is always TYPE. This function implements all reasonable
2885 conversions; callers should filter out those that are
2886 not permitted by the language being compiled. */
2889 convert (type
, expr
)
2892 enum tree_code code
= TREE_CODE (type
);
2893 tree etype
= TREE_TYPE (expr
);
2894 enum tree_code ecode
= TREE_CODE (etype
);
2897 /* If EXPR is already the right type, we are done. */
2900 /* If we're converting between two aggregate types that have the same main
2901 variant, just make a NOP_EXPR. */
2902 else if (AGGREGATE_TYPE_P (type
)
2903 && TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
))
2904 return build1 (NOP_EXPR
, type
, expr
);
2905 /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
2907 else if (TREE_CODE (expr
) == WITH_RECORD_EXPR
)
2908 return build (WITH_RECORD_EXPR
, type
,
2909 convert (type
, TREE_OPERAND (expr
, 0)),
2910 TREE_OPERAND (expr
, 1));
2912 /* If the input type has padding, remove it by doing a component reference
2913 to the field. If the output type has padding, make a constructor
2914 to build the record. If both input and output have padding and are
2915 of variable size, do this as an unchecked conversion. */
2916 else if (ecode
== RECORD_TYPE
&& code
== RECORD_TYPE
2917 && TYPE_IS_PADDING_P (type
) && TYPE_IS_PADDING_P (etype
)
2918 && (! TREE_CONSTANT (TYPE_SIZE (type
))
2919 || ! TREE_CONSTANT (TYPE_SIZE (etype
))))
2921 else if (ecode
== RECORD_TYPE
&& TYPE_IS_PADDING_P (etype
))
2923 /* If we have just converted to this padded type, just get
2924 the inner expression. */
2925 if (TREE_CODE (expr
) == CONSTRUCTOR
2926 && CONSTRUCTOR_ELTS (expr
) != 0
2927 && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr
)) == TYPE_FIELDS (etype
))
2928 return TREE_VALUE (CONSTRUCTOR_ELTS (expr
));
2930 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2931 TYPE_FIELDS (etype
), 0));
2933 else if (code
== RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
2935 /* If we previously converted from another type and our type is
2936 of variable size, remove the conversion to avoid the need for
2937 variable-size temporaries. */
2938 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
2939 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2940 expr
= TREE_OPERAND (expr
, 0);
2942 /* If we are just removing the padding from expr, convert the original
2943 object if we have variable size. That will avoid the need
2944 for some variable-size temporaries. */
2945 if (TREE_CODE (expr
) == COMPONENT_REF
2946 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == RECORD_TYPE
2947 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr
, 0)))
2948 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2949 return convert (type
, TREE_OPERAND (expr
, 0));
2951 /* If the result type is a padded type with a self-referentially-sized
2952 field and the expression type is a record, do this as an
2953 unchecked converstion. */
2954 else if (TREE_CODE (etype
) == RECORD_TYPE
2955 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type
))))
2956 return unchecked_convert (type
, expr
, 0);
2960 gnat_build_constructor (type
,
2961 tree_cons (TYPE_FIELDS (type
),
2963 (TYPE_FIELDS (type
)),
2968 /* If the input is a biased type, adjust first. */
2969 if (ecode
== INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype
))
2970 return convert (type
, fold (build (PLUS_EXPR
, TREE_TYPE (etype
),
2971 fold (build1 (GNAT_NOP_EXPR
,
2972 TREE_TYPE (etype
), expr
)),
2973 TYPE_MIN_VALUE (etype
))));
2975 /* If the input is a left-justified modular type, we need to extract
2976 the actual object before converting it to any other type with the
2977 exception of an unconstrained array. */
2978 if (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)
2979 && code
!= UNCONSTRAINED_ARRAY_TYPE
)
2980 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2981 TYPE_FIELDS (etype
), 0));
2983 /* If converting to a type that contains a template, convert to the data
2984 type and then build the template. */
2985 if (code
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type
))
2987 tree obj_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2989 /* If the source already has a template, get a reference to the
2990 associated array only, as we are going to rebuild a template
2991 for the target type anyway. */
2992 expr
= maybe_unconstrained_array (expr
);
2995 gnat_build_constructor
2997 tree_cons (TYPE_FIELDS (type
),
2998 build_template (TREE_TYPE (TYPE_FIELDS (type
)),
2999 obj_type
, NULL_TREE
),
3000 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
3001 convert (obj_type
, expr
), NULL_TREE
)));
3004 /* There are some special cases of expressions that we process
3006 switch (TREE_CODE (expr
))
3011 case TRANSFORM_EXPR
:
3013 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
3014 conversion in gnat_expand_expr. NULL_EXPR does not represent
3015 and actual value, so no conversion is needed. */
3016 expr
= copy_node (expr
);
3017 TREE_TYPE (expr
) = type
;
3022 /* If we are converting a STRING_CST to another constrained array type,
3023 just make a new one in the proper type. Likewise for a
3025 if (code
== ecode
&& AGGREGATE_TYPE_P (etype
)
3026 && ! (TREE_CODE (TYPE_SIZE (etype
)) == INTEGER_CST
3027 && TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
))
3029 expr
= copy_node (expr
);
3030 TREE_TYPE (expr
) = type
;
3036 /* If we are converting between two aggregate types of the same
3037 kind, size, mode, and alignment, just make a new COMPONENT_REF.
3038 This avoid unneeded conversions which makes reference computations
3040 if (code
== ecode
&& TYPE_MODE (type
) == TYPE_MODE (etype
)
3041 && AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
3042 && TYPE_ALIGN (type
) == TYPE_ALIGN (etype
)
3043 && operand_equal_p (TYPE_SIZE (type
), TYPE_SIZE (etype
), 0))
3044 return build (COMPONENT_REF
, type
, TREE_OPERAND (expr
, 0),
3045 TREE_OPERAND (expr
, 1));
3049 case UNCONSTRAINED_ARRAY_REF
:
3050 /* Convert this to the type of the inner array by getting the address of
3051 the array from the template. */
3052 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3053 build_component_ref (TREE_OPERAND (expr
, 0),
3054 get_identifier ("P_ARRAY"),
3056 etype
= TREE_TYPE (expr
);
3057 ecode
= TREE_CODE (etype
);
3060 case VIEW_CONVERT_EXPR
:
3061 if (AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
3062 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
3063 return convert (type
, TREE_OPERAND (expr
, 0));
3067 /* If both types are record types, just convert the pointer and
3068 make a new INDIRECT_REF.
3070 ??? Disable this for now since it causes problems with the
3071 code in build_binary_op for MODIFY_EXPR which wants to
3072 strip off conversions. But that code really is a mess and
3073 we need to do this a much better way some time. */
3075 && (TREE_CODE (type
) == RECORD_TYPE
3076 || TREE_CODE (type
) == UNION_TYPE
)
3077 && (TREE_CODE (etype
) == RECORD_TYPE
3078 || TREE_CODE (etype
) == UNION_TYPE
)
3079 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
3080 return build_unary_op (INDIRECT_REF
, NULL_TREE
,
3081 convert (build_pointer_type (type
),
3082 TREE_OPERAND (expr
, 0)));
3089 /* Check for converting to a pointer to an unconstrained array. */
3090 if (TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
3091 return convert_to_fat_pointer (type
, expr
);
3093 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
)
3094 || (code
== INTEGER_CST
&& ecode
== INTEGER_CST
3095 && (type
== TREE_TYPE (etype
) || etype
== TREE_TYPE (type
))))
3096 return fold (build1 (NOP_EXPR
, type
, expr
));
3101 return build1 (CONVERT_EXPR
, type
, expr
);
3104 if (TYPE_HAS_ACTUAL_BOUNDS_P (type
)
3105 && (ecode
== ARRAY_TYPE
|| ecode
== UNCONSTRAINED_ARRAY_TYPE
3106 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))))
3107 return unchecked_convert (type
, expr
, 0);
3108 else if (TYPE_BIASED_REPRESENTATION_P (type
))
3109 return fold (build1 (CONVERT_EXPR
, type
,
3110 fold (build (MINUS_EXPR
, TREE_TYPE (type
),
3111 convert (TREE_TYPE (type
), expr
),
3112 TYPE_MIN_VALUE (type
)))));
3114 /* ... fall through ... */
3117 return fold (convert_to_integer (type
, expr
));
3120 case REFERENCE_TYPE
:
3121 /* If converting between two pointers to records denoting
3122 both a template and type, adjust if needed to account
3123 for any differing offsets, since one might be negative. */
3124 if (TYPE_THIN_POINTER_P (etype
) && TYPE_THIN_POINTER_P (type
))
3127 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype
))),
3128 bit_position (TYPE_FIELDS (TREE_TYPE (type
))));
3129 tree byte_diff
= size_binop (CEIL_DIV_EXPR
, bit_diff
,
3130 sbitsize_int (BITS_PER_UNIT
));
3132 expr
= build1 (NOP_EXPR
, type
, expr
);
3133 TREE_CONSTANT (expr
) = TREE_CONSTANT (TREE_OPERAND (expr
, 0));
3134 if (integer_zerop (byte_diff
))
3137 return build_binary_op (PLUS_EXPR
, type
, expr
,
3138 fold (convert_to_pointer (type
, byte_diff
)));
3141 /* If converting to a thin pointer, handle specially. */
3142 if (TYPE_THIN_POINTER_P (type
)
3143 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)) != 0)
3144 return convert_to_thin_pointer (type
, expr
);
3146 /* If converting fat pointer to normal pointer, get the pointer to the
3147 array and then convert it. */
3148 else if (TYPE_FAT_POINTER_P (etype
))
3149 expr
= build_component_ref (expr
, get_identifier ("P_ARRAY"),
3152 return fold (convert_to_pointer (type
, expr
));
3155 return fold (convert_to_real (type
, expr
));
3158 if (TYPE_LEFT_JUSTIFIED_MODULAR_P (type
) && ! AGGREGATE_TYPE_P (etype
))
3160 gnat_build_constructor
3161 (type
, tree_cons (TYPE_FIELDS (type
),
3162 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
3165 /* ... fall through ... */
3168 /* In these cases, assume the front-end has validated the conversion.
3169 If the conversion is valid, it will be a bit-wise conversion, so
3170 it can be viewed as an unchecked conversion. */
3171 return unchecked_convert (type
, expr
, 0);
3174 /* Just validate that the type is indeed that of a field
3175 of the type. Then make the simple conversion. */
3176 for (tem
= TYPE_FIELDS (type
); tem
; tem
= TREE_CHAIN (tem
))
3178 if (TREE_TYPE (tem
) == etype
)
3179 return build1 (CONVERT_EXPR
, type
, expr
);
3180 else if (TREE_CODE (TREE_TYPE (tem
)) == RECORD_TYPE
3181 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (tem
))
3182 || TYPE_IS_PADDING_P (TREE_TYPE (tem
)))
3183 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem
))) == etype
)
3184 return build1 (CONVERT_EXPR
, type
,
3185 convert (TREE_TYPE (tem
), expr
));
3190 case UNCONSTRAINED_ARRAY_TYPE
:
3191 /* If EXPR is a constrained array, take its address, convert it to a
3192 fat pointer, and then dereference it. Likewise if EXPR is a
3193 record containing both a template and a constrained array.
3194 Note that a record representing a left justified modular type
3195 always represents a packed constrained array. */
3196 if (ecode
== ARRAY_TYPE
3197 || (ecode
== INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (etype
))
3198 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))
3199 || (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)))
3202 (INDIRECT_REF
, NULL_TREE
,
3203 convert_to_fat_pointer (TREE_TYPE (type
),
3204 build_unary_op (ADDR_EXPR
,
3207 /* Do something very similar for converting one unconstrained
3208 array to another. */
3209 else if (ecode
== UNCONSTRAINED_ARRAY_TYPE
)
3211 build_unary_op (INDIRECT_REF
, NULL_TREE
,
3212 convert (TREE_TYPE (type
),
3213 build_unary_op (ADDR_EXPR
,
3219 return fold (convert_to_complex (type
, expr
));
3226 /* Remove all conversions that are done in EXP. This includes converting
3227 from a padded type or to a left-justified modular type. If TRUE_ADDRESS
3228 is nonzero, always return the address of the containing object even if
3229 the address is not bit-aligned. */
3232 remove_conversions (exp
, true_address
)
3236 switch (TREE_CODE (exp
))
3240 && TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
3241 && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp
)))
3242 return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp
)), 1);
3246 if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp
, 0))) == RECORD_TYPE
3247 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp
, 0))))
3248 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3251 case VIEW_CONVERT_EXPR
: case NON_LVALUE_EXPR
:
3252 case NOP_EXPR
: case CONVERT_EXPR
: case GNAT_NOP_EXPR
:
3253 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3262 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3263 refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
3264 likewise return an expression pointing to the underlying array. */
3267 maybe_unconstrained_array (exp
)
3270 enum tree_code code
= TREE_CODE (exp
);
3273 switch (TREE_CODE (TREE_TYPE (exp
)))
3275 case UNCONSTRAINED_ARRAY_TYPE
:
3276 if (code
== UNCONSTRAINED_ARRAY_REF
)
3279 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
3280 build_component_ref (TREE_OPERAND (exp
, 0),
3281 get_identifier ("P_ARRAY"),
3283 TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp
);
3287 else if (code
== NULL_EXPR
)
3288 return build1 (NULL_EXPR
,
3289 TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3290 (TREE_TYPE (TREE_TYPE (exp
))))),
3291 TREE_OPERAND (exp
, 0));
3293 else if (code
== WITH_RECORD_EXPR
3294 && (TREE_OPERAND (exp
, 0)
3295 != (new = maybe_unconstrained_array
3296 (TREE_OPERAND (exp
, 0)))))
3297 return build (WITH_RECORD_EXPR
, TREE_TYPE (new), new,
3298 TREE_OPERAND (exp
, 1));
3301 /* If this is a padded type, convert to the unpadded type and see if
3302 it contains a template. */
3303 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
3305 new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
3306 if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3307 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
3309 build_component_ref (new, NULL_TREE
,
3310 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
3313 else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp
)))
3315 build_component_ref (exp
, NULL_TREE
,
3316 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp
))), 0);
3326 /* Return an expression that does an unchecked converstion of EXPR to TYPE.
3327 If NOTRUNC_P is set, truncation operations should be suppressed. */
3330 unchecked_convert (type
, expr
, notrunc_p
)
3335 tree etype
= TREE_TYPE (expr
);
3337 /* If the expression is already the right type, we are done. */
3341 /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
3343 if (TREE_CODE (expr
) == WITH_RECORD_EXPR
)
3344 return build (WITH_RECORD_EXPR
, type
,
3345 unchecked_convert (type
, TREE_OPERAND (expr
, 0), notrunc_p
),
3346 TREE_OPERAND (expr
, 1));
3348 /* If both types types are integral just do a normal conversion.
3349 Likewise for a conversion to an unconstrained array. */
3350 if ((((INTEGRAL_TYPE_P (type
)
3351 && ! (TREE_CODE (type
) == INTEGER_TYPE
3352 && TYPE_VAX_FLOATING_POINT_P (type
)))
3353 || (POINTER_TYPE_P (type
) && ! TYPE_THIN_POINTER_P (type
))
3354 || (TREE_CODE (type
) == RECORD_TYPE
3355 && TYPE_LEFT_JUSTIFIED_MODULAR_P (type
)))
3356 && ((INTEGRAL_TYPE_P (etype
)
3357 && ! (TREE_CODE (etype
) == INTEGER_TYPE
3358 && TYPE_VAX_FLOATING_POINT_P (etype
)))
3359 || (POINTER_TYPE_P (etype
) && ! TYPE_THIN_POINTER_P (etype
))
3360 || (TREE_CODE (etype
) == RECORD_TYPE
3361 && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
))))
3362 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3366 if (TREE_CODE (etype
) == INTEGER_TYPE
3367 && TYPE_BIASED_REPRESENTATION_P (etype
))
3369 tree ntype
= copy_type (etype
);
3371 TYPE_BIASED_REPRESENTATION_P (ntype
) = 0;
3372 TYPE_MAIN_VARIANT (ntype
) = ntype
;
3373 expr
= build1 (GNAT_NOP_EXPR
, ntype
, expr
);
3376 if (TREE_CODE (type
) == INTEGER_TYPE
3377 && TYPE_BIASED_REPRESENTATION_P (type
))
3379 rtype
= copy_type (type
);
3380 TYPE_BIASED_REPRESENTATION_P (rtype
) = 0;
3381 TYPE_MAIN_VARIANT (rtype
) = rtype
;
3384 expr
= convert (rtype
, expr
);
3386 expr
= build1 (GNAT_NOP_EXPR
, type
, expr
);
3389 /* If we are converting TO an integral type whose precision is not the
3390 same as its size, first unchecked convert to a record that contains
3391 an object of the output type. Then extract the field. */
3392 else if (INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3393 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3394 GET_MODE_BITSIZE (TYPE_MODE (type
))))
3396 tree rec_type
= make_node (RECORD_TYPE
);
3397 tree field
= create_field_decl (get_identifier ("OBJ"), type
,
3398 rec_type
, 1, 0, 0, 0);
3400 TYPE_FIELDS (rec_type
) = field
;
3401 layout_type (rec_type
);
3403 expr
= unchecked_convert (rec_type
, expr
, notrunc_p
);
3404 expr
= build_component_ref (expr
, NULL_TREE
, field
, 0);
3407 /* Similarly for integral input type whose precision is not equal to its
3409 else if (INTEGRAL_TYPE_P (etype
) && TYPE_RM_SIZE (etype
) != 0
3410 && 0 != compare_tree_int (TYPE_RM_SIZE (etype
),
3411 GET_MODE_BITSIZE (TYPE_MODE (etype
))))
3413 tree rec_type
= make_node (RECORD_TYPE
);
3415 = create_field_decl (get_identifier ("OBJ"), etype
, rec_type
,
3418 TYPE_FIELDS (rec_type
) = field
;
3419 layout_type (rec_type
);
3421 expr
= gnat_build_constructor (rec_type
, build_tree_list (field
, expr
));
3422 expr
= unchecked_convert (type
, expr
, notrunc_p
);
3425 /* We have a special case when we are converting between two
3426 unconstrained array types. In that case, take the address,
3427 convert the fat pointer types, and dereference. */
3428 else if (TREE_CODE (etype
) == UNCONSTRAINED_ARRAY_TYPE
3429 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3430 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3431 build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (type
),
3432 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3436 expr
= maybe_unconstrained_array (expr
);
3437 etype
= TREE_TYPE (expr
);
3438 expr
= build1 (VIEW_CONVERT_EXPR
, type
, expr
);
3441 /* If the result is an integral type whose size is not equal to
3442 the size of the underlying machine type, sign- or zero-extend
3443 the result. We need not do this in the case where the input is
3444 an integral type of the same precision and signedness or if the output
3445 is a biased type or if both the input and output are unsigned. */
3447 && INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3448 && ! (TREE_CODE (type
) == INTEGER_TYPE
3449 && TYPE_BIASED_REPRESENTATION_P (type
))
3450 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3451 GET_MODE_BITSIZE (TYPE_MODE (type
)))
3452 && ! (INTEGRAL_TYPE_P (etype
)
3453 && TREE_UNSIGNED (type
) == TREE_UNSIGNED (etype
)
3454 && operand_equal_p (TYPE_RM_SIZE (type
),
3455 (TYPE_RM_SIZE (etype
) != 0
3456 ? TYPE_RM_SIZE (etype
) : TYPE_SIZE (etype
)),
3458 && ! (TREE_UNSIGNED (type
) && TREE_UNSIGNED (etype
)))
3460 tree base_type
= gnat_type_for_mode (TYPE_MODE (type
),
3461 TREE_UNSIGNED (type
));
3463 = convert (base_type
,
3464 size_binop (MINUS_EXPR
,
3466 (GET_MODE_BITSIZE (TYPE_MODE (type
))),
3467 TYPE_RM_SIZE (type
)));
3470 build_binary_op (RSHIFT_EXPR
, base_type
,
3471 build_binary_op (LSHIFT_EXPR
, base_type
,
3472 convert (base_type
, expr
),
3477 /* An unchecked conversion should never raise Constraint_Error. The code
3478 below assumes that GCC's conversion routines overflow the same way that
3479 the underlying hardware does. This is probably true. In the rare case
3480 when it is false, we can rely on the fact that such conversions are
3481 erroneous anyway. */
3482 if (TREE_CODE (expr
) == INTEGER_CST
)
3483 TREE_OVERFLOW (expr
) = TREE_CONSTANT_OVERFLOW (expr
) = 0;
3485 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3486 show no longer constant. */
3487 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
3488 && ! operand_equal_p (TYPE_SIZE_UNIT (type
), TYPE_SIZE_UNIT (etype
), 1))
3489 TREE_CONSTANT (expr
) = 0;
3494 #include "gt-ada-utils.h"
3495 #include "gtype-ada.h"