1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
10 * Copyright (C) 1992-2003, Free Software Foundation, Inc. *
12 * GNAT is free software; you can redistribute it and/or modify it under *
13 * terms of the GNU General Public License as published by the Free Soft- *
14 * ware Foundation; either version 2, or (at your option) any later ver- *
15 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
16 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
17 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
18 * for more details. You should have received a copy of the GNU General *
19 * Public License distributed with GNAT; see file COPYING. If not, write *
20 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
21 * MA 02111-1307, USA. *
23 * GNAT was originally developed by the GNAT team at New York University. *
24 * Extensive contributions were provided by Ada Core Technologies Inc. *
26 ****************************************************************************/
30 #include "coretypes.h"
55 #ifndef MAX_FIXED_MODE_SIZE
56 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
59 #ifndef MAX_BITS_PER_WORD
60 #define MAX_BITS_PER_WORD BITS_PER_WORD
63 /* If nonzero, pretend we are allocating at global level. */
66 /* Tree nodes for the various types and decls we create. */
67 tree gnat_std_decls
[(int) ADT_LAST
];
69 /* Functions to call for each of the possible raise reasons. */
70 tree gnat_raise_decls
[(int) LAST_REASON_CODE
+ 1];
72 /* Associates a GNAT tree node to a GCC tree node. It is used in
73 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
74 of `save_gnu_tree' for more info. */
75 static GTY((length ("max_gnat_nodes"))) tree
*associate_gnat_to_gnu
;
77 /* This listhead is used to record any global objects that need elaboration.
78 TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
79 initial value to assign. */
81 static GTY(()) tree pending_elaborations
;
83 /* This stack allows us to momentarily switch to generating elaboration
84 lists for an inner context. */
86 struct e_stack
GTY(()) {
90 static GTY(()) struct e_stack
*elist_stack
;
92 /* This variable keeps a table for types for each precision so that we only
93 allocate each of them once. Signed and unsigned types are kept separate.
95 Note that these types are only used when fold-const requests something
96 special. Perhaps we should NOT share these types; we'll see how it
98 static GTY(()) tree signed_and_unsigned_types
[2 * MAX_BITS_PER_WORD
+ 1][2];
100 /* Likewise for float types, but record these by mode. */
101 static GTY(()) tree float_types
[NUM_MACHINE_MODES
];
103 /* For each binding contour we allocate a binding_level structure which records
104 the entities defined or declared in that contour. Contours include:
107 one for each subprogram definition
108 one for each compound statement (declare block)
110 Binding contours are used to create GCC tree BLOCK nodes. */
112 struct binding_level
GTY(())
114 /* A chain of ..._DECL nodes for all variables, constants, functions,
115 parameters and type declarations. These ..._DECL nodes are chained
116 through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
117 in the reverse of the order supplied to be compatible with the
120 /* For each level (except the global one), a chain of BLOCK nodes for all
121 the levels that were entered and exited one level down from this one. */
123 /* The BLOCK node for this level, if one has been preallocated.
124 If 0, the BLOCK is allocated (if needed) when the level is popped. */
126 /* The binding level containing this one (the enclosing binding level). */
127 struct binding_level
*level_chain
;
130 /* The binding level currently in effect. */
131 static GTY(()) struct binding_level
*current_binding_level
;
133 /* A chain of binding_level structures awaiting reuse. */
134 static GTY((deletable (""))) struct binding_level
*free_binding_level
;
136 /* The outermost binding level. This binding level is created when the
137 compiler is started and it will exist through the entire compilation. */
138 static struct binding_level
*global_binding_level
;
140 /* Binding level structures are initialized by copying this one. */
141 static struct binding_level clear_binding_level
= {NULL
, NULL
, NULL
, NULL
};
143 struct language_function
GTY(())
148 static tree merge_sizes
PARAMS ((tree
, tree
, tree
, int, int));
149 static tree compute_related_constant
PARAMS ((tree
, tree
));
150 static tree split_plus
PARAMS ((tree
, tree
*));
151 static int value_zerop
PARAMS ((tree
));
152 static tree float_type_for_size
PARAMS ((int, enum machine_mode
));
153 static tree convert_to_fat_pointer
PARAMS ((tree
, tree
));
154 static tree convert_to_thin_pointer
PARAMS ((tree
, tree
));
155 static tree make_descriptor_field
PARAMS ((const char *,tree
, tree
,
158 /* Initialize the association of GNAT nodes to GCC trees. */
165 associate_gnat_to_gnu
= (tree
*) ggc_alloc (max_gnat_nodes
* sizeof (tree
));
167 for (gnat_node
= 0; gnat_node
< max_gnat_nodes
; gnat_node
++)
168 associate_gnat_to_gnu
[gnat_node
] = NULL_TREE
;
170 pending_elaborations
= build_tree_list (NULL_TREE
, NULL_TREE
);
173 /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
174 which is to be associated with GNAT_ENTITY. Such GCC tree node is always
175 a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
177 If GNU_DECL is zero, a previous association is to be reset. */
180 save_gnu_tree (gnat_entity
, gnu_decl
, no_check
)
181 Entity_Id gnat_entity
;
186 && (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]
187 || (! no_check
&& ! DECL_P (gnu_decl
))))
190 associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] = gnu_decl
;
193 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
194 Return the ..._DECL node that was associated with it. If there is no tree
195 node associated with GNAT_ENTITY, abort.
197 In some cases, such as delayed elaboration or expressions that need to
198 be elaborated only once, GNAT_ENTITY is really not an entity. */
201 get_gnu_tree (gnat_entity
)
202 Entity_Id gnat_entity
;
204 if (! associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
])
207 return associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
];
210 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
213 present_gnu_tree (gnat_entity
)
214 Entity_Id gnat_entity
;
216 return (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] != NULL_TREE
);
220 /* Return non-zero if we are currently in the global binding level. */
225 return (force_global
!= 0 || current_binding_level
== global_binding_level
229 /* Return the list of declarations in the current level. Note that this list
230 is in reverse order (it has to be so for back-end compatibility). */
235 return current_binding_level
->names
;
238 /* Nonzero if the current level needs to have a BLOCK made. */
243 return (current_binding_level
->names
!= 0);
246 /* Enter a new binding level. The input parameter is ignored, but has to be
247 specified for back-end compatibility. */
251 int ignore ATTRIBUTE_UNUSED
;
253 struct binding_level
*newlevel
= NULL
;
255 /* Reuse a struct for this binding level, if there is one. */
256 if (free_binding_level
)
258 newlevel
= free_binding_level
;
259 free_binding_level
= free_binding_level
->level_chain
;
263 = (struct binding_level
*) ggc_alloc (sizeof (struct binding_level
));
265 *newlevel
= clear_binding_level
;
267 /* Add this level to the front of the chain (stack) of levels that are
269 newlevel
->level_chain
= current_binding_level
;
270 current_binding_level
= newlevel
;
273 /* Exit a binding level.
274 Pop the level off, and restore the state of the identifier-decl mappings
275 that were in effect when this level was entered.
277 If KEEP is nonzero, this level had explicit declarations, so
278 and create a "block" (a BLOCK node) for the level
279 to record its declarations and subblocks for symbol table output.
281 If FUNCTIONBODY is nonzero, this level is the body of a function,
282 so create a block as if KEEP were set and also clear out all
285 If REVERSE is nonzero, reverse the order of decls before putting
286 them into the BLOCK. */
289 poplevel (keep
, reverse
, functionbody
)
294 /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
295 binding level that we are about to exit and which is returned by this
297 tree block
= NULL_TREE
;
300 tree subblock_chain
= current_binding_level
->blocks
;
302 int block_previously_created
;
304 /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL
305 nodes chained through the `names' field of current_binding_level are in
306 reverse order except for PARM_DECL node, which are explicitly stored in
308 current_binding_level
->names
309 = decl_chain
= (reverse
) ? nreverse (current_binding_level
->names
)
310 : current_binding_level
->names
;
312 /* Output any nested inline functions within this block which must be
313 compiled because their address is needed. */
314 for (decl_node
= decl_chain
; decl_node
; decl_node
= TREE_CHAIN (decl_node
))
315 if (TREE_CODE (decl_node
) == FUNCTION_DECL
316 && ! TREE_ASM_WRITTEN (decl_node
) && TREE_ADDRESSABLE (decl_node
)
317 && DECL_INITIAL (decl_node
) != 0)
319 push_function_context ();
320 output_inline_function (decl_node
);
321 pop_function_context ();
325 block_previously_created
= (current_binding_level
->this_block
!= 0);
326 if (block_previously_created
)
327 block
= current_binding_level
->this_block
;
328 else if (keep
|| functionbody
)
329 block
= make_node (BLOCK
);
332 BLOCK_VARS (block
) = keep
? decl_chain
: 0;
333 BLOCK_SUBBLOCKS (block
) = subblock_chain
;
336 /* Record the BLOCK node just built as the subblock its enclosing scope. */
337 for (subblock_node
= subblock_chain
; subblock_node
;
338 subblock_node
= TREE_CHAIN (subblock_node
))
339 BLOCK_SUPERCONTEXT (subblock_node
) = block
;
341 /* Clear out the meanings of the local variables of this level. */
343 for (subblock_node
= decl_chain
; subblock_node
;
344 subblock_node
= TREE_CHAIN (subblock_node
))
345 if (DECL_NAME (subblock_node
) != 0)
346 /* If the identifier was used or addressed via a local extern decl,
347 don't forget that fact. */
348 if (DECL_EXTERNAL (subblock_node
))
350 if (TREE_USED (subblock_node
))
351 TREE_USED (DECL_NAME (subblock_node
)) = 1;
352 if (TREE_ADDRESSABLE (subblock_node
))
353 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node
)) = 1;
357 /* Pop the current level, and free the structure for reuse. */
358 struct binding_level
*level
= current_binding_level
;
359 current_binding_level
= current_binding_level
->level_chain
;
360 level
->level_chain
= free_binding_level
;
361 free_binding_level
= level
;
366 /* This is the top level block of a function. The ..._DECL chain stored
367 in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
368 leave them in the BLOCK because they are found in the FUNCTION_DECL
370 DECL_INITIAL (current_function_decl
) = block
;
371 BLOCK_VARS (block
) = 0;
375 if (!block_previously_created
)
376 current_binding_level
->blocks
377 = chainon (current_binding_level
->blocks
, block
);
380 /* If we did not make a block for the level just exited, any blocks made for
381 inner levels (since they cannot be recorded as subblocks in that level)
382 must be carried forward so they will later become subblocks of something
384 else if (subblock_chain
)
385 current_binding_level
->blocks
386 = chainon (current_binding_level
->blocks
, subblock_chain
);
388 TREE_USED (block
) = 1;
393 /* Insert BLOCK at the end of the list of subblocks of the
394 current binding level. This is used when a BIND_EXPR is expanded,
395 to handle the BLOCK node inside the BIND_EXPR. */
401 TREE_USED (block
) = 1;
402 current_binding_level
->blocks
403 = chainon (current_binding_level
->blocks
, block
);
406 /* Set the BLOCK node for the innermost scope
407 (the one we are currently in). */
413 current_binding_level
->this_block
= block
;
414 current_binding_level
->names
= chainon (current_binding_level
->names
,
416 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
417 BLOCK_SUBBLOCKS (block
));
420 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
421 Returns the ..._DECL node. */
427 struct binding_level
*b
;
429 /* If at top level, there is no context. But PARM_DECLs always go in the
430 level of its function. */
431 if (global_bindings_p () && TREE_CODE (decl
) != PARM_DECL
)
433 b
= global_binding_level
;
434 DECL_CONTEXT (decl
) = 0;
438 b
= current_binding_level
;
439 DECL_CONTEXT (decl
) = current_function_decl
;
442 /* Put the declaration on the list. The list of declarations is in reverse
443 order. The list will be reversed later if necessary. This needs to be
444 this way for compatibility with the back-end.
446 Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They
447 will cause trouble with the debugger and aren't needed anyway. */
448 if (TREE_CODE (decl
) != TYPE_DECL
449 || TREE_CODE (TREE_TYPE (decl
)) != UNCONSTRAINED_ARRAY_TYPE
)
451 TREE_CHAIN (decl
) = b
->names
;
455 /* For the declaration of a type, set its name if it either is not already
456 set, was set to an IDENTIFIER_NODE, indicating an internal name,
457 or if the previous type name was not derived from a source name.
458 We'd rather have the type named with a real name and all the pointer
459 types to the same object have the same POINTER_TYPE node. Code in this
460 function in c-decl.c makes a copy of the type node here, but that may
461 cause us trouble with incomplete types, so let's not try it (at least
464 if (TREE_CODE (decl
) == TYPE_DECL
465 && DECL_NAME (decl
) != 0
466 && (TYPE_NAME (TREE_TYPE (decl
)) == 0
467 || TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == IDENTIFIER_NODE
468 || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == TYPE_DECL
469 && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl
)))
470 && ! DECL_ARTIFICIAL (decl
))))
471 TYPE_NAME (TREE_TYPE (decl
)) = decl
;
476 /* Do little here. Set up the standard declarations later after the
477 front end has been run. */
480 gnat_init_decl_processing ()
484 /* Make the binding_level structure for global names. */
485 current_function_decl
= 0;
486 current_binding_level
= 0;
487 free_binding_level
= 0;
489 global_binding_level
= current_binding_level
;
491 build_common_tree_nodes (0);
493 /* In Ada, we use a signed type for SIZETYPE. Use the signed type
494 corresponding to the size of ptr_mode. Make this here since we need
495 this before we can expand the GNAT types. */
496 set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (ptr_mode
), 0));
497 build_common_tree_nodes_2 (0);
499 pushdecl (build_decl (TYPE_DECL
, get_identifier (SIZE_TYPE
), sizetype
));
501 /* We need to make the integer type before doing anything else.
502 We stitch this in to the appropriate GNAT type later. */
503 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
505 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
508 ptr_void_type_node
= build_pointer_type (void_type_node
);
512 /* Create the predefined scalar types such as `integer_type_node' needed
513 in the gcc back-end and initialize the global binding level. */
516 init_gigi_decls (long_long_float_type
, exception_type
)
517 tree long_long_float_type
, exception_type
;
522 /* Set the types that GCC and Gigi use from the front end. We would like
523 to do this for char_type_node, but it needs to correspond to the C
525 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
527 /* In this case, the builtin floating point types are VAX float,
528 so make up a type for use. */
529 longest_float_type_node
= make_node (REAL_TYPE
);
530 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
531 layout_type (longest_float_type_node
);
532 pushdecl (build_decl (TYPE_DECL
, get_identifier ("longest float type"),
533 longest_float_type_node
));
536 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
538 except_type_node
= TREE_TYPE (exception_type
);
540 unsigned_type_node
= gnat_type_for_size (INT_TYPE_SIZE
, 1);
541 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
542 unsigned_type_node
));
545 = pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
548 void_ftype
= build_function_type (void_type_node
, NULL_TREE
);
549 ptr_void_ftype
= build_pointer_type (void_ftype
);
551 /* Now declare runtime functions. */
552 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
554 /* malloc is a function declaration tree for a function to allocate
556 malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"),
558 build_function_type (ptr_void_type_node
,
559 tree_cons (NULL_TREE
,
562 NULL_TREE
, 0, 1, 1, 0);
564 /* free is a function declaration tree for a function to free memory. */
567 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
568 build_function_type (void_type_node
,
569 tree_cons (NULL_TREE
,
572 NULL_TREE
, 0, 1, 1, 0);
574 /* Make the types and functions used for exception processing. */
576 = build_array_type (gnat_type_for_mode (Pmode
, 0),
577 build_index_type (build_int_2 (5, 0)));
578 pushdecl (build_decl (TYPE_DECL
, get_identifier ("JMPBUF_T"), jmpbuf_type
));
579 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
581 /* Functions to get and set the jumpbuf pointer for the current thread. */
583 = create_subprog_decl
584 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
585 NULL_TREE
, build_function_type (jmpbuf_ptr_type
, NULL_TREE
),
586 NULL_TREE
, 0, 1, 1, 0);
589 = create_subprog_decl
590 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
592 build_function_type (void_type_node
,
593 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
594 NULL_TREE
, 0, 1, 1, 0);
596 /* Function to get the current exception. */
598 = create_subprog_decl
599 (get_identifier ("system__soft_links__get_gnat_exception"),
601 build_function_type (build_pointer_type (except_type_node
), NULL_TREE
),
602 NULL_TREE
, 0, 1, 1, 0);
604 /* Functions that raise exceptions. */
606 = create_subprog_decl
607 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
608 build_function_type (void_type_node
,
609 tree_cons (NULL_TREE
,
610 build_pointer_type (except_type_node
),
612 NULL_TREE
, 0, 1, 1, 0);
614 /* If in no exception handlers mode, all raise statements are redirected to
615 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
616 this procedure will never be called in this mode. */
617 if (No_Exception_Handlers_Set ())
620 = create_subprog_decl
621 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
622 build_function_type (void_type_node
,
623 tree_cons (NULL_TREE
,
624 build_pointer_type (char_type_node
),
625 tree_cons (NULL_TREE
,
628 NULL_TREE
, 0, 1, 1, 0);
630 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
631 gnat_raise_decls
[i
] = decl
;
634 /* Otherwise, make one decl for each exception reason. */
635 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
639 sprintf (name
, "__gnat_rcheck_%.2d", i
);
641 = create_subprog_decl
642 (get_identifier (name
), NULL_TREE
,
643 build_function_type (void_type_node
,
644 tree_cons (NULL_TREE
,
647 tree_cons (NULL_TREE
,
650 NULL_TREE
, 0, 1, 1, 0);
653 /* Indicate that these never return. */
654 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
655 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
656 TREE_TYPE (raise_nodefer_decl
)
657 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
660 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
662 TREE_THIS_VOLATILE (gnat_raise_decls
[i
]) = 1;
663 TREE_SIDE_EFFECTS (gnat_raise_decls
[i
]) = 1;
664 TREE_TYPE (gnat_raise_decls
[i
])
665 = build_qualified_type (TREE_TYPE (gnat_raise_decls
[i
]),
669 /* setjmp returns an integer and has one operand, which is a pointer to
672 = create_subprog_decl
673 (get_identifier ("setjmp"), NULL_TREE
,
674 build_function_type (integer_type_node
,
675 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
676 NULL_TREE
, 0, 1, 1, 0);
678 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
679 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
681 main_identifier_node
= get_identifier ("main");
684 /* This function is called indirectly from toplev.c to handle incomplete
685 declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
686 compile_file in toplev.c makes an indirect call through the function pointer
687 incomplete_decl_finalize_hook which is initialized to this routine in
688 init_decl_processing. */
691 gnat_finish_incomplete_decl (dont_care
)
692 tree dont_care ATTRIBUTE_UNUSED
;
697 /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
698 nodes (FIELDLIST), finish constructing the record or union type.
699 If HAS_REP is nonzero, this record has a rep clause; don't call
700 layout_type but merely set the size and alignment ourselves.
701 If DEFER_DEBUG is nonzero, do not call the debugging routines
702 on this type; it will be done later. */
705 finish_record_type (record_type
, fieldlist
, has_rep
, defer_debug
)
711 enum tree_code code
= TREE_CODE (record_type
);
712 tree ada_size
= bitsize_zero_node
;
713 tree size
= bitsize_zero_node
;
714 tree size_unit
= size_zero_node
;
718 TYPE_FIELDS (record_type
) = fieldlist
;
720 if (TYPE_NAME (record_type
) != 0
721 && TREE_CODE (TYPE_NAME (record_type
)) == TYPE_DECL
)
722 TYPE_STUB_DECL (record_type
) = TYPE_NAME (record_type
);
724 TYPE_STUB_DECL (record_type
)
725 = pushdecl (build_decl (TYPE_DECL
, TYPE_NAME (record_type
),
728 /* We don't need both the typedef name and the record name output in
729 the debugging information, since they are the same. */
730 DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type
)) = 1;
732 /* Globally initialize the record first. If this is a rep'ed record,
733 that just means some initializations; otherwise, layout the record. */
737 TYPE_ALIGN (record_type
) = MAX (BITS_PER_UNIT
, TYPE_ALIGN (record_type
));
738 TYPE_MODE (record_type
) = BLKmode
;
739 if (TYPE_SIZE (record_type
) == 0)
741 TYPE_SIZE (record_type
) = bitsize_zero_node
;
742 TYPE_SIZE_UNIT (record_type
) = size_zero_node
;
747 /* Ensure there isn't a size already set. There can be in an error
748 case where there is a rep clause but all fields have errors and
749 no longer have a position. */
750 TYPE_SIZE (record_type
) = 0;
751 layout_type (record_type
);
754 /* At this point, the position and size of each field is known. It was
755 either set before entry by a rep clause, or by laying out the type
756 above. We now make a pass through the fields (in reverse order for
757 QUAL_UNION_TYPEs) to compute the Ada size; the GCC size and alignment
758 (for rep'ed records that are not padding types); and the mode (for
761 if (code
== QUAL_UNION_TYPE
)
762 fieldlist
= nreverse (fieldlist
);
764 for (field
= fieldlist
; field
; field
= TREE_CHAIN (field
))
766 tree type
= TREE_TYPE (field
);
767 tree this_size
= DECL_SIZE (field
);
768 tree this_size_unit
= DECL_SIZE_UNIT (field
);
769 tree this_ada_size
= DECL_SIZE (field
);
771 /* We need to make an XVE/XVU record if any field has variable size,
772 whether or not the record does. For example, if we have an union,
773 it may be that all fields, rounded up to the alignment, have the
774 same size, in which case we'll use that size. But the debug
775 output routines (except Dwarf2) won't be able to output the fields,
776 so we need to make the special record. */
777 if (TREE_CODE (this_size
) != INTEGER_CST
)
780 if ((TREE_CODE (type
) == RECORD_TYPE
|| TREE_CODE (type
) == UNION_TYPE
781 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
782 && ! TYPE_IS_FAT_POINTER_P (type
)
783 && ! TYPE_CONTAINS_TEMPLATE_P (type
)
784 && TYPE_ADA_SIZE (type
) != 0)
785 this_ada_size
= TYPE_ADA_SIZE (type
);
787 if (has_rep
&& ! DECL_BIT_FIELD (field
))
788 TYPE_ALIGN (record_type
)
789 = MAX (TYPE_ALIGN (record_type
), DECL_ALIGN (field
));
794 ada_size
= size_binop (MAX_EXPR
, ada_size
, this_ada_size
);
795 size
= size_binop (MAX_EXPR
, size
, this_size
);
796 size_unit
= size_binop (MAX_EXPR
, size_unit
, this_size_unit
);
799 case QUAL_UNION_TYPE
:
801 = fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
802 this_ada_size
, ada_size
));
803 size
= fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
805 size_unit
= fold (build (COND_EXPR
, sizetype
, DECL_QUALIFIER (field
),
806 this_size_unit
, size_unit
));
810 /* Since we know here that all fields are sorted in order of
811 increasing bit position, the size of the record is one
812 higher than the ending bit of the last field processed
813 unless we have a rep clause, since in that case we might
814 have a field outside a QUAL_UNION_TYPE that has a higher ending
815 position. So use a MAX in that case. Also, if this field is a
816 QUAL_UNION_TYPE, we need to take into account the previous size in
817 the case of empty variants. */
819 = merge_sizes (ada_size
, bit_position (field
), this_ada_size
,
820 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
821 size
= merge_sizes (size
, bit_position (field
), this_size
,
822 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
824 = merge_sizes (size_unit
, byte_position (field
), this_size_unit
,
825 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
833 if (code
== QUAL_UNION_TYPE
)
834 nreverse (fieldlist
);
836 /* If this is a padding record, we never want to make the size smaller than
837 what was specified in it, if any. */
838 if (TREE_CODE (record_type
) == RECORD_TYPE
839 && TYPE_IS_PADDING_P (record_type
) && TYPE_SIZE (record_type
) != 0)
841 size
= TYPE_SIZE (record_type
);
842 size_unit
= TYPE_SIZE_UNIT (record_type
);
845 /* Now set any of the values we've just computed that apply. */
846 if (! TYPE_IS_FAT_POINTER_P (record_type
)
847 && ! TYPE_CONTAINS_TEMPLATE_P (record_type
))
848 SET_TYPE_ADA_SIZE (record_type
, ada_size
);
850 size
= round_up (size
, TYPE_ALIGN (record_type
));
851 size_unit
= round_up (size_unit
, TYPE_ALIGN (record_type
) / BITS_PER_UNIT
);
854 && ! (TREE_CODE (record_type
) == RECORD_TYPE
855 && TYPE_IS_PADDING_P (record_type
)
856 && TREE_CODE (size
) != INTEGER_CST
857 && contains_placeholder_p (size
)))
859 TYPE_SIZE (record_type
) = size
;
860 TYPE_SIZE_UNIT (record_type
) = size_unit
;
864 compute_record_mode (record_type
);
868 /* If this record is of variable size, rename it so that the
869 debugger knows it is and make a new, parallel, record
870 that tells the debugger how the record is laid out. See
875 = make_node (TREE_CODE (record_type
) == QUAL_UNION_TYPE
876 ? UNION_TYPE
: TREE_CODE (record_type
));
877 tree orig_id
= DECL_NAME (TYPE_STUB_DECL (record_type
));
879 = concat_id_with_name (orig_id
,
880 TREE_CODE (record_type
) == QUAL_UNION_TYPE
882 tree last_pos
= bitsize_zero_node
;
885 TYPE_NAME (new_record_type
) = new_id
;
886 TYPE_ALIGN (new_record_type
) = BIGGEST_ALIGNMENT
;
887 TYPE_STUB_DECL (new_record_type
)
888 = pushdecl (build_decl (TYPE_DECL
, new_id
, new_record_type
));
889 DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type
)) = 1;
890 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type
))
891 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type
));
892 TYPE_SIZE (new_record_type
) = size_int (TYPE_ALIGN (record_type
));
894 /* Now scan all the fields, replacing each field with a new
895 field corresponding to the new encoding. */
896 for (old_field
= TYPE_FIELDS (record_type
); old_field
!= 0;
897 old_field
= TREE_CHAIN (old_field
))
899 tree field_type
= TREE_TYPE (old_field
);
900 tree field_name
= DECL_NAME (old_field
);
902 tree curpos
= bit_position (old_field
);
904 unsigned int align
= 0;
907 /* See how the position was modified from the last position.
909 There are two basic cases we support: a value was added
910 to the last position or the last position was rounded to
911 a boundary and they something was added. Check for the
912 first case first. If not, see if there is any evidence
913 of rounding. If so, round the last position and try
916 If this is a union, the position can be taken as zero. */
918 if (TREE_CODE (new_record_type
) == UNION_TYPE
)
919 pos
= bitsize_zero_node
, align
= 0;
921 pos
= compute_related_constant (curpos
, last_pos
);
923 if (pos
== 0 && TREE_CODE (curpos
) == MULT_EXPR
924 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
)
926 align
= TREE_INT_CST_LOW (TREE_OPERAND (curpos
, 1));
927 pos
= compute_related_constant (curpos
,
928 round_up (last_pos
, align
));
930 else if (pos
== 0 && TREE_CODE (curpos
) == PLUS_EXPR
931 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
932 && TREE_CODE (TREE_OPERAND (curpos
, 0)) == MULT_EXPR
933 && host_integerp (TREE_OPERAND
934 (TREE_OPERAND (curpos
, 0), 1),
939 (TREE_OPERAND (TREE_OPERAND (curpos
, 0), 1), 1);
940 pos
= compute_related_constant (curpos
,
941 round_up (last_pos
, align
));
944 /* If we can't compute a position, set it to zero.
946 ??? We really should abort here, but it's too much work
947 to get this correct for all cases. */
950 pos
= bitsize_zero_node
;
952 /* See if this type is variable-size and make a new type
953 and indicate the indirection if so. */
954 if (TREE_CODE (DECL_SIZE (old_field
)) != INTEGER_CST
)
956 field_type
= build_pointer_type (field_type
);
960 /* Make a new field name, if necessary. */
961 if (var
|| align
!= 0)
966 sprintf (suffix
, "XV%c%u", var
? 'L' : 'A',
967 align
/ BITS_PER_UNIT
);
969 strcpy (suffix
, "XVL");
971 field_name
= concat_id_with_name (field_name
, suffix
);
974 new_field
= create_field_decl (field_name
, field_type
,
976 DECL_SIZE (old_field
), pos
, 0);
977 TREE_CHAIN (new_field
) = TYPE_FIELDS (new_record_type
);
978 TYPE_FIELDS (new_record_type
) = new_field
;
980 /* If old_field is a QUAL_UNION_TYPE, take its size as being
981 zero. The only time it's not the last field of the record
982 is when there are other components at fixed positions after
983 it (meaning there was a rep clause for every field) and we
984 want to be able to encode them. */
985 last_pos
= size_binop (PLUS_EXPR
, bit_position (old_field
),
986 (TREE_CODE (TREE_TYPE (old_field
))
989 : DECL_SIZE (old_field
));
992 TYPE_FIELDS (new_record_type
)
993 = nreverse (TYPE_FIELDS (new_record_type
));
995 rest_of_type_compilation (new_record_type
, global_bindings_p ());
998 rest_of_type_compilation (record_type
, global_bindings_p ());
1002 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1003 with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
1004 if this represents a QUAL_UNION_TYPE in which case we must look for
1005 COND_EXPRs and replace a value of zero with the old size. If HAS_REP
1006 is nonzero, we must take the MAX of the end position of this field
1007 with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
1009 We return an expression for the size. */
1012 merge_sizes (last_size
, first_bit
, size
, special
, has_rep
)
1014 tree first_bit
, size
;
1018 tree type
= TREE_TYPE (last_size
);
1020 if (! special
|| TREE_CODE (size
) != COND_EXPR
)
1022 tree
new = size_binop (PLUS_EXPR
, first_bit
, size
);
1025 new = size_binop (MAX_EXPR
, last_size
, new);
1030 return fold (build (COND_EXPR
, type
, TREE_OPERAND (size
, 0),
1031 integer_zerop (TREE_OPERAND (size
, 1))
1032 ? last_size
: merge_sizes (last_size
, first_bit
,
1033 TREE_OPERAND (size
, 1),
1035 integer_zerop (TREE_OPERAND (size
, 2))
1036 ? last_size
: merge_sizes (last_size
, first_bit
,
1037 TREE_OPERAND (size
, 2),
1041 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1042 related by the addition of a constant. Return that constant if so. */
1045 compute_related_constant (op0
, op1
)
1048 tree op0_var
, op1_var
;
1049 tree op0_con
= split_plus (op0
, &op0_var
);
1050 tree op1_con
= split_plus (op1
, &op1_var
);
1051 tree result
= size_binop (MINUS_EXPR
, op0_con
, op1_con
);
1053 if (operand_equal_p (op0_var
, op1_var
, 0))
1055 else if (operand_equal_p (op0
, size_binop (PLUS_EXPR
, op1_var
, result
), 0))
1061 /* Utility function of above to split a tree OP which may be a sum, into a
1062 constant part, which is returned, and a variable part, which is stored
1063 in *PVAR. *PVAR may be size_zero_node. All operations must be of
1067 split_plus (in
, pvar
)
1071 tree result
= bitsize_zero_node
;
1073 while (TREE_CODE (in
) == NON_LVALUE_EXPR
)
1074 in
= TREE_OPERAND (in
, 0);
1077 if (TREE_CODE (in
) == INTEGER_CST
)
1079 *pvar
= bitsize_zero_node
;
1082 else if (TREE_CODE (in
) == PLUS_EXPR
|| TREE_CODE (in
) == MINUS_EXPR
)
1084 tree lhs_var
, rhs_var
;
1085 tree lhs_con
= split_plus (TREE_OPERAND (in
, 0), &lhs_var
);
1086 tree rhs_con
= split_plus (TREE_OPERAND (in
, 1), &rhs_var
);
1088 result
= size_binop (PLUS_EXPR
, result
, lhs_con
);
1089 result
= size_binop (TREE_CODE (in
), result
, rhs_con
);
1091 if (lhs_var
== TREE_OPERAND (in
, 0)
1092 && rhs_var
== TREE_OPERAND (in
, 1))
1093 return bitsize_zero_node
;
1095 *pvar
= size_binop (TREE_CODE (in
), lhs_var
, rhs_var
);
1099 return bitsize_zero_node
;
1102 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1103 subprogram. If it is void_type_node, then we are dealing with a procedure,
1104 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1105 PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
1106 copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1107 RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
1108 object. RETURNS_BY_REF is nonzero if the function returns by reference.
1109 RETURNS_WITH_DSP is nonzero if the function is to return with a
1110 depressed stack pointer. */
1113 create_subprog_type (return_type
, param_decl_list
, cico_list
,
1114 returns_unconstrained
, returns_by_ref
, returns_with_dsp
)
1116 tree param_decl_list
;
1118 int returns_unconstrained
, returns_by_ref
, returns_with_dsp
;
1120 /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1121 the subprogram formal parameters. This list is generated by traversing the
1122 input list of PARM_DECL nodes. */
1123 tree param_type_list
= NULL
;
1127 for (param_decl
= param_decl_list
; param_decl
;
1128 param_decl
= TREE_CHAIN (param_decl
))
1129 param_type_list
= tree_cons (NULL_TREE
, TREE_TYPE (param_decl
),
1132 /* The list of the function parameter types has to be terminated by the void
1133 type to signal to the back-end that we are not dealing with a variable
1134 parameter subprogram, but that the subprogram has a fixed number of
1136 param_type_list
= tree_cons (NULL_TREE
, void_type_node
, param_type_list
);
1138 /* The list of argument types has been created in reverse
1140 param_type_list
= nreverse (param_type_list
);
1142 type
= build_function_type (return_type
, param_type_list
);
1144 /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
1145 or the new type should, make a copy of TYPE. Likewise for
1146 RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
1147 if (TYPE_CI_CO_LIST (type
) != 0 || cico_list
!= 0
1148 || TYPE_RETURNS_UNCONSTRAINED_P (type
) != returns_unconstrained
1149 || TYPE_RETURNS_BY_REF_P (type
) != returns_by_ref
)
1150 type
= copy_type (type
);
1152 SET_TYPE_CI_CO_LIST (type
, cico_list
);
1153 TYPE_RETURNS_UNCONSTRAINED_P (type
) = returns_unconstrained
;
1154 TYPE_RETURNS_STACK_DEPRESSED (type
) = returns_with_dsp
;
1155 TYPE_RETURNS_BY_REF_P (type
) = returns_by_ref
;
1159 /* Return a copy of TYPE but safe to modify in any way. */
1165 tree
new = copy_node (type
);
1167 /* copy_node clears this field instead of copying it, because it is
1168 aliased with TREE_CHAIN. */
1169 TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type
);
1171 TYPE_POINTER_TO (new) = 0;
1172 TYPE_REFERENCE_TO (new) = 0;
1173 TYPE_MAIN_VARIANT (new) = new;
1174 TYPE_NEXT_VARIANT (new) = 0;
1179 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1180 TYPE_INDEX_TYPE is INDEX. */
1183 create_index_type (min
, max
, index
)
1187 /* First build a type for the desired range. */
1188 tree type
= build_index_2_type (min
, max
);
1190 /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
1191 doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
1192 is set, but not to INDEX, make a copy of this type with the requested
1193 index type. Note that we have no way of sharing these types, but that's
1194 only a small hole. */
1195 if (TYPE_INDEX_TYPE (type
) == index
)
1197 else if (TYPE_INDEX_TYPE (type
) != 0)
1198 type
= copy_type (type
);
1200 SET_TYPE_INDEX_TYPE (type
, index
);
1204 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1205 string) and TYPE is a ..._TYPE node giving its data type.
1206 ARTIFICIAL_P is nonzero if this is a declaration that was generated
1207 by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
1208 information about this type. */
1211 create_type_decl (type_name
, type
, attr_list
, artificial_p
, debug_info_p
)
1214 struct attrib
*attr_list
;
1218 tree type_decl
= build_decl (TYPE_DECL
, type_name
, type
);
1219 enum tree_code code
= TREE_CODE (type
);
1221 DECL_ARTIFICIAL (type_decl
) = artificial_p
;
1222 pushdecl (type_decl
);
1223 process_attributes (type_decl
, attr_list
);
1225 /* Pass type declaration information to the debugger unless this is an
1226 UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1227 and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
1228 a dummy type, which will be completed later, or a type for which
1229 debugging information was not requested. */
1230 if (code
== UNCONSTRAINED_ARRAY_TYPE
|| TYPE_IS_DUMMY_P (type
)
1232 DECL_IGNORED_P (type_decl
) = 1;
1233 else if (code
!= ENUMERAL_TYPE
&& code
!= RECORD_TYPE
1234 && ! ((code
== POINTER_TYPE
|| code
== REFERENCE_TYPE
)
1235 && TYPE_IS_DUMMY_P (TREE_TYPE (type
))))
1236 rest_of_decl_compilation (type_decl
, NULL
, global_bindings_p (), 0);
1241 /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
1242 ASM_NAME is its assembler name (if provided). TYPE is its data type
1243 (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
1244 expression; NULL_TREE if none.
1246 CONST_FLAG is nonzero if this variable is constant.
1248 PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
1249 the current compilation unit. This flag should be set when processing the
1250 variable definitions in a package specification. EXTERN_FLAG is nonzero
1251 when processing an external variable declaration (as opposed to a
1252 definition: no storage is to be allocated for the variable here).
1254 STATIC_FLAG is only relevant when not at top level. In that case
1255 it indicates whether to always allocate storage to the variable. */
1258 create_var_decl (var_name
, asm_name
, type
, var_init
, const_flag
, public_flag
,
1259 extern_flag
, static_flag
, attr_list
)
1268 struct attrib
*attr_list
;
1273 : (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1274 && (global_bindings_p () || static_flag
1275 ? 0 != initializer_constant_valid_p (var_init
,
1276 TREE_TYPE (var_init
))
1277 : TREE_CONSTANT (var_init
))));
1279 = build_decl ((const_flag
&& init_const
1280 /* Only make a CONST_DECL for sufficiently-small objects.
1281 We consider complex double "sufficiently-small" */
1282 && TYPE_SIZE (type
) != 0
1283 && host_integerp (TYPE_SIZE_UNIT (type
), 1)
1284 && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type
),
1285 GET_MODE_SIZE (DCmode
)))
1286 ? CONST_DECL
: VAR_DECL
, var_name
, type
);
1287 tree assign_init
= 0;
1289 /* If this is external, throw away any initializations unless this is a
1290 CONST_DECL (meaning we have a constant); they will be done elsewhere. If
1291 we are defining a global here, leave a constant initialization and save
1292 any variable elaborations for the elaboration routine. Otherwise, if
1293 the initializing expression is not the same as TYPE, generate the
1294 initialization with an assignment statement, since it knows how
1295 to do the required adjustents. If we are just annotating types,
1296 throw away the initialization if it isn't a constant. */
1298 if ((extern_flag
&& TREE_CODE (var_decl
) != CONST_DECL
)
1299 || (type_annotate_only
&& var_init
!= 0 && ! TREE_CONSTANT (var_init
)))
1302 if (global_bindings_p () && var_init
!= 0 && ! init_const
)
1304 add_pending_elaborations (var_decl
, var_init
);
1308 else if (var_init
!= 0
1309 && ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1310 != TYPE_MAIN_VARIANT (type
))
1311 || (static_flag
&& ! init_const
)))
1312 assign_init
= var_init
, var_init
= 0;
1314 DECL_COMMON (var_decl
) = !flag_no_common
;
1315 DECL_INITIAL (var_decl
) = var_init
;
1316 TREE_READONLY (var_decl
) = const_flag
;
1317 DECL_EXTERNAL (var_decl
) = extern_flag
;
1318 TREE_PUBLIC (var_decl
) = public_flag
|| extern_flag
;
1319 TREE_CONSTANT (var_decl
) = TREE_CODE (var_decl
) == CONST_DECL
;
1320 TREE_THIS_VOLATILE (var_decl
) = TREE_SIDE_EFFECTS (var_decl
)
1321 = TYPE_VOLATILE (type
);
1323 /* At the global binding level we need to allocate static storage for the
1324 variable if and only if its not external. If we are not at the top level
1325 we allocate automatic storage unless requested not to. */
1326 TREE_STATIC (var_decl
) = global_bindings_p () ? !extern_flag
: static_flag
;
1329 SET_DECL_ASSEMBLER_NAME (var_decl
, asm_name
);
1331 process_attributes (var_decl
, attr_list
);
1333 /* Add this decl to the current binding level and generate any
1334 needed code and RTL. */
1335 var_decl
= pushdecl (var_decl
);
1336 expand_decl (var_decl
);
1338 if (DECL_CONTEXT (var_decl
) != 0)
1339 expand_decl_init (var_decl
);
1341 /* If this is volatile, force it into memory. */
1342 if (TREE_SIDE_EFFECTS (var_decl
))
1343 gnat_mark_addressable (var_decl
);
1345 if (TREE_CODE (var_decl
) != CONST_DECL
)
1346 rest_of_decl_compilation (var_decl
, 0, global_bindings_p (), 0);
1348 if (assign_init
!= 0)
1350 /* If VAR_DECL has a padded type, convert it to the unpadded
1351 type so the assignment is done properly. */
1352 tree lhs
= var_decl
;
1354 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
1355 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
1356 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
1358 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
, lhs
,
1365 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1366 type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
1367 this field is in a record type with a "pragma pack". If SIZE is nonzero
1368 it is the specified size for this field. If POS is nonzero, it is the bit
1369 position. If ADDRESSABLE is nonzero, it means we are allowed to take
1370 the address of this field for aliasing purposes. */
1373 create_field_decl (field_name
, field_type
, record_type
, packed
, size
, pos
,
1382 tree field_decl
= build_decl (FIELD_DECL
, field_name
, field_type
);
1384 DECL_CONTEXT (field_decl
) = record_type
;
1385 TREE_READONLY (field_decl
) = TREE_READONLY (field_type
);
1387 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1388 byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
1389 If it is a padding type where the inner field is of variable size, it
1390 must be at its natural alignment. Just handle the packed case here; we
1391 will disallow non-aligned rep clauses elsewhere. */
1392 if (packed
&& TYPE_MODE (field_type
) == BLKmode
)
1393 DECL_ALIGN (field_decl
)
1394 = ((TREE_CODE (field_type
) == RECORD_TYPE
1395 && TYPE_IS_PADDING_P (field_type
)
1396 && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (field_type
))))
1397 ? TYPE_ALIGN (field_type
) : BITS_PER_UNIT
);
1399 /* If a size is specified, use it. Otherwise, see if we have a size
1400 to use that may differ from the natural size of the object. */
1402 size
= convert (bitsizetype
, size
);
1405 if (packed
== 1 && ! operand_equal_p (rm_size (field_type
),
1406 TYPE_SIZE (field_type
), 0))
1407 size
= rm_size (field_type
);
1409 /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1411 if (size
!= 0 && TREE_CODE (size
) == INTEGER_CST
1412 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) > 0)
1413 size
= round_up (size
, BITS_PER_UNIT
);
1416 /* Make a bitfield if a size is specified for two reasons: first if the size
1417 differs from the natural size. Second, if the alignment is insufficient.
1418 There are a number of ways the latter can be true. But never make a
1419 bitfield if the type of the field has a nonconstant size. */
1421 if (size
!= 0 && TREE_CODE (size
) == INTEGER_CST
1422 && TREE_CODE (TYPE_SIZE (field_type
)) == INTEGER_CST
1423 && (! operand_equal_p (TYPE_SIZE (field_type
), size
, 0)
1425 && ! value_zerop (size_binop (TRUNC_MOD_EXPR
, pos
,
1426 bitsize_int (TYPE_ALIGN
1429 || (TYPE_ALIGN (record_type
) != 0
1430 && TYPE_ALIGN (record_type
) < TYPE_ALIGN (field_type
))))
1432 DECL_BIT_FIELD (field_decl
) = 1;
1433 DECL_SIZE (field_decl
) = size
;
1434 if (! packed
&& pos
== 0)
1435 DECL_ALIGN (field_decl
)
1436 = (TYPE_ALIGN (record_type
) != 0
1437 ? MIN (TYPE_ALIGN (record_type
), TYPE_ALIGN (field_type
))
1438 : TYPE_ALIGN (field_type
));
1441 DECL_PACKED (field_decl
) = pos
!= 0 ? DECL_BIT_FIELD (field_decl
) : packed
;
1442 DECL_ALIGN (field_decl
)
1443 = MAX (DECL_ALIGN (field_decl
),
1444 DECL_BIT_FIELD (field_decl
) ? 1
1445 : packed
&& TYPE_MODE (field_type
) != BLKmode
? BITS_PER_UNIT
1446 : TYPE_ALIGN (field_type
));
1450 /* We need to pass in the alignment the DECL is known to have.
1451 This is the lowest-order bit set in POS, but no more than
1452 the alignment of the record, if one is specified. Note
1453 that an alignment of 0 is taken as infinite. */
1454 unsigned int known_align
;
1456 if (host_integerp (pos
, 1))
1457 known_align
= tree_low_cst (pos
, 1) & - tree_low_cst (pos
, 1);
1459 known_align
= BITS_PER_UNIT
;
1461 if (TYPE_ALIGN (record_type
)
1462 && (known_align
== 0 || known_align
> TYPE_ALIGN (record_type
)))
1463 known_align
= TYPE_ALIGN (record_type
);
1465 layout_decl (field_decl
, known_align
);
1466 SET_DECL_OFFSET_ALIGN (field_decl
,
1467 host_integerp (pos
, 1) ? BIGGEST_ALIGNMENT
1469 pos_from_bit (&DECL_FIELD_OFFSET (field_decl
),
1470 &DECL_FIELD_BIT_OFFSET (field_decl
),
1471 DECL_OFFSET_ALIGN (field_decl
), pos
);
1473 DECL_HAS_REP_P (field_decl
) = 1;
1476 /* If the field type is passed by reference, we will have pointers to the
1477 field, so it is addressable. */
1478 if (must_pass_by_ref (field_type
) || default_pass_by_ref (field_type
))
1481 /* Mark the decl as nonaddressable if it either is indicated so semantically
1482 or if it is a bit field. */
1483 DECL_NONADDRESSABLE_P (field_decl
)
1484 = ! addressable
|| DECL_BIT_FIELD (field_decl
);
1489 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1490 effects, has the value of zero. */
1496 if (TREE_CODE (exp
) == COMPOUND_EXPR
)
1497 return value_zerop (TREE_OPERAND (exp
, 1));
1499 return integer_zerop (exp
);
1502 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1503 PARAM_TYPE is its type. READONLY is nonzero if the parameter is
1504 readonly (either an IN parameter or an address of a pass-by-ref
1508 create_param_decl (param_name
, param_type
, readonly
)
1513 tree param_decl
= build_decl (PARM_DECL
, param_name
, param_type
);
1515 DECL_ARG_TYPE (param_decl
) = param_type
;
1516 DECL_ARG_TYPE_AS_WRITTEN (param_decl
) = param_type
;
1517 TREE_READONLY (param_decl
) = readonly
;
1521 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1524 process_attributes (decl
, attr_list
)
1526 struct attrib
*attr_list
;
1528 for (; attr_list
; attr_list
= attr_list
->next
)
1529 switch (attr_list
->type
)
1531 case ATTR_MACHINE_ATTRIBUTE
:
1532 decl_attributes (&decl
, tree_cons (attr_list
->name
, attr_list
->arg
,
1534 ATTR_FLAG_TYPE_IN_PLACE
);
1537 case ATTR_LINK_ALIAS
:
1538 TREE_STATIC (decl
) = 1;
1539 assemble_alias (decl
, attr_list
->name
);
1542 case ATTR_WEAK_EXTERNAL
:
1544 declare_weak (decl
);
1546 post_error ("?weak declarations not supported on this target",
1547 attr_list
->error_point
);
1550 case ATTR_LINK_SECTION
:
1551 #ifdef ASM_OUTPUT_SECTION_NAME
1552 DECL_SECTION_NAME (decl
)
1553 = build_string (IDENTIFIER_LENGTH (attr_list
->name
),
1554 IDENTIFIER_POINTER (attr_list
->name
));
1555 DECL_COMMON (decl
) = 0;
1557 post_error ("?section attributes are not supported for this target",
1558 attr_list
->error_point
);
1564 /* Add some pending elaborations on the list. */
1567 add_pending_elaborations (var_decl
, var_init
)
1572 Check_Elaboration_Code_Allowed (error_gnat_node
);
1574 pending_elaborations
1575 = chainon (pending_elaborations
, build_tree_list (var_decl
, var_init
));
1578 /* Obtain any pending elaborations and clear the old list. */
1581 get_pending_elaborations ()
1583 /* Each thing added to the list went on the end; we want it on the
1585 tree result
= TREE_CHAIN (pending_elaborations
);
1587 TREE_CHAIN (pending_elaborations
) = 0;
1591 /* Return nonzero if there are pending elaborations. */
1594 pending_elaborations_p ()
1596 return TREE_CHAIN (pending_elaborations
) != 0;
1599 /* Save a copy of the current pending elaboration list and make a new
1603 push_pending_elaborations ()
1605 struct e_stack
*p
= (struct e_stack
*) ggc_alloc (sizeof (struct e_stack
));
1607 p
->next
= elist_stack
;
1608 p
->elab_list
= pending_elaborations
;
1610 pending_elaborations
= build_tree_list (NULL_TREE
, NULL_TREE
);
1613 /* Pop the stack of pending elaborations. */
1616 pop_pending_elaborations ()
1618 struct e_stack
*p
= elist_stack
;
1620 pending_elaborations
= p
->elab_list
;
1621 elist_stack
= p
->next
;
1624 /* Return the current position in pending_elaborations so we can insert
1625 elaborations after that point. */
1628 get_elaboration_location ()
1630 return tree_last (pending_elaborations
);
1633 /* Insert the current elaborations after ELAB, which is in some elaboration
1637 insert_elaboration_list (elab
)
1640 tree next
= TREE_CHAIN (elab
);
1642 if (TREE_CHAIN (pending_elaborations
))
1644 TREE_CHAIN (elab
) = TREE_CHAIN (pending_elaborations
);
1645 TREE_CHAIN (tree_last (pending_elaborations
)) = next
;
1646 TREE_CHAIN (pending_elaborations
) = 0;
1650 /* Returns a LABEL_DECL node for LABEL_NAME. */
1653 create_label_decl (label_name
)
1656 tree label_decl
= build_decl (LABEL_DECL
, label_name
, void_type_node
);
1658 DECL_CONTEXT (label_decl
) = current_function_decl
;
1659 DECL_MODE (label_decl
) = VOIDmode
;
1660 DECL_SOURCE_LOCATION (label_decl
) = input_location
;
1665 /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1666 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1667 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1668 PARM_DECL nodes chained through the TREE_CHAIN field).
1670 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1671 appropriate fields in the FUNCTION_DECL. */
1674 create_subprog_decl (subprog_name
, asm_name
, subprog_type
, param_decl_list
,
1675 inline_flag
, public_flag
, extern_flag
, attr_list
)
1679 tree param_decl_list
;
1683 struct attrib
*attr_list
;
1685 tree return_type
= TREE_TYPE (subprog_type
);
1686 tree subprog_decl
= build_decl (FUNCTION_DECL
, subprog_name
, subprog_type
);
1688 /* If this is a function nested inside an inlined external function, it
1689 means we aren't going to compile the outer function unless it is
1690 actually inlined, so do the same for us. */
1691 if (current_function_decl
!= 0 && DECL_INLINE (current_function_decl
)
1692 && DECL_EXTERNAL (current_function_decl
))
1695 DECL_EXTERNAL (subprog_decl
) = extern_flag
;
1696 TREE_PUBLIC (subprog_decl
) = public_flag
;
1697 DECL_INLINE (subprog_decl
) = inline_flag
;
1698 TREE_READONLY (subprog_decl
) = TYPE_READONLY (subprog_type
);
1699 TREE_THIS_VOLATILE (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1700 TREE_SIDE_EFFECTS (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1701 DECL_ARGUMENTS (subprog_decl
) = param_decl_list
;
1702 DECL_RESULT (subprog_decl
) = build_decl (RESULT_DECL
, 0, return_type
);
1705 SET_DECL_ASSEMBLER_NAME (subprog_decl
, asm_name
);
1707 process_attributes (subprog_decl
, attr_list
);
1709 /* Add this decl to the current binding level. */
1710 subprog_decl
= pushdecl (subprog_decl
);
1712 /* Output the assembler code and/or RTL for the declaration. */
1713 rest_of_decl_compilation (subprog_decl
, 0, global_bindings_p (), 0);
1715 return subprog_decl
;
1718 /* Count how deep we are into nested functions. This is because
1719 we shouldn't call the backend function context routines unless we
1720 are in a nested function. */
1722 static int function_nesting_depth
;
1724 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1725 body. This routine needs to be invoked before processing the declarations
1726 appearing in the subprogram. */
1729 begin_subprog_body (subprog_decl
)
1732 tree param_decl_list
;
1736 if (function_nesting_depth
++ != 0)
1737 push_function_context ();
1739 announce_function (subprog_decl
);
1741 /* Make this field nonzero so further routines know that this is not
1742 tentative. error_mark_node is replaced below (in poplevel) with the
1744 DECL_INITIAL (subprog_decl
) = error_mark_node
;
1746 /* This function exists in static storage. This does not mean `static' in
1748 TREE_STATIC (subprog_decl
) = 1;
1750 /* Enter a new binding level. */
1751 current_function_decl
= subprog_decl
;
1754 /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
1755 subprogram body) so that they can be recognized as local variables in the
1758 The list of PARM_DECL nodes is stored in the right order in
1759 DECL_ARGUMENTS. Since ..._DECL nodes get stored in the reverse order in
1760 which they are transmitted to `pushdecl' we need to reverse the list of
1761 PARM_DECLs if we want it to be stored in the right order. The reason why
1762 we want to make sure the PARM_DECLs are stored in the correct order is
1763 that this list will be retrieved in a few lines with a call to `getdecl'
1764 to store it back into the DECL_ARGUMENTS field. */
1765 param_decl_list
= nreverse (DECL_ARGUMENTS (subprog_decl
));
1767 for (param_decl
= param_decl_list
; param_decl
; param_decl
= next_param
)
1769 next_param
= TREE_CHAIN (param_decl
);
1770 TREE_CHAIN (param_decl
) = NULL
;
1771 pushdecl (param_decl
);
1774 /* Store back the PARM_DECL nodes. They appear in the right order. */
1775 DECL_ARGUMENTS (subprog_decl
) = getdecls ();
1777 init_function_start (subprog_decl
, input_filename
, input_line
);
1778 expand_function_start (subprog_decl
, 0);
1780 /* If this function is `main', emit a call to `__main'
1781 to run global initializers, etc. */
1782 if (DECL_ASSEMBLER_NAME (subprog_decl
) != 0
1783 && MAIN_NAME_P (DECL_ASSEMBLER_NAME (subprog_decl
))
1784 && DECL_CONTEXT (subprog_decl
) == NULL_TREE
)
1785 expand_main_function ();
1788 /* Finish the definition of the current subprogram and compile it all the way
1789 to assembler language output. */
1798 BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl
))
1799 = current_function_decl
;
1801 /* Mark the RESULT_DECL as being in this subprogram. */
1802 DECL_CONTEXT (DECL_RESULT (current_function_decl
)) = current_function_decl
;
1804 expand_function_end (input_filename
, input_line
, 0);
1806 /* If this is a nested function, push a new GC context. That will keep
1807 local variables on the stack from being collected while we're doing
1808 the compilation of this function. */
1809 if (function_nesting_depth
> 1)
1810 ggc_push_context ();
1812 rest_of_compilation (current_function_decl
);
1814 if (function_nesting_depth
> 1)
1818 /* If we're sure this function is defined in this file then mark it
1820 if (TREE_ASM_WRITTEN (current_function_decl
))
1821 mark_fn_defined_in_this_file (current_function_decl
);
1824 /* Throw away any VAR_DECLs we made for OUT parameters; they must
1825 not be seen when we call this function and will be in
1826 unallocated memory anyway. */
1827 for (cico_list
= TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl
));
1828 cico_list
!= 0; cico_list
= TREE_CHAIN (cico_list
))
1829 TREE_VALUE (cico_list
) = 0;
1831 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
1833 /* Throw away DECL_RTL in any PARM_DECLs unless this function
1834 was saved for inline, in which case the DECL_RTLs are in
1835 preserved memory. */
1836 for (decl
= DECL_ARGUMENTS (current_function_decl
);
1837 decl
!= 0; decl
= TREE_CHAIN (decl
))
1839 SET_DECL_RTL (decl
, 0);
1840 DECL_INCOMING_RTL (decl
) = 0;
1843 /* Similarly, discard DECL_RTL of the return value. */
1844 SET_DECL_RTL (DECL_RESULT (current_function_decl
), 0);
1846 /* But DECL_INITIAL must remain nonzero so we know this
1847 was an actual function definition unless toplev.c decided not
1849 if (DECL_INITIAL (current_function_decl
) != 0)
1850 DECL_INITIAL (current_function_decl
) = error_mark_node
;
1852 DECL_ARGUMENTS (current_function_decl
) = 0;
1855 /* If we are not at the bottom of the function nesting stack, pop up to
1856 the containing function. Otherwise show we aren't in any function. */
1857 if (--function_nesting_depth
!= 0)
1858 pop_function_context ();
1860 current_function_decl
= 0;
1863 /* Return a definition for a builtin function named NAME and whose data type
1864 is TYPE. TYPE should be a function type with argument types.
1865 FUNCTION_CODE tells later passes how to compile calls to this function.
1866 See tree.h for its possible values.
1868 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1869 the name to be called if we can't opencode the function. If
1870 ATTRS is nonzero, use that for the function attribute list. */
1873 builtin_function (name
, type
, function_code
, class, library_name
, attrs
)
1877 enum built_in_class
class;
1878 const char *library_name
;
1881 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
1883 DECL_EXTERNAL (decl
) = 1;
1884 TREE_PUBLIC (decl
) = 1;
1886 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
1889 DECL_BUILT_IN_CLASS (decl
) = class;
1890 DECL_FUNCTION_CODE (decl
) = function_code
;
1892 decl_attributes (&decl
, attrs
, ATTR_FLAG_BUILT_IN
);
1896 /* Return an integer type with the number of bits of precision given by
1897 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
1898 it is a signed type. */
1901 gnat_type_for_size (precision
, unsignedp
)
1908 if (precision
<= 2 * MAX_BITS_PER_WORD
1909 && signed_and_unsigned_types
[precision
][unsignedp
] != 0)
1910 return signed_and_unsigned_types
[precision
][unsignedp
];
1913 t
= make_unsigned_type (precision
);
1915 t
= make_signed_type (precision
);
1917 if (precision
<= 2 * MAX_BITS_PER_WORD
)
1918 signed_and_unsigned_types
[precision
][unsignedp
] = t
;
1920 if (TYPE_NAME (t
) == 0)
1922 sprintf (type_name
, "%sSIGNED_%d", unsignedp
? "UN" : "", precision
);
1923 TYPE_NAME (t
) = get_identifier (type_name
);
1929 /* Likewise for floating-point types. */
1932 float_type_for_size (precision
, mode
)
1934 enum machine_mode mode
;
1939 if (float_types
[(int) mode
] != 0)
1940 return float_types
[(int) mode
];
1942 float_types
[(int) mode
] = t
= make_node (REAL_TYPE
);
1943 TYPE_PRECISION (t
) = precision
;
1946 if (TYPE_MODE (t
) != mode
)
1949 if (TYPE_NAME (t
) == 0)
1951 sprintf (type_name
, "FLOAT_%d", precision
);
1952 TYPE_NAME (t
) = get_identifier (type_name
);
1958 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
1959 an unsigned type; otherwise a signed type is returned. */
1962 gnat_type_for_mode (mode
, unsignedp
)
1963 enum machine_mode mode
;
1966 if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
1967 return float_type_for_size (GET_MODE_BITSIZE (mode
), mode
);
1969 return gnat_type_for_size (GET_MODE_BITSIZE (mode
), unsignedp
);
1972 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
1975 gnat_unsigned_type (type_node
)
1978 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 1);
1980 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
1982 type
= copy_node (type
);
1983 TREE_TYPE (type
) = type_node
;
1985 else if (TREE_TYPE (type_node
) != 0
1986 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
1987 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
1989 type
= copy_node (type
);
1990 TREE_TYPE (type
) = TREE_TYPE (type_node
);
1996 /* Return the signed version of a TYPE_NODE, a scalar type. */
1999 gnat_signed_type (type_node
)
2002 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 0);
2004 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
2006 type
= copy_node (type
);
2007 TREE_TYPE (type
) = type_node
;
2009 else if (TREE_TYPE (type_node
) != 0
2010 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
2011 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
2013 type
= copy_node (type
);
2014 TREE_TYPE (type
) = TREE_TYPE (type_node
);
2020 /* Return a type the same as TYPE except unsigned or signed according to
2024 gnat_signed_or_unsigned_type (unsignedp
, type
)
2028 if (! INTEGRAL_TYPE_P (type
) || TREE_UNSIGNED (type
) == unsignedp
)
2031 return gnat_type_for_size (TYPE_PRECISION (type
), unsignedp
);
2034 /* EXP is an expression for the size of an object. If this size contains
2035 discriminant references, replace them with the maximum (if MAX_P) or
2036 minimum (if ! MAX_P) possible value of the discriminant. */
2039 max_size (exp
, max_p
)
2043 enum tree_code code
= TREE_CODE (exp
);
2044 tree type
= TREE_TYPE (exp
);
2046 switch (TREE_CODE_CLASS (code
))
2053 if (code
== TREE_LIST
)
2054 return tree_cons (TREE_PURPOSE (exp
),
2055 max_size (TREE_VALUE (exp
), max_p
),
2056 TREE_CHAIN (exp
) != 0
2057 ? max_size (TREE_CHAIN (exp
), max_p
) : 0);
2061 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2062 modify. Otherwise, we abort since it is something we can't
2064 if (! contains_placeholder_p (exp
))
2067 type
= TREE_TYPE (TREE_OPERAND (exp
, 1));
2069 max_size (max_p
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
), 1);
2072 return max_p
? size_one_node
: size_zero_node
;
2077 switch (TREE_CODE_LENGTH (code
))
2080 if (code
== NON_LVALUE_EXPR
)
2081 return max_size (TREE_OPERAND (exp
, 0), max_p
);
2084 fold (build1 (code
, type
,
2085 max_size (TREE_OPERAND (exp
, 0),
2086 code
== NEGATE_EXPR
? ! max_p
: max_p
)));
2089 if (code
== RTL_EXPR
)
2091 else if (code
== COMPOUND_EXPR
)
2092 return max_size (TREE_OPERAND (exp
, 1), max_p
);
2093 else if (code
== WITH_RECORD_EXPR
)
2097 tree lhs
= max_size (TREE_OPERAND (exp
, 0), max_p
);
2098 tree rhs
= max_size (TREE_OPERAND (exp
, 1),
2099 code
== MINUS_EXPR
? ! max_p
: max_p
);
2101 /* Special-case wanting the maximum value of a MIN_EXPR.
2102 In that case, if one side overflows, return the other.
2103 sizetype is signed, but we know sizes are non-negative.
2104 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2105 overflowing or the maximum possible value and the RHS
2107 if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (rhs
))
2109 else if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (lhs
))
2111 else if ((code
== MINUS_EXPR
|| code
== PLUS_EXPR
)
2112 && (TREE_OVERFLOW (lhs
)
2113 || operand_equal_p (lhs
, TYPE_MAX_VALUE (type
), 0))
2114 && ! TREE_CONSTANT (rhs
))
2117 return fold (build (code
, type
, lhs
, rhs
));
2121 if (code
== SAVE_EXPR
)
2123 else if (code
== COND_EXPR
)
2124 return fold (build (MAX_EXPR
, type
,
2125 max_size (TREE_OPERAND (exp
, 1), max_p
),
2126 max_size (TREE_OPERAND (exp
, 2), max_p
)));
2127 else if (code
== CALL_EXPR
&& TREE_OPERAND (exp
, 1) != 0)
2128 return build (CALL_EXPR
, type
, TREE_OPERAND (exp
, 0),
2129 max_size (TREE_OPERAND (exp
, 1), max_p
));
2136 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2137 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2138 Return a constructor for the template. */
2141 build_template (template_type
, array_type
, expr
)
2146 tree template_elts
= NULL_TREE
;
2147 tree bound_list
= NULL_TREE
;
2150 if (TREE_CODE (array_type
) == RECORD_TYPE
2151 && (TYPE_IS_PADDING_P (array_type
)
2152 || TYPE_LEFT_JUSTIFIED_MODULAR_P (array_type
)))
2153 array_type
= TREE_TYPE (TYPE_FIELDS (array_type
));
2155 if (TREE_CODE (array_type
) == ARRAY_TYPE
2156 || (TREE_CODE (array_type
) == INTEGER_TYPE
2157 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type
)))
2158 bound_list
= TYPE_ACTUAL_BOUNDS (array_type
);
2160 /* First make the list for a CONSTRUCTOR for the template. Go down the
2161 field list of the template instead of the type chain because this
2162 array might be an Ada array of arrays and we can't tell where the
2163 nested arrays stop being the underlying object. */
2165 for (field
= TYPE_FIELDS (template_type
); field
;
2167 ? (bound_list
= TREE_CHAIN (bound_list
))
2168 : (array_type
= TREE_TYPE (array_type
))),
2169 field
= TREE_CHAIN (TREE_CHAIN (field
)))
2171 tree bounds
, min
, max
;
2173 /* If we have a bound list, get the bounds from there. Likewise
2174 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2175 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2176 This will give us a maximum range. */
2177 if (bound_list
!= 0)
2178 bounds
= TREE_VALUE (bound_list
);
2179 else if (TREE_CODE (array_type
) == ARRAY_TYPE
)
2180 bounds
= TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type
));
2181 else if (expr
!= 0 && TREE_CODE (expr
) == PARM_DECL
2182 && DECL_BY_COMPONENT_PTR_P (expr
))
2183 bounds
= TREE_TYPE (field
);
2187 min
= convert (TREE_TYPE (TREE_CHAIN (field
)), TYPE_MIN_VALUE (bounds
));
2188 max
= convert (TREE_TYPE (field
), TYPE_MAX_VALUE (bounds
));
2190 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2191 surround them with a WITH_RECORD_EXPR giving EXPR as the
2193 if (! TREE_CONSTANT (min
) && contains_placeholder_p (min
))
2194 min
= build (WITH_RECORD_EXPR
, TREE_TYPE (min
), min
, expr
);
2195 if (! TREE_CONSTANT (max
) && contains_placeholder_p (max
))
2196 max
= build (WITH_RECORD_EXPR
, TREE_TYPE (max
), max
, expr
);
2198 template_elts
= tree_cons (TREE_CHAIN (field
), max
,
2199 tree_cons (field
, min
, template_elts
));
2202 return gnat_build_constructor (template_type
, nreverse (template_elts
));
2205 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2206 a descriptor type, and the GCC type of an object. Each FIELD_DECL
2207 in the type contains in its DECL_INITIAL the expression to use when
2208 a constructor is made for the type. GNAT_ENTITY is a gnat node used
2209 to print out an error message if the mechanism cannot be applied to
2210 an object of that type and also for the name. */
2213 build_vms_descriptor (type
, mech
, gnat_entity
)
2215 Mechanism_Type mech
;
2216 Entity_Id gnat_entity
;
2218 tree record_type
= make_node (RECORD_TYPE
);
2219 tree field_list
= 0;
2228 /* If TYPE is an unconstrained array, use the underlying array type. */
2229 if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
2230 type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type
))));
2232 /* If this is an array, compute the number of dimensions in the array,
2233 get the index types, and point to the inner type. */
2234 if (TREE_CODE (type
) != ARRAY_TYPE
)
2237 for (ndim
= 1, inner_type
= type
;
2238 TREE_CODE (TREE_TYPE (inner_type
)) == ARRAY_TYPE
2239 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type
));
2240 ndim
++, inner_type
= TREE_TYPE (inner_type
))
2243 idx_arr
= (tree
*) alloca (ndim
* sizeof (tree
));
2245 if (mech
!= By_Descriptor_NCA
2246 && TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type
))
2247 for (i
= ndim
- 1, inner_type
= type
;
2249 i
--, inner_type
= TREE_TYPE (inner_type
))
2250 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2252 for (i
= 0, inner_type
= type
;
2254 i
++, inner_type
= TREE_TYPE (inner_type
))
2255 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2257 /* Now get the DTYPE value. */
2258 switch (TREE_CODE (type
))
2262 if (TYPE_VAX_FLOATING_POINT_P (type
))
2263 switch ((int) TYPE_DIGITS_VALUE (type
))
2276 switch (GET_MODE_BITSIZE (TYPE_MODE (type
)))
2279 dtype
= TREE_UNSIGNED (type
) ? 2 : 6;
2282 dtype
= TREE_UNSIGNED (type
) ? 3 : 7;
2285 dtype
= TREE_UNSIGNED (type
) ? 4 : 8;
2288 dtype
= TREE_UNSIGNED (type
) ? 5 : 9;
2291 dtype
= TREE_UNSIGNED (type
) ? 25 : 26;
2297 dtype
= GET_MODE_BITSIZE (TYPE_MODE (type
)) == 32 ? 52 : 53;
2301 if (TREE_CODE (TREE_TYPE (type
)) == INTEGER_TYPE
2302 && TYPE_VAX_FLOATING_POINT_P (type
))
2303 switch ((int) TYPE_DIGITS_VALUE (type
))
2315 dtype
= GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type
))) == 32 ? 54: 55;
2326 /* Get the CLASS value. */
2329 case By_Descriptor_A
:
2332 case By_Descriptor_NCA
:
2335 case By_Descriptor_SB
:
2342 /* Make the type for a descriptor for VMS. The first four fields
2343 are the same for all types. */
2346 = chainon (field_list
,
2347 make_descriptor_field
2348 ("LENGTH", gnat_type_for_size (16, 1), record_type
,
2349 size_in_bytes (mech
== By_Descriptor_A
? inner_type
: type
)));
2351 field_list
= chainon (field_list
,
2352 make_descriptor_field ("DTYPE",
2353 gnat_type_for_size (8, 1),
2354 record_type
, size_int (dtype
)));
2355 field_list
= chainon (field_list
,
2356 make_descriptor_field ("CLASS",
2357 gnat_type_for_size (8, 1),
2358 record_type
, size_int (class)));
2361 = chainon (field_list
,
2362 make_descriptor_field ("POINTER",
2363 build_pointer_type (type
),
2366 build_pointer_type (type
),
2367 build (PLACEHOLDER_EXPR
,
2373 case By_Descriptor_S
:
2376 case By_Descriptor_SB
:
2378 = chainon (field_list
,
2379 make_descriptor_field
2380 ("SB_L1", gnat_type_for_size (32, 1), record_type
,
2381 TREE_CODE (type
) == ARRAY_TYPE
2382 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2384 = chainon (field_list
,
2385 make_descriptor_field
2386 ("SB_L2", gnat_type_for_size (32, 1), record_type
,
2387 TREE_CODE (type
) == ARRAY_TYPE
2388 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2391 case By_Descriptor_A
:
2392 case By_Descriptor_NCA
:
2393 field_list
= chainon (field_list
,
2394 make_descriptor_field ("SCALE",
2395 gnat_type_for_size (8, 1),
2399 field_list
= chainon (field_list
,
2400 make_descriptor_field ("DIGITS",
2401 gnat_type_for_size (8, 1),
2406 = chainon (field_list
,
2407 make_descriptor_field
2408 ("AFLAGS", gnat_type_for_size (8, 1), record_type
,
2409 size_int (mech
== By_Descriptor_NCA
2411 /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
2412 : (TREE_CODE (type
) == ARRAY_TYPE
2413 && TYPE_CONVENTION_FORTRAN_P (type
)
2416 field_list
= chainon (field_list
,
2417 make_descriptor_field ("DIMCT",
2418 gnat_type_for_size (8, 1),
2422 field_list
= chainon (field_list
,
2423 make_descriptor_field ("ARSIZE",
2424 gnat_type_for_size (32, 1),
2426 size_in_bytes (type
)));
2428 /* Now build a pointer to the 0,0,0... element. */
2429 tem
= build (PLACEHOLDER_EXPR
, type
);
2430 for (i
= 0, inner_type
= type
; i
< ndim
;
2431 i
++, inner_type
= TREE_TYPE (inner_type
))
2432 tem
= build (ARRAY_REF
, TREE_TYPE (inner_type
), tem
,
2433 convert (TYPE_DOMAIN (inner_type
), size_zero_node
));
2436 = chainon (field_list
,
2437 make_descriptor_field
2438 ("A0", build_pointer_type (inner_type
), record_type
,
2439 build1 (ADDR_EXPR
, build_pointer_type (inner_type
), tem
)));
2441 /* Next come the addressing coefficients. */
2443 for (i
= 0; i
< ndim
; i
++)
2447 = size_binop (MULT_EXPR
, tem
,
2448 size_binop (PLUS_EXPR
,
2449 size_binop (MINUS_EXPR
,
2450 TYPE_MAX_VALUE (idx_arr
[i
]),
2451 TYPE_MIN_VALUE (idx_arr
[i
])),
2454 fname
[0] = (mech
== By_Descriptor_NCA
? 'S' : 'M');
2455 fname
[1] = '0' + i
, fname
[2] = 0;
2457 = chainon (field_list
,
2458 make_descriptor_field (fname
,
2459 gnat_type_for_size (32, 1),
2460 record_type
, idx_length
));
2462 if (mech
== By_Descriptor_NCA
)
2466 /* Finally here are the bounds. */
2467 for (i
= 0; i
< ndim
; i
++)
2471 fname
[0] = 'L', fname
[1] = '0' + i
, fname
[2] = 0;
2473 = chainon (field_list
,
2474 make_descriptor_field
2475 (fname
, gnat_type_for_size (32, 1), record_type
,
2476 TYPE_MIN_VALUE (idx_arr
[i
])));
2480 = chainon (field_list
,
2481 make_descriptor_field
2482 (fname
, gnat_type_for_size (32, 1), record_type
,
2483 TYPE_MAX_VALUE (idx_arr
[i
])));
2488 post_error ("unsupported descriptor type for &", gnat_entity
);
2491 finish_record_type (record_type
, field_list
, 0, 1);
2492 pushdecl (build_decl (TYPE_DECL
, create_concat_name (gnat_entity
, "DESC"),
2498 /* Utility routine for above code to make a field. */
2501 make_descriptor_field (name
, type
, rec_type
, initial
)
2508 = create_field_decl (get_identifier (name
), type
, rec_type
, 0, 0, 0, 0);
2510 DECL_INITIAL (field
) = initial
;
2514 /* Build a type to be used to represent an aliased object whose nominal
2515 type is an unconstrained array. This consists of a RECORD_TYPE containing
2516 a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2517 ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
2518 is used to represent an arbitrary unconstrained object. Use NAME
2519 as the name of the record. */
2522 build_unc_object_type (template_type
, object_type
, name
)
2527 tree type
= make_node (RECORD_TYPE
);
2528 tree template_field
= create_field_decl (get_identifier ("BOUNDS"),
2529 template_type
, type
, 0, 0, 0, 1);
2530 tree array_field
= create_field_decl (get_identifier ("ARRAY"), object_type
,
2533 TYPE_NAME (type
) = name
;
2534 TYPE_CONTAINS_TEMPLATE_P (type
) = 1;
2535 finish_record_type (type
,
2536 chainon (chainon (NULL_TREE
, template_field
),
2543 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
2544 the normal case this is just two adjustments, but we have more to do
2545 if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
2548 update_pointer_to (old_type
, new_type
)
2552 tree ptr
= TYPE_POINTER_TO (old_type
);
2553 tree ref
= TYPE_REFERENCE_TO (old_type
);
2556 /* If this is the main variant, process all the other variants first. */
2557 if (TYPE_MAIN_VARIANT (old_type
) == old_type
)
2558 for (type
= TYPE_NEXT_VARIANT (old_type
); type
!= 0;
2559 type
= TYPE_NEXT_VARIANT (type
))
2560 update_pointer_to (type
, new_type
);
2562 /* If no pointer or reference, we are done. Otherwise, get the new type with
2563 the same qualifiers as the old type and see if it is the same as the old
2565 if (ptr
== 0 && ref
== 0)
2568 new_type
= build_qualified_type (new_type
, TYPE_QUALS (old_type
));
2569 if (old_type
== new_type
)
2572 /* First handle the simple case. */
2573 if (TREE_CODE (new_type
) != UNCONSTRAINED_ARRAY_TYPE
)
2576 TREE_TYPE (ptr
) = new_type
;
2577 TYPE_POINTER_TO (new_type
) = ptr
;
2580 TREE_TYPE (ref
) = new_type
;
2581 TYPE_REFERENCE_TO (new_type
) = ref
;
2583 if (ptr
!= 0 && TYPE_NAME (ptr
) != 0
2584 && TREE_CODE (TYPE_NAME (ptr
)) == TYPE_DECL
2585 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2586 rest_of_decl_compilation (TYPE_NAME (ptr
), NULL
,
2587 global_bindings_p (), 0);
2588 if (ref
!= 0 && TYPE_NAME (ref
) != 0
2589 && TREE_CODE (TYPE_NAME (ref
)) == TYPE_DECL
2590 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2591 rest_of_decl_compilation (TYPE_NAME (ref
), NULL
,
2592 global_bindings_p (), 0);
2595 /* Now deal with the unconstrained array case. In this case the "pointer"
2596 is actually a RECORD_TYPE where the types of both fields are
2597 pointers to void. In that case, copy the field list from the
2598 old type to the new one and update the fields' context. */
2599 else if (TREE_CODE (ptr
) != RECORD_TYPE
|| ! TYPE_IS_FAT_POINTER_P (ptr
))
2604 tree new_obj_rec
= TYPE_OBJECT_RECORD_TYPE (new_type
);
2609 TYPE_FIELDS (ptr
) = TYPE_FIELDS (TYPE_POINTER_TO (new_type
));
2610 DECL_CONTEXT (TYPE_FIELDS (ptr
)) = ptr
;
2611 DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr
))) = ptr
;
2613 /* Rework the PLACEHOLDER_EXPR inside the reference to the
2616 ??? This is now the only use of gnat_substitute_in_type, which
2617 is now a very "heavy" routine to do this, so it should be replaced
2619 ptr_temp_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr
)));
2620 new_ref
= build (COMPONENT_REF
, ptr_temp_type
,
2621 build (PLACEHOLDER_EXPR
, ptr
),
2622 TREE_CHAIN (TYPE_FIELDS (ptr
)));
2625 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2626 gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2627 TREE_CHAIN (TYPE_FIELDS (ptr
)), new_ref
));
2629 for (var
= TYPE_MAIN_VARIANT (ptr
); var
; var
= TYPE_NEXT_VARIANT (var
))
2630 SET_TYPE_UNCONSTRAINED_ARRAY (var
, new_type
);
2632 TYPE_POINTER_TO (new_type
) = TYPE_REFERENCE_TO (new_type
)
2633 = TREE_TYPE (new_type
) = ptr
;
2635 /* Now handle updating the allocation record, what the thin pointer
2636 points to. Update all pointers from the old record into the new
2637 one, update the types of the fields, and recompute the size. */
2639 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type
), new_obj_rec
);
2641 TREE_TYPE (TYPE_FIELDS (new_obj_rec
)) = TREE_TYPE (ptr_temp_type
);
2642 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2643 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
)));
2644 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2645 = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2646 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2647 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2649 TYPE_SIZE (new_obj_rec
)
2650 = size_binop (PLUS_EXPR
,
2651 DECL_SIZE (TYPE_FIELDS (new_obj_rec
)),
2652 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2653 TYPE_SIZE_UNIT (new_obj_rec
)
2654 = size_binop (PLUS_EXPR
,
2655 DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec
)),
2656 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2657 rest_of_type_compilation (ptr
, global_bindings_p ());
2661 /* Convert a pointer to a constrained array into a pointer to a fat
2662 pointer. This involves making or finding a template. */
2665 convert_to_fat_pointer (type
, expr
)
2669 tree template_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
))));
2670 tree
template, template_addr
;
2671 tree etype
= TREE_TYPE (expr
);
2673 /* If EXPR is a constant of zero, we make a fat pointer that has a null
2674 pointer to the template and array. */
2675 if (integer_zerop (expr
))
2677 gnat_build_constructor
2679 tree_cons (TYPE_FIELDS (type
),
2680 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2681 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2682 convert (build_pointer_type (template_type
),
2686 /* If EXPR is a thin pointer, make the template and data from the record. */
2688 else if (TYPE_THIN_POINTER_P (etype
))
2690 tree fields
= TYPE_FIELDS (TREE_TYPE (etype
));
2692 expr
= save_expr (expr
);
2693 if (TREE_CODE (expr
) == ADDR_EXPR
)
2694 expr
= TREE_OPERAND (expr
, 0);
2696 expr
= build1 (INDIRECT_REF
, TREE_TYPE (etype
), expr
);
2698 template = build_component_ref (expr
, NULL_TREE
, fields
);
2699 expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
2700 build_component_ref (expr
, NULL_TREE
,
2701 TREE_CHAIN (fields
)));
2704 /* Otherwise, build the constructor for the template. */
2705 template = build_template (template_type
, TREE_TYPE (etype
), expr
);
2707 template_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, template);
2709 /* The result is a CONSTRUCTOR for the fat pointer. */
2711 gnat_build_constructor (type
,
2712 tree_cons (TYPE_FIELDS (type
), expr
,
2713 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2714 template_addr
, NULL_TREE
)));
2717 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
2718 is something that is a fat pointer, so convert to it first if it EXPR
2719 is not already a fat pointer. */
2722 convert_to_thin_pointer (type
, expr
)
2726 if (! TYPE_FAT_POINTER_P (TREE_TYPE (expr
)))
2728 = convert_to_fat_pointer
2729 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))), expr
);
2731 /* We get the pointer to the data and use a NOP_EXPR to make it the
2733 expr
= build_component_ref (expr
, NULL_TREE
, TYPE_FIELDS (TREE_TYPE (expr
)));
2734 expr
= build1 (NOP_EXPR
, type
, expr
);
2739 /* Create an expression whose value is that of EXPR,
2740 converted to type TYPE. The TREE_TYPE of the value
2741 is always TYPE. This function implements all reasonable
2742 conversions; callers should filter out those that are
2743 not permitted by the language being compiled. */
2746 convert (type
, expr
)
2749 enum tree_code code
= TREE_CODE (type
);
2750 tree etype
= TREE_TYPE (expr
);
2751 enum tree_code ecode
= TREE_CODE (etype
);
2754 /* If EXPR is already the right type, we are done. */
2758 /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
2760 if (TREE_CODE (expr
) == WITH_RECORD_EXPR
)
2761 return build (WITH_RECORD_EXPR
, type
,
2762 convert (type
, TREE_OPERAND (expr
, 0)),
2763 TREE_OPERAND (expr
, 1));
2765 /* If the input type has padding, remove it by doing a component reference
2766 to the field. If the output type has padding, make a constructor
2767 to build the record. If both input and output have padding and are
2768 of variable size, do this as an unchecked conversion. */
2769 if (ecode
== RECORD_TYPE
&& code
== RECORD_TYPE
2770 && TYPE_IS_PADDING_P (type
) && TYPE_IS_PADDING_P (etype
)
2771 && (! TREE_CONSTANT (TYPE_SIZE (type
))
2772 || ! TREE_CONSTANT (TYPE_SIZE (etype
))))
2774 else if (ecode
== RECORD_TYPE
&& TYPE_IS_PADDING_P (etype
))
2776 /* If we have just converted to this padded type, just get
2777 the inner expression. */
2778 if (TREE_CODE (expr
) == CONSTRUCTOR
2779 && CONSTRUCTOR_ELTS (expr
) != 0
2780 && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr
)) == TYPE_FIELDS (etype
))
2781 return TREE_VALUE (CONSTRUCTOR_ELTS (expr
));
2783 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2784 TYPE_FIELDS (etype
)));
2786 else if (code
== RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
2788 /* If we previously converted from another type and our type is
2789 of variable size, remove the conversion to avoid the need for
2790 variable-size temporaries. */
2791 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
2792 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2793 expr
= TREE_OPERAND (expr
, 0);
2795 /* If we are just removing the padding from expr, convert the original
2796 object if we have variable size. That will avoid the need
2797 for some variable-size temporaries. */
2798 if (TREE_CODE (expr
) == COMPONENT_REF
2799 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == RECORD_TYPE
2800 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr
, 0)))
2801 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2802 return convert (type
, TREE_OPERAND (expr
, 0));
2804 /* If the result type is a padded type with a self-referentially-sized
2805 field and the expression type is a record, do this as an
2806 unchecked converstion. */
2807 else if (TREE_CODE (DECL_SIZE (TYPE_FIELDS (type
))) != INTEGER_CST
2808 && contains_placeholder_p (DECL_SIZE (TYPE_FIELDS (type
)))
2809 && TREE_CODE (etype
) == RECORD_TYPE
)
2810 return unchecked_convert (type
, expr
);
2814 gnat_build_constructor (type
,
2815 tree_cons (TYPE_FIELDS (type
),
2817 (TYPE_FIELDS (type
)),
2822 /* If the input is a biased type, adjust first. */
2823 if (ecode
== INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype
))
2824 return convert (type
, fold (build (PLUS_EXPR
, TREE_TYPE (etype
),
2825 fold (build1 (GNAT_NOP_EXPR
,
2826 TREE_TYPE (etype
), expr
)),
2827 TYPE_MIN_VALUE (etype
))));
2829 /* If the input is a left-justified modular type, we need to extract
2830 the actual object before converting it to any other type with the
2831 exception of an unconstrained array. */
2832 if (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)
2833 && code
!= UNCONSTRAINED_ARRAY_TYPE
)
2834 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2835 TYPE_FIELDS (etype
)));
2837 /* If converting a type that does not contain a template into one
2838 that does, convert to the data type and then build the template. */
2839 if (code
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type
)
2840 && ! (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
)))
2842 tree obj_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2845 gnat_build_constructor
2847 tree_cons (TYPE_FIELDS (type
),
2848 build_template (TREE_TYPE (TYPE_FIELDS (type
)),
2849 obj_type
, NULL_TREE
),
2850 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2851 convert (obj_type
, expr
), NULL_TREE
)));
2854 /* There are some special cases of expressions that we process
2856 switch (TREE_CODE (expr
))
2861 case TRANSFORM_EXPR
:
2863 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
2864 conversion in gnat_expand_expr. NULL_EXPR does not represent
2865 and actual value, so no conversion is needed. */
2866 TREE_TYPE (expr
) = type
;
2871 /* If we are converting a STRING_CST to another constrained array type,
2872 just make a new one in the proper type. Likewise for a
2874 if (code
== ecode
&& AGGREGATE_TYPE_P (etype
)
2875 && ! (TREE_CODE (TYPE_SIZE (etype
)) == INTEGER_CST
2876 && TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
))
2878 expr
= copy_node (expr
);
2879 TREE_TYPE (expr
) = type
;
2885 /* If we are converting between two aggregate types of the same
2886 kind, size, mode, and alignment, just make a new COMPONENT_REF.
2887 This avoid unneeded conversions which makes reference computations
2889 if (code
== ecode
&& TYPE_MODE (type
) == TYPE_MODE (etype
)
2890 && AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
2891 && TYPE_ALIGN (type
) == TYPE_ALIGN (etype
)
2892 && operand_equal_p (TYPE_SIZE (type
), TYPE_SIZE (etype
), 0))
2893 return build (COMPONENT_REF
, type
, TREE_OPERAND (expr
, 0),
2894 TREE_OPERAND (expr
, 1));
2898 case UNCONSTRAINED_ARRAY_REF
:
2899 /* Convert this to the type of the inner array by getting the address of
2900 the array from the template. */
2901 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2902 build_component_ref (TREE_OPERAND (expr
, 0),
2903 get_identifier ("P_ARRAY"),
2905 etype
= TREE_TYPE (expr
);
2906 ecode
= TREE_CODE (etype
);
2909 case VIEW_CONVERT_EXPR
:
2910 if (AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
2911 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2912 return convert (type
, TREE_OPERAND (expr
, 0));
2916 /* If both types are record types, just convert the pointer and
2917 make a new INDIRECT_REF.
2919 ??? Disable this for now since it causes problems with the
2920 code in build_binary_op for MODIFY_EXPR which wants to
2921 strip off conversions. But that code really is a mess and
2922 we need to do this a much better way some time. */
2924 && (TREE_CODE (type
) == RECORD_TYPE
2925 || TREE_CODE (type
) == UNION_TYPE
)
2926 && (TREE_CODE (etype
) == RECORD_TYPE
2927 || TREE_CODE (etype
) == UNION_TYPE
)
2928 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2929 return build_unary_op (INDIRECT_REF
, NULL_TREE
,
2930 convert (build_pointer_type (type
),
2931 TREE_OPERAND (expr
, 0)));
2938 /* Check for converting to a pointer to an unconstrained array. */
2939 if (TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2940 return convert_to_fat_pointer (type
, expr
);
2942 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
)
2943 || (code
== INTEGER_CST
&& ecode
== INTEGER_CST
2944 && (type
== TREE_TYPE (etype
) || etype
== TREE_TYPE (type
))))
2945 return fold (build1 (NOP_EXPR
, type
, expr
));
2950 return build1 (CONVERT_EXPR
, type
, expr
);
2953 if (TYPE_HAS_ACTUAL_BOUNDS_P (type
)
2954 && (ecode
== ARRAY_TYPE
|| ecode
== UNCONSTRAINED_ARRAY_TYPE
))
2955 return unchecked_convert (type
, expr
);
2956 else if (TYPE_BIASED_REPRESENTATION_P (type
))
2957 return fold (build1 (CONVERT_EXPR
, type
,
2958 fold (build (MINUS_EXPR
, TREE_TYPE (type
),
2959 convert (TREE_TYPE (type
), expr
),
2960 TYPE_MIN_VALUE (type
)))));
2962 /* ... fall through ... */
2965 return fold (convert_to_integer (type
, expr
));
2968 case REFERENCE_TYPE
:
2969 /* If converting between two pointers to records denoting
2970 both a template and type, adjust if needed to account
2971 for any differing offsets, since one might be negative. */
2972 if (TYPE_THIN_POINTER_P (etype
) && TYPE_THIN_POINTER_P (type
))
2975 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype
))),
2976 bit_position (TYPE_FIELDS (TREE_TYPE (type
))));
2977 tree byte_diff
= size_binop (CEIL_DIV_EXPR
, bit_diff
,
2978 sbitsize_int (BITS_PER_UNIT
));
2980 expr
= build1 (NOP_EXPR
, type
, expr
);
2981 TREE_CONSTANT (expr
) = TREE_CONSTANT (TREE_OPERAND (expr
, 0));
2982 if (integer_zerop (byte_diff
))
2985 return build_binary_op (PLUS_EXPR
, type
, expr
,
2986 fold (convert_to_pointer (type
, byte_diff
)));
2989 /* If converting to a thin pointer, handle specially. */
2990 if (TYPE_THIN_POINTER_P (type
)
2991 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)) != 0)
2992 return convert_to_thin_pointer (type
, expr
);
2994 /* If converting fat pointer to normal pointer, get the pointer to the
2995 array and then convert it. */
2996 else if (TYPE_FAT_POINTER_P (etype
))
2997 expr
= build_component_ref (expr
, get_identifier ("P_ARRAY"),
3000 return fold (convert_to_pointer (type
, expr
));
3003 return fold (convert_to_real (type
, expr
));
3006 if (TYPE_LEFT_JUSTIFIED_MODULAR_P (type
) && ! AGGREGATE_TYPE_P (etype
))
3008 gnat_build_constructor
3009 (type
, tree_cons (TYPE_FIELDS (type
),
3010 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
3013 /* ... fall through ... */
3016 /* In these cases, assume the front-end has validated the conversion.
3017 If the conversion is valid, it will be a bit-wise conversion, so
3018 it can be viewed as an unchecked conversion. */
3019 return unchecked_convert (type
, expr
);
3022 /* Just validate that the type is indeed that of a field
3023 of the type. Then make the simple conversion. */
3024 for (tem
= TYPE_FIELDS (type
); tem
; tem
= TREE_CHAIN (tem
))
3025 if (TREE_TYPE (tem
) == etype
)
3026 return build1 (CONVERT_EXPR
, type
, expr
);
3030 case UNCONSTRAINED_ARRAY_TYPE
:
3031 /* If EXPR is a constrained array, take its address, convert it to a
3032 fat pointer, and then dereference it. Likewise if EXPR is a
3033 record containing both a template and a constrained array.
3034 Note that a record representing a left justified modular type
3035 always represents a packed constrained array. */
3036 if (ecode
== ARRAY_TYPE
3037 || (ecode
== INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (etype
))
3038 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))
3039 || (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)))
3042 (INDIRECT_REF
, NULL_TREE
,
3043 convert_to_fat_pointer (TREE_TYPE (type
),
3044 build_unary_op (ADDR_EXPR
,
3047 /* Do something very similar for converting one unconstrained
3048 array to another. */
3049 else if (ecode
== UNCONSTRAINED_ARRAY_TYPE
)
3051 build_unary_op (INDIRECT_REF
, NULL_TREE
,
3052 convert (TREE_TYPE (type
),
3053 build_unary_op (ADDR_EXPR
,
3059 return fold (convert_to_complex (type
, expr
));
3066 /* Remove all conversions that are done in EXP. This includes converting
3067 from a padded type or to a left-justified modular type. If TRUE_ADDRESS
3068 is nonzero, always return the address of the containing object even if
3069 the address is not bit-aligned. */
3072 remove_conversions (exp
, true_address
)
3076 switch (TREE_CODE (exp
))
3080 && TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
3081 && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp
)))
3082 return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp
)), 1);
3086 if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp
, 0))) == RECORD_TYPE
3087 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp
, 0))))
3088 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3091 case VIEW_CONVERT_EXPR
: case NON_LVALUE_EXPR
:
3092 case NOP_EXPR
: case CONVERT_EXPR
: case GNAT_NOP_EXPR
:
3093 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3102 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3103 refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
3104 likewise return an expression pointing to the underlying array. */
3107 maybe_unconstrained_array (exp
)
3110 enum tree_code code
= TREE_CODE (exp
);
3113 switch (TREE_CODE (TREE_TYPE (exp
)))
3115 case UNCONSTRAINED_ARRAY_TYPE
:
3116 if (code
== UNCONSTRAINED_ARRAY_REF
)
3119 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
3120 build_component_ref (TREE_OPERAND (exp
, 0),
3121 get_identifier ("P_ARRAY"),
3123 TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp
);
3127 else if (code
== NULL_EXPR
)
3128 return build1 (NULL_EXPR
,
3129 TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3130 (TREE_TYPE (TREE_TYPE (exp
))))),
3131 TREE_OPERAND (exp
, 0));
3133 else if (code
== WITH_RECORD_EXPR
3134 && (TREE_OPERAND (exp
, 0)
3135 != (new = maybe_unconstrained_array
3136 (TREE_OPERAND (exp
, 0)))))
3137 return build (WITH_RECORD_EXPR
, TREE_TYPE (new), new,
3138 TREE_OPERAND (exp
, 1));
3141 if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp
)))
3144 = build_component_ref (exp
, NULL_TREE
,
3145 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp
))));
3146 if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3147 && TYPE_IS_PADDING_P (TREE_TYPE (new)))
3148 new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (new))), new);
3161 /* Return an expression that does an unchecked converstion of EXPR to TYPE. */
3164 unchecked_convert (type
, expr
)
3168 tree etype
= TREE_TYPE (expr
);
3170 /* If the expression is already the right type, we are done. */
3174 /* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
3176 if (TREE_CODE (expr
) == WITH_RECORD_EXPR
)
3177 return build (WITH_RECORD_EXPR
, type
,
3178 unchecked_convert (type
, TREE_OPERAND (expr
, 0)),
3179 TREE_OPERAND (expr
, 1));
3181 /* If both types types are integral just do a normal conversion.
3182 Likewise for a conversion to an unconstrained array. */
3183 if ((((INTEGRAL_TYPE_P (type
)
3184 && ! (TREE_CODE (type
) == INTEGER_TYPE
3185 && TYPE_VAX_FLOATING_POINT_P (type
)))
3186 || (POINTER_TYPE_P (type
) && ! TYPE_THIN_POINTER_P (type
))
3187 || (TREE_CODE (type
) == RECORD_TYPE
3188 && TYPE_LEFT_JUSTIFIED_MODULAR_P (type
)))
3189 && ((INTEGRAL_TYPE_P (etype
)
3190 && ! (TREE_CODE (etype
) == INTEGER_TYPE
3191 && TYPE_VAX_FLOATING_POINT_P (etype
)))
3192 || (POINTER_TYPE_P (etype
) && ! TYPE_THIN_POINTER_P (etype
))
3193 || (TREE_CODE (etype
) == RECORD_TYPE
3194 && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
))))
3195 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3199 if (TREE_CODE (etype
) == INTEGER_TYPE
3200 && TYPE_BIASED_REPRESENTATION_P (etype
))
3202 tree ntype
= copy_type (etype
);
3204 TYPE_BIASED_REPRESENTATION_P (ntype
) = 0;
3205 TYPE_MAIN_VARIANT (ntype
) = ntype
;
3206 expr
= build1 (GNAT_NOP_EXPR
, ntype
, expr
);
3209 if (TREE_CODE (type
) == INTEGER_TYPE
3210 && TYPE_BIASED_REPRESENTATION_P (type
))
3212 rtype
= copy_type (type
);
3213 TYPE_BIASED_REPRESENTATION_P (rtype
) = 0;
3214 TYPE_MAIN_VARIANT (rtype
) = rtype
;
3217 expr
= convert (rtype
, expr
);
3219 expr
= build1 (GNAT_NOP_EXPR
, type
, expr
);
3222 /* If we are converting TO an integral type whose precision is not the
3223 same as its size, first unchecked convert to a record that contains
3224 an object of the output type. Then extract the field. */
3225 else if (INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3226 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3227 GET_MODE_BITSIZE (TYPE_MODE (type
))))
3229 tree rec_type
= make_node (RECORD_TYPE
);
3230 tree field
= create_field_decl (get_identifier ("OBJ"), type
,
3231 rec_type
, 1, 0, 0, 0);
3233 TYPE_FIELDS (rec_type
) = field
;
3234 layout_type (rec_type
);
3236 expr
= unchecked_convert (rec_type
, expr
);
3237 expr
= build_component_ref (expr
, NULL_TREE
, field
);
3240 /* Similarly for integral input type whose precision is not equal to its
3242 else if (INTEGRAL_TYPE_P (etype
) && TYPE_RM_SIZE (etype
) != 0
3243 && 0 != compare_tree_int (TYPE_RM_SIZE (etype
),
3244 GET_MODE_BITSIZE (TYPE_MODE (etype
))))
3246 tree rec_type
= make_node (RECORD_TYPE
);
3248 = create_field_decl (get_identifier ("OBJ"), etype
, rec_type
,
3251 TYPE_FIELDS (rec_type
) = field
;
3252 layout_type (rec_type
);
3254 expr
= gnat_build_constructor (rec_type
, build_tree_list (field
, expr
));
3255 expr
= unchecked_convert (type
, expr
);
3258 /* We have a special case when we are converting between two
3259 unconstrained array types. In that case, take the address,
3260 convert the fat pointer types, and dereference. */
3261 else if (TREE_CODE (etype
) == UNCONSTRAINED_ARRAY_TYPE
3262 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3263 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3264 build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (type
),
3265 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3269 expr
= maybe_unconstrained_array (expr
);
3270 etype
= TREE_TYPE (expr
);
3271 expr
= build1 (VIEW_CONVERT_EXPR
, type
, expr
);
3274 /* If the result is an integral type whose size is not equal to
3275 the size of the underlying machine type, sign- or zero-extend
3276 the result. We need not do this in the case where the input is
3277 an integral type of the same precision and signedness or if the output
3278 is a biased type or if both the input and output are unsigned. */
3279 if (INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3280 && ! (TREE_CODE (type
) == INTEGER_TYPE
3281 && TYPE_BIASED_REPRESENTATION_P (type
))
3282 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3283 GET_MODE_BITSIZE (TYPE_MODE (type
)))
3284 && ! (INTEGRAL_TYPE_P (etype
)
3285 && TREE_UNSIGNED (type
) == TREE_UNSIGNED (etype
)
3286 && operand_equal_p (TYPE_RM_SIZE (type
),
3287 (TYPE_RM_SIZE (etype
) != 0
3288 ? TYPE_RM_SIZE (etype
) : TYPE_SIZE (etype
)),
3290 && ! (TREE_UNSIGNED (type
) && TREE_UNSIGNED (etype
)))
3292 tree base_type
= gnat_type_for_mode (TYPE_MODE (type
),
3293 TREE_UNSIGNED (type
));
3295 = convert (base_type
,
3296 size_binop (MINUS_EXPR
,
3298 (GET_MODE_BITSIZE (TYPE_MODE (type
))),
3299 TYPE_RM_SIZE (type
)));
3302 build_binary_op (RSHIFT_EXPR
, base_type
,
3303 build_binary_op (LSHIFT_EXPR
, base_type
,
3304 convert (base_type
, expr
),
3309 /* An unchecked conversion should never raise Constraint_Error. The code
3310 below assumes that GCC's conversion routines overflow the same way that
3311 the underlying hardware does. This is probably true. In the rare case
3312 when it is false, we can rely on the fact that such conversions are
3313 erroneous anyway. */
3314 if (TREE_CODE (expr
) == INTEGER_CST
)
3315 TREE_OVERFLOW (expr
) = TREE_CONSTANT_OVERFLOW (expr
) = 0;
3317 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3318 show no longer constant. */
3319 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
3320 && ! operand_equal_p (TYPE_SIZE_UNIT (type
), TYPE_SIZE_UNIT (etype
), 1))
3321 TREE_CONSTANT (expr
) = 0;
3326 #include "gt-ada-utils.h"
3327 #include "gtype-ada.h"