1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
42 #include "tree-inline.h"
43 #include "tree-gimple.h"
44 #include "tree-dump.h"
60 #ifndef MAX_FIXED_MODE_SIZE
61 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
64 #ifndef MAX_BITS_PER_WORD
65 #define MAX_BITS_PER_WORD BITS_PER_WORD
68 /* If nonzero, pretend we are allocating at global level. */
71 /* Tree nodes for the various types and decls we create. */
72 tree gnat_std_decls
[(int) ADT_LAST
];
74 /* Functions to call for each of the possible raise reasons. */
75 tree gnat_raise_decls
[(int) LAST_REASON_CODE
+ 1];
77 /* Associates a GNAT tree node to a GCC tree node. It is used in
78 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
79 of `save_gnu_tree' for more info. */
80 static GTY((length ("max_gnat_nodes"))) tree
*associate_gnat_to_gnu
;
82 /* This variable keeps a table for types for each precision so that we only
83 allocate each of them once. Signed and unsigned types are kept separate.
85 Note that these types are only used when fold-const requests something
86 special. Perhaps we should NOT share these types; we'll see how it
88 static GTY(()) tree signed_and_unsigned_types
[2 * MAX_BITS_PER_WORD
+ 1][2];
90 /* Likewise for float types, but record these by mode. */
91 static GTY(()) tree float_types
[NUM_MACHINE_MODES
];
93 /* For each binding contour we allocate a binding_level structure to indicate
96 struct gnat_binding_level
GTY((chain_next ("%h.chain")))
98 /* The binding level containing this one (the enclosing binding level). */
99 struct gnat_binding_level
*chain
;
100 /* The BLOCK node for this level. */
102 /* If nonzero, the setjmp buffer that needs to be updated for any
103 variable-sized definition within this context. */
107 /* The binding level currently in effect. */
108 static GTY(()) struct gnat_binding_level
*current_binding_level
;
110 /* A chain of gnat_binding_level structures awaiting reuse. */
111 static GTY((deletable
)) struct gnat_binding_level
*free_binding_level
;
113 /* A chain of unused BLOCK nodes. */
114 static GTY((deletable
)) tree free_block_chain
;
116 struct language_function
GTY(())
121 static void gnat_define_builtin (const char *, tree
, int, const char *, bool);
122 static void gnat_install_builtins (void);
123 static tree
merge_sizes (tree
, tree
, tree
, bool, bool);
124 static tree
compute_related_constant (tree
, tree
);
125 static tree
split_plus (tree
, tree
*);
126 static bool value_zerop (tree
);
127 static void gnat_gimplify_function (tree
);
128 static tree
float_type_for_precision (int, enum machine_mode
);
129 static tree
convert_to_fat_pointer (tree
, tree
);
130 static tree
convert_to_thin_pointer (tree
, tree
);
131 static tree
make_descriptor_field (const char *,tree
, tree
, tree
);
132 static bool value_factor_p (tree
, HOST_WIDE_INT
);
133 static bool potential_alignment_gap (tree
, tree
, tree
);
135 /* Initialize the association of GNAT nodes to GCC trees. */
138 init_gnat_to_gnu (void)
140 associate_gnat_to_gnu
141 = (tree
*) ggc_alloc_cleared (max_gnat_nodes
* sizeof (tree
));
144 /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
145 which is to be associated with GNAT_ENTITY. Such GCC tree node is always
146 a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
148 If GNU_DECL is zero, a previous association is to be reset. */
151 save_gnu_tree (Entity_Id gnat_entity
, tree gnu_decl
, bool no_check
)
153 /* Check that GNAT_ENTITY is not already defined and that it is being set
154 to something which is a decl. Raise gigi 401 if not. Usually, this
155 means GNAT_ENTITY is defined twice, but occasionally is due to some
157 gcc_assert (!gnu_decl
158 || (!associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]
159 && (no_check
|| DECL_P (gnu_decl
))));
160 associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] = gnu_decl
;
163 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
164 Return the ..._DECL node that was associated with it. If there is no tree
165 node associated with GNAT_ENTITY, abort.
167 In some cases, such as delayed elaboration or expressions that need to
168 be elaborated only once, GNAT_ENTITY is really not an entity. */
171 get_gnu_tree (Entity_Id gnat_entity
)
173 gcc_assert (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]);
174 return associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
];
177 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
180 present_gnu_tree (Entity_Id gnat_entity
)
182 return (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]) != 0;
186 /* Return non-zero if we are currently in the global binding level. */
189 global_bindings_p (void)
191 return ((force_global
|| !current_function_decl
) ? -1 : 0);
194 /* Enter a new binding level. */
199 struct gnat_binding_level
*newlevel
= NULL
;
201 /* Reuse a struct for this binding level, if there is one. */
202 if (free_binding_level
)
204 newlevel
= free_binding_level
;
205 free_binding_level
= free_binding_level
->chain
;
209 = (struct gnat_binding_level
*)
210 ggc_alloc (sizeof (struct gnat_binding_level
));
212 /* Use a free BLOCK, if any; otherwise, allocate one. */
213 if (free_block_chain
)
215 newlevel
->block
= free_block_chain
;
216 free_block_chain
= TREE_CHAIN (free_block_chain
);
217 TREE_CHAIN (newlevel
->block
) = NULL_TREE
;
220 newlevel
->block
= make_node (BLOCK
);
222 /* Point the BLOCK we just made to its parent. */
223 if (current_binding_level
)
224 BLOCK_SUPERCONTEXT (newlevel
->block
) = current_binding_level
->block
;
226 BLOCK_VARS (newlevel
->block
) = BLOCK_SUBBLOCKS (newlevel
->block
) = NULL_TREE
;
227 TREE_USED (newlevel
->block
) = 1;
229 /* Add this level to the front of the chain (stack) of levels that are
231 newlevel
->chain
= current_binding_level
;
232 newlevel
->jmpbuf_decl
= NULL_TREE
;
233 current_binding_level
= newlevel
;
236 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
237 and point FNDECL to this BLOCK. */
240 set_current_block_context (tree fndecl
)
242 BLOCK_SUPERCONTEXT (current_binding_level
->block
) = fndecl
;
243 DECL_INITIAL (fndecl
) = current_binding_level
->block
;
246 /* Set the jmpbuf_decl for the current binding level to DECL. */
249 set_block_jmpbuf_decl (tree decl
)
251 current_binding_level
->jmpbuf_decl
= decl
;
254 /* Get the jmpbuf_decl, if any, for the current binding level. */
257 get_block_jmpbuf_decl ()
259 return current_binding_level
->jmpbuf_decl
;
262 /* Exit a binding level. Set any BLOCK into the current code group. */
267 struct gnat_binding_level
*level
= current_binding_level
;
268 tree block
= level
->block
;
270 BLOCK_VARS (block
) = nreverse (BLOCK_VARS (block
));
271 BLOCK_SUBBLOCKS (block
) = nreverse (BLOCK_SUBBLOCKS (block
));
273 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
274 are no variables free the block and merge its subblocks into those of its
275 parent block. Otherwise, add it to the list of its parent. */
276 if (TREE_CODE (BLOCK_SUPERCONTEXT (block
)) == FUNCTION_DECL
)
278 else if (BLOCK_VARS (block
) == NULL_TREE
)
280 BLOCK_SUBBLOCKS (level
->chain
->block
)
281 = chainon (BLOCK_SUBBLOCKS (block
),
282 BLOCK_SUBBLOCKS (level
->chain
->block
));
283 TREE_CHAIN (block
) = free_block_chain
;
284 free_block_chain
= block
;
288 TREE_CHAIN (block
) = BLOCK_SUBBLOCKS (level
->chain
->block
);
289 BLOCK_SUBBLOCKS (level
->chain
->block
) = block
;
290 TREE_USED (block
) = 1;
291 set_block_for_group (block
);
294 /* Free this binding structure. */
295 current_binding_level
= level
->chain
;
296 level
->chain
= free_binding_level
;
297 free_binding_level
= level
;
300 /* Insert BLOCK at the end of the list of subblocks of the
301 current binding level. This is used when a BIND_EXPR is expanded,
302 to handle the BLOCK node inside the BIND_EXPR. */
305 insert_block (tree block
)
307 TREE_USED (block
) = 1;
308 TREE_CHAIN (block
) = BLOCK_SUBBLOCKS (current_binding_level
->block
);
309 BLOCK_SUBBLOCKS (current_binding_level
->block
) = block
;
312 /* Records a ..._DECL node DECL as belonging to the current lexical scope
313 and uses GNAT_NODE for location information. */
316 gnat_pushdecl (tree decl
, Node_Id gnat_node
)
318 /* If at top level, there is no context. But PARM_DECLs always go in the
319 level of its function. */
320 if (global_bindings_p () && TREE_CODE (decl
) != PARM_DECL
)
321 DECL_CONTEXT (decl
) = 0;
323 DECL_CONTEXT (decl
) = current_function_decl
;
325 /* Set the location of DECL and emit a declaration for it. */
326 if (Present (gnat_node
))
327 Sloc_to_locus (Sloc (gnat_node
), &DECL_SOURCE_LOCATION (decl
));
328 add_decl_expr (decl
, gnat_node
);
330 /* Put the declaration on the list. The list of declarations is in reverse
331 order. The list will be reversed later. We don't do this for global
332 variables. Also, don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
333 the list. They will cause trouble with the debugger and aren't needed
335 if (!global_bindings_p ()
336 && (TREE_CODE (decl
) != TYPE_DECL
337 || TREE_CODE (TREE_TYPE (decl
)) != UNCONSTRAINED_ARRAY_TYPE
))
339 TREE_CHAIN (decl
) = BLOCK_VARS (current_binding_level
->block
);
340 BLOCK_VARS (current_binding_level
->block
) = decl
;
343 /* For the declaration of a type, set its name if it either is not already
344 set, was set to an IDENTIFIER_NODE, indicating an internal name,
345 or if the previous type name was not derived from a source name.
346 We'd rather have the type named with a real name and all the pointer
347 types to the same object have the same POINTER_TYPE node. Code in this
348 function in c-decl.c makes a copy of the type node here, but that may
349 cause us trouble with incomplete types, so let's not try it (at least
352 if (TREE_CODE (decl
) == TYPE_DECL
354 && (!TYPE_NAME (TREE_TYPE (decl
))
355 || TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == IDENTIFIER_NODE
356 || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == TYPE_DECL
357 && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl
)))
358 && !DECL_ARTIFICIAL (decl
))))
359 TYPE_NAME (TREE_TYPE (decl
)) = decl
;
361 if (TREE_CODE (decl
) != CONST_DECL
)
362 rest_of_decl_compilation (decl
, global_bindings_p (), 0);
365 /* Do little here. Set up the standard declarations later after the
366 front end has been run. */
369 gnat_init_decl_processing (void)
373 /* Make the binding_level structure for global names. */
374 current_function_decl
= 0;
375 current_binding_level
= 0;
376 free_binding_level
= 0;
379 build_common_tree_nodes (true, true);
381 /* In Ada, we use a signed type for SIZETYPE. Use the signed type
382 corresponding to the size of Pmode. In most cases when ptr_mode and
383 Pmode differ, C will use the width of ptr_mode as sizetype. But we get
384 far better code using the width of Pmode. Make this here since we need
385 this before we can expand the GNAT types. */
386 size_type_node
= gnat_type_for_size (GET_MODE_BITSIZE (Pmode
), 0);
387 set_sizetype (size_type_node
);
388 build_common_tree_nodes_2 (0);
390 /* Give names and make TYPE_DECLs for common types. */
391 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier (SIZE_TYPE
), sizetype
),
393 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
396 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
399 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("long integer"),
400 long_integer_type_node
),
403 ptr_void_type_node
= build_pointer_type (void_type_node
);
405 gnat_install_builtins ();
408 /* Define a builtin function. This is temporary and is just being done
409 to initialize *_built_in_decls for the middle-end. We'll want
410 to do full builtin processing soon. */
413 gnat_define_builtin (const char *name
, tree type
,
414 int function_code
, const char *library_name
, bool const_p
)
416 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
418 DECL_EXTERNAL (decl
) = 1;
419 TREE_PUBLIC (decl
) = 1;
421 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
422 make_decl_rtl (decl
);
423 gnat_pushdecl (decl
, Empty
);
424 DECL_BUILT_IN_CLASS (decl
) = BUILT_IN_NORMAL
;
425 DECL_FUNCTION_CODE (decl
) = function_code
;
426 TREE_READONLY (decl
) = const_p
;
428 implicit_built_in_decls
[function_code
] = decl
;
429 built_in_decls
[function_code
] = decl
;
432 /* Install the builtin functions the middle-end needs. */
435 gnat_install_builtins ()
440 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, void_list_node
);
441 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, tmp
);
442 ftype
= build_function_type (long_integer_type_node
, tmp
);
443 gnat_define_builtin ("__builtin_expect", ftype
, BUILT_IN_EXPECT
,
444 "__builtin_expect", true);
446 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
447 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
448 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
449 ftype
= build_function_type (ptr_void_type_node
, tmp
);
450 gnat_define_builtin ("__builtin_memcpy", ftype
, BUILT_IN_MEMCPY
,
453 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
454 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
455 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
456 ftype
= build_function_type (integer_type_node
, tmp
);
457 gnat_define_builtin ("__builtin_memcmp", ftype
, BUILT_IN_MEMCMP
,
460 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
461 tmp
= tree_cons (NULL_TREE
, integer_type_node
, tmp
);
462 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
463 ftype
= build_function_type (integer_type_node
, tmp
);
464 gnat_define_builtin ("__builtin_memset", ftype
, BUILT_IN_MEMSET
,
467 tmp
= tree_cons (NULL_TREE
, integer_type_node
, void_list_node
);
468 ftype
= build_function_type (integer_type_node
, tmp
);
469 gnat_define_builtin ("__builtin_clz", ftype
, BUILT_IN_CLZ
, "clz", true);
471 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, void_list_node
);
472 ftype
= build_function_type (integer_type_node
, tmp
);
473 gnat_define_builtin ("__builtin_clzl", ftype
, BUILT_IN_CLZL
, "clzl", true);
475 tmp
= tree_cons (NULL_TREE
, long_long_integer_type_node
, void_list_node
);
476 ftype
= build_function_type (integer_type_node
, tmp
);
477 gnat_define_builtin ("__builtin_clzll", ftype
, BUILT_IN_CLZLL
, "clzll",
480 /* The init_trampoline and adjust_trampoline builtins aren't used directly.
481 They are inserted during lowering of nested functions. */
483 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
484 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
485 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
486 ftype
= build_function_type (void_type_node
, tmp
);
487 gnat_define_builtin ("__builtin_init_trampoline", ftype
,
488 BUILT_IN_INIT_TRAMPOLINE
, "init_trampoline", false);
490 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
491 ftype
= build_function_type (ptr_void_type_node
, tmp
);
492 gnat_define_builtin ("__builtin_adjust_trampoline", ftype
,
493 BUILT_IN_ADJUST_TRAMPOLINE
, "adjust_trampoline", true);
495 /* The stack_save, stack_restore, and alloca builtins aren't used directly.
496 They are inserted during gimplification to implement variable sized stack
499 ftype
= build_function_type (ptr_void_type_node
, void_list_node
);
500 gnat_define_builtin ("__builtin_stack_save", ftype
, BUILT_IN_STACK_SAVE
,
501 "stack_save", false);
503 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
504 ftype
= build_function_type (void_type_node
, tmp
);
505 gnat_define_builtin ("__builtin_stack_restore", ftype
,
506 BUILT_IN_STACK_RESTORE
, "stack_restore", false);
508 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
509 ftype
= build_function_type (ptr_void_type_node
, tmp
);
510 gnat_define_builtin ("__builtin_alloca", ftype
, BUILT_IN_ALLOCA
,
513 /* Target specific builtins, such as the AltiVec family on ppc. */
514 targetm
.init_builtins ();
517 /* Create the predefined scalar types such as `integer_type_node' needed
518 in the gcc back-end and initialize the global binding level. */
521 init_gigi_decls (tree long_long_float_type
, tree exception_type
)
526 /* Set the types that GCC and Gigi use from the front end. We would like
527 to do this for char_type_node, but it needs to correspond to the C
529 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
531 /* In this case, the builtin floating point types are VAX float,
532 so make up a type for use. */
533 longest_float_type_node
= make_node (REAL_TYPE
);
534 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
535 layout_type (longest_float_type_node
);
536 create_type_decl (get_identifier ("longest float type"),
537 longest_float_type_node
, NULL
, false, true, Empty
);
540 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
542 except_type_node
= TREE_TYPE (exception_type
);
544 unsigned_type_node
= gnat_type_for_size (INT_TYPE_SIZE
, 1);
545 create_type_decl (get_identifier ("unsigned int"), unsigned_type_node
,
546 NULL
, false, true, Empty
);
548 void_type_decl_node
= create_type_decl (get_identifier ("void"),
549 void_type_node
, NULL
, false, true,
552 void_ftype
= build_function_type (void_type_node
, NULL_TREE
);
553 ptr_void_ftype
= build_pointer_type (void_ftype
);
555 /* Now declare runtime functions. */
556 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
558 /* malloc is a function declaration tree for a function to allocate
560 malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"),
562 build_function_type (ptr_void_type_node
,
563 tree_cons (NULL_TREE
,
566 NULL_TREE
, false, true, true, NULL
,
569 /* free is a function declaration tree for a function to free memory. */
571 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
572 build_function_type (void_type_node
,
573 tree_cons (NULL_TREE
,
576 NULL_TREE
, false, true, true, NULL
, Empty
);
578 /* Make the types and functions used for exception processing. */
580 = build_array_type (gnat_type_for_mode (Pmode
, 0),
581 build_index_type (build_int_cst (NULL_TREE
, 5)));
582 create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type
, NULL
,
584 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
586 /* Functions to get and set the jumpbuf pointer for the current thread. */
588 = create_subprog_decl
589 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
590 NULL_TREE
, build_function_type (jmpbuf_ptr_type
, NULL_TREE
),
591 NULL_TREE
, false, true, true, NULL
, Empty
);
594 = create_subprog_decl
595 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
597 build_function_type (void_type_node
,
598 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
599 NULL_TREE
, false, true, true, NULL
, Empty
);
601 /* Function to get the current exception. */
603 = create_subprog_decl
604 (get_identifier ("system__soft_links__get_gnat_exception"),
606 build_function_type (build_pointer_type (except_type_node
), NULL_TREE
),
607 NULL_TREE
, false, true, true, NULL
, Empty
);
609 /* Functions that raise exceptions. */
611 = create_subprog_decl
612 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
613 build_function_type (void_type_node
,
614 tree_cons (NULL_TREE
,
615 build_pointer_type (except_type_node
),
617 NULL_TREE
, false, true, true, NULL
, Empty
);
619 /* Dummy objects to materialize "others" and "all others" in the exception
620 tables. These are exported by a-exexpr.adb, so see this unit for the
624 = create_var_decl (get_identifier ("OTHERS"),
625 get_identifier ("__gnat_others_value"),
626 integer_type_node
, 0, 1, 0, 1, 1, 0, Empty
);
629 = create_var_decl (get_identifier ("ALL_OTHERS"),
630 get_identifier ("__gnat_all_others_value"),
631 integer_type_node
, 0, 1, 0, 1, 1, 0, Empty
);
633 /* Hooks to call when entering/leaving an exception handler. */
635 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
636 build_function_type (void_type_node
,
637 tree_cons (NULL_TREE
,
640 NULL_TREE
, false, true, true, NULL
, Empty
);
643 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
644 build_function_type (void_type_node
,
645 tree_cons (NULL_TREE
,
648 NULL_TREE
, false, true, true, NULL
, Empty
);
650 /* If in no exception handlers mode, all raise statements are redirected to
651 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
652 this procedure will never be called in this mode. */
653 if (No_Exception_Handlers_Set ())
656 = create_subprog_decl
657 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
658 build_function_type (void_type_node
,
659 tree_cons (NULL_TREE
,
660 build_pointer_type (char_type_node
),
661 tree_cons (NULL_TREE
,
664 NULL_TREE
, false, true, true, NULL
, Empty
);
666 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
667 gnat_raise_decls
[i
] = decl
;
670 /* Otherwise, make one decl for each exception reason. */
671 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
675 sprintf (name
, "__gnat_rcheck_%.2d", i
);
677 = create_subprog_decl
678 (get_identifier (name
), NULL_TREE
,
679 build_function_type (void_type_node
,
680 tree_cons (NULL_TREE
,
683 tree_cons (NULL_TREE
,
686 NULL_TREE
, false, true, true, NULL
, Empty
);
689 /* Indicate that these never return. */
690 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
691 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
692 TREE_TYPE (raise_nodefer_decl
)
693 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
696 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
698 TREE_THIS_VOLATILE (gnat_raise_decls
[i
]) = 1;
699 TREE_SIDE_EFFECTS (gnat_raise_decls
[i
]) = 1;
700 TREE_TYPE (gnat_raise_decls
[i
])
701 = build_qualified_type (TREE_TYPE (gnat_raise_decls
[i
]),
705 /* setjmp returns an integer and has one operand, which is a pointer to
708 = create_subprog_decl
709 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
710 build_function_type (integer_type_node
,
711 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
712 NULL_TREE
, false, true, true, NULL
, Empty
);
714 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
715 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
717 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
719 update_setjmp_buf_decl
720 = create_subprog_decl
721 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
722 build_function_type (void_type_node
,
723 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
724 NULL_TREE
, false, true, true, NULL
, Empty
);
726 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl
) = BUILT_IN_NORMAL
;
727 DECL_FUNCTION_CODE (update_setjmp_buf_decl
) = BUILT_IN_UPDATE_SETJMP_BUF
;
729 main_identifier_node
= get_identifier ("main");
732 /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes
733 (FIELDLIST), finish constructing the record or union type. If HAS_REP is
734 true, this record has a rep clause; don't call layout_type but merely set
735 the size and alignment ourselves. If DEFER_DEBUG is true, do not call
736 the debugging routines on this type; it will be done later. */
739 finish_record_type (tree record_type
, tree fieldlist
, bool has_rep
,
742 enum tree_code code
= TREE_CODE (record_type
);
743 tree ada_size
= bitsize_zero_node
;
744 tree size
= bitsize_zero_node
;
745 bool var_size
= false;
746 bool had_size
= TYPE_SIZE (record_type
) != 0;
747 bool had_size_unit
= TYPE_SIZE_UNIT (record_type
) != 0;
750 TYPE_FIELDS (record_type
) = fieldlist
;
751 TYPE_STUB_DECL (record_type
)
752 = build_decl (TYPE_DECL
, NULL_TREE
, record_type
);
754 /* We don't need both the typedef name and the record name output in
755 the debugging information, since they are the same. */
756 DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type
)) = 1;
758 /* Globally initialize the record first. If this is a rep'ed record,
759 that just means some initializations; otherwise, layout the record. */
763 TYPE_ALIGN (record_type
) = MAX (BITS_PER_UNIT
, TYPE_ALIGN (record_type
));
764 TYPE_MODE (record_type
) = BLKmode
;
767 TYPE_SIZE_UNIT (record_type
) = size_zero_node
;
770 TYPE_SIZE (record_type
) = bitsize_zero_node
;
771 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
772 out just like a UNION_TYPE, since the size will be fixed. */
773 else if (code
== QUAL_UNION_TYPE
)
778 /* Ensure there isn't a size already set. There can be in an error
779 case where there is a rep clause but all fields have errors and
780 no longer have a position. */
781 TYPE_SIZE (record_type
) = 0;
782 layout_type (record_type
);
785 /* At this point, the position and size of each field is known. It was
786 either set before entry by a rep clause, or by laying out the type above.
788 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
789 to compute the Ada size; the GCC size and alignment (for rep'ed records
790 that are not padding types); and the mode (for rep'ed records). We also
791 clear the DECL_BIT_FIELD indication for the cases we know have not been
792 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
794 if (code
== QUAL_UNION_TYPE
)
795 fieldlist
= nreverse (fieldlist
);
797 for (field
= fieldlist
; field
; field
= TREE_CHAIN (field
))
799 tree pos
= bit_position (field
);
801 tree type
= TREE_TYPE (field
);
802 tree this_size
= DECL_SIZE (field
);
803 tree this_ada_size
= DECL_SIZE (field
);
805 /* We need to make an XVE/XVU record if any field has variable size,
806 whether or not the record does. For example, if we have an union,
807 it may be that all fields, rounded up to the alignment, have the
808 same size, in which case we'll use that size. But the debug
809 output routines (except Dwarf2) won't be able to output the fields,
810 so we need to make the special record. */
811 if (TREE_CODE (this_size
) != INTEGER_CST
)
814 if ((TREE_CODE (type
) == RECORD_TYPE
|| TREE_CODE (type
) == UNION_TYPE
815 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
816 && !TYPE_IS_FAT_POINTER_P (type
)
817 && !TYPE_CONTAINS_TEMPLATE_P (type
)
818 && TYPE_ADA_SIZE (type
))
819 this_ada_size
= TYPE_ADA_SIZE (type
);
821 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
822 if (DECL_BIT_FIELD (field
) && !STRICT_ALIGNMENT
823 && value_factor_p (pos
, BITS_PER_UNIT
)
824 && operand_equal_p (this_size
, TYPE_SIZE (type
), 0))
825 DECL_BIT_FIELD (field
) = 0;
827 /* If we still have DECL_BIT_FIELD set at this point, we know the field
828 is technically not addressable. Except that it can actually be
829 addressed if the field is BLKmode and happens to be properly
831 DECL_NONADDRESSABLE_P (field
)
832 |= DECL_BIT_FIELD (field
) && DECL_MODE (field
) != BLKmode
;
834 if (has_rep
&& !DECL_BIT_FIELD (field
))
835 TYPE_ALIGN (record_type
)
836 = MAX (TYPE_ALIGN (record_type
), DECL_ALIGN (field
));
841 ada_size
= size_binop (MAX_EXPR
, ada_size
, this_ada_size
);
842 size
= size_binop (MAX_EXPR
, size
, this_size
);
845 case QUAL_UNION_TYPE
:
847 = fold (build3 (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
848 this_ada_size
, ada_size
));
849 size
= fold (build3 (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
854 /* Since we know here that all fields are sorted in order of
855 increasing bit position, the size of the record is one
856 higher than the ending bit of the last field processed
857 unless we have a rep clause, since in that case we might
858 have a field outside a QUAL_UNION_TYPE that has a higher ending
859 position. So use a MAX in that case. Also, if this field is a
860 QUAL_UNION_TYPE, we need to take into account the previous size in
861 the case of empty variants. */
863 = merge_sizes (ada_size
, pos
, this_ada_size
,
864 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
865 size
= merge_sizes (size
, pos
, this_size
,
866 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
874 if (code
== QUAL_UNION_TYPE
)
875 nreverse (fieldlist
);
877 /* If this is a padding record, we never want to make the size smaller than
878 what was specified in it, if any. */
879 if (TREE_CODE (record_type
) == RECORD_TYPE
880 && TYPE_IS_PADDING_P (record_type
) && TYPE_SIZE (record_type
))
881 size
= TYPE_SIZE (record_type
);
883 /* Now set any of the values we've just computed that apply. */
884 if (!TYPE_IS_FAT_POINTER_P (record_type
)
885 && !TYPE_CONTAINS_TEMPLATE_P (record_type
))
886 SET_TYPE_ADA_SIZE (record_type
, ada_size
);
891 = (had_size_unit
? TYPE_SIZE_UNIT (record_type
)
892 : convert (sizetype
, size_binop (CEIL_DIV_EXPR
, size
,
893 bitsize_unit_node
)));
895 TYPE_SIZE (record_type
) = round_up (size
, TYPE_ALIGN (record_type
));
896 TYPE_SIZE_UNIT (record_type
)
897 = round_up (size_unit
, TYPE_ALIGN (record_type
) / BITS_PER_UNIT
);
899 compute_record_mode (record_type
);
904 /* If this record is of variable size, rename it so that the
905 debugger knows it is and make a new, parallel, record
906 that tells the debugger how the record is laid out. See
907 exp_dbug.ads. But don't do this for records that are padding
908 since they confuse GDB. */
910 && !(TREE_CODE (record_type
) == RECORD_TYPE
911 && TYPE_IS_PADDING_P (record_type
)))
914 = make_node (TREE_CODE (record_type
) == QUAL_UNION_TYPE
915 ? UNION_TYPE
: TREE_CODE (record_type
));
916 tree orig_name
= TYPE_NAME (record_type
);
918 = (TREE_CODE (orig_name
) == TYPE_DECL
? DECL_NAME (orig_name
)
921 = concat_id_with_name (orig_id
,
922 TREE_CODE (record_type
) == QUAL_UNION_TYPE
924 tree last_pos
= bitsize_zero_node
;
926 tree prev_old_field
= 0;
928 TYPE_NAME (new_record_type
) = new_id
;
929 TYPE_ALIGN (new_record_type
) = BIGGEST_ALIGNMENT
;
930 TYPE_STUB_DECL (new_record_type
)
931 = build_decl (TYPE_DECL
, NULL_TREE
, new_record_type
);
932 DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type
)) = 1;
933 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type
))
934 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type
));
935 TYPE_SIZE (new_record_type
) = size_int (TYPE_ALIGN (record_type
));
936 TYPE_SIZE_UNIT (new_record_type
)
937 = size_int (TYPE_ALIGN (record_type
) / BITS_PER_UNIT
);
939 /* Now scan all the fields, replacing each field with a new
940 field corresponding to the new encoding. */
941 for (old_field
= TYPE_FIELDS (record_type
); old_field
;
942 old_field
= TREE_CHAIN (old_field
))
944 tree field_type
= TREE_TYPE (old_field
);
945 tree field_name
= DECL_NAME (old_field
);
947 tree curpos
= bit_position (old_field
);
949 unsigned int align
= 0;
952 /* See how the position was modified from the last position.
954 There are two basic cases we support: a value was added
955 to the last position or the last position was rounded to
956 a boundary and they something was added. Check for the
957 first case first. If not, see if there is any evidence
958 of rounding. If so, round the last position and try
961 If this is a union, the position can be taken as zero. */
963 if (TREE_CODE (new_record_type
) == UNION_TYPE
)
964 pos
= bitsize_zero_node
, align
= 0;
966 pos
= compute_related_constant (curpos
, last_pos
);
968 if (!pos
&& TREE_CODE (curpos
) == MULT_EXPR
969 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
)
971 align
= TREE_INT_CST_LOW (TREE_OPERAND (curpos
, 1));
972 pos
= compute_related_constant (curpos
,
973 round_up (last_pos
, align
));
975 else if (!pos
&& TREE_CODE (curpos
) == PLUS_EXPR
976 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
977 && TREE_CODE (TREE_OPERAND (curpos
, 0)) == MULT_EXPR
978 && host_integerp (TREE_OPERAND
979 (TREE_OPERAND (curpos
, 0), 1),
984 (TREE_OPERAND (TREE_OPERAND (curpos
, 0), 1), 1);
985 pos
= compute_related_constant (curpos
,
986 round_up (last_pos
, align
));
988 else if (potential_alignment_gap (prev_old_field
, old_field
,
991 align
= TYPE_ALIGN (field_type
);
992 pos
= compute_related_constant (curpos
,
993 round_up (last_pos
, align
));
996 /* If we can't compute a position, set it to zero.
998 ??? We really should abort here, but it's too much work
999 to get this correct for all cases. */
1002 pos
= bitsize_zero_node
;
1004 /* See if this type is variable-size and make a new type
1005 and indicate the indirection if so. */
1006 if (TREE_CODE (DECL_SIZE (old_field
)) != INTEGER_CST
)
1008 field_type
= build_pointer_type (field_type
);
1012 /* Make a new field name, if necessary. */
1013 if (var
|| align
!= 0)
1018 sprintf (suffix
, "XV%c%u", var
? 'L' : 'A',
1019 align
/ BITS_PER_UNIT
);
1021 strcpy (suffix
, "XVL");
1023 field_name
= concat_id_with_name (field_name
, suffix
);
1026 new_field
= create_field_decl (field_name
, field_type
,
1028 DECL_SIZE (old_field
), pos
, 0);
1029 TREE_CHAIN (new_field
) = TYPE_FIELDS (new_record_type
);
1030 TYPE_FIELDS (new_record_type
) = new_field
;
1032 /* If old_field is a QUAL_UNION_TYPE, take its size as being
1033 zero. The only time it's not the last field of the record
1034 is when there are other components at fixed positions after
1035 it (meaning there was a rep clause for every field) and we
1036 want to be able to encode them. */
1037 last_pos
= size_binop (PLUS_EXPR
, bit_position (old_field
),
1038 (TREE_CODE (TREE_TYPE (old_field
))
1041 : DECL_SIZE (old_field
));
1042 prev_old_field
= old_field
;
1045 TYPE_FIELDS (new_record_type
)
1046 = nreverse (TYPE_FIELDS (new_record_type
));
1048 rest_of_type_compilation (new_record_type
, global_bindings_p ());
1051 rest_of_type_compilation (record_type
, global_bindings_p ());
1055 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1056 with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
1057 if this represents a QUAL_UNION_TYPE in which case we must look for
1058 COND_EXPRs and replace a value of zero with the old size. If HAS_REP
1059 is nonzero, we must take the MAX of the end position of this field
1060 with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
1062 We return an expression for the size. */
1065 merge_sizes (tree last_size
, tree first_bit
, tree size
, bool special
,
1068 tree type
= TREE_TYPE (last_size
);
1071 if (!special
|| TREE_CODE (size
) != COND_EXPR
)
1073 new = size_binop (PLUS_EXPR
, first_bit
, size
);
1075 new = size_binop (MAX_EXPR
, last_size
, new);
1079 new = fold (build3 (COND_EXPR
, type
, TREE_OPERAND (size
, 0),
1080 integer_zerop (TREE_OPERAND (size
, 1))
1081 ? last_size
: merge_sizes (last_size
, first_bit
,
1082 TREE_OPERAND (size
, 1),
1084 integer_zerop (TREE_OPERAND (size
, 2))
1085 ? last_size
: merge_sizes (last_size
, first_bit
,
1086 TREE_OPERAND (size
, 2),
1089 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1090 when fed through substitute_in_expr) into thinking that a constant
1091 size is not constant. */
1092 while (TREE_CODE (new) == NON_LVALUE_EXPR
)
1093 new = TREE_OPERAND (new, 0);
1098 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1099 related by the addition of a constant. Return that constant if so. */
1102 compute_related_constant (tree op0
, tree op1
)
1104 tree op0_var
, op1_var
;
1105 tree op0_con
= split_plus (op0
, &op0_var
);
1106 tree op1_con
= split_plus (op1
, &op1_var
);
1107 tree result
= size_binop (MINUS_EXPR
, op0_con
, op1_con
);
1109 if (operand_equal_p (op0_var
, op1_var
, 0))
1111 else if (operand_equal_p (op0
, size_binop (PLUS_EXPR
, op1_var
, result
), 0))
1117 /* Utility function of above to split a tree OP which may be a sum, into a
1118 constant part, which is returned, and a variable part, which is stored
1119 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
1123 split_plus (tree in
, tree
*pvar
)
1125 /* Strip NOPS in order to ease the tree traversal and maximize the
1126 potential for constant or plus/minus discovery. We need to be careful
1127 to always return and set *pvar to bitsizetype trees, but it's worth
1131 *pvar
= convert (bitsizetype
, in
);
1133 if (TREE_CODE (in
) == INTEGER_CST
)
1135 *pvar
= bitsize_zero_node
;
1136 return convert (bitsizetype
, in
);
1138 else if (TREE_CODE (in
) == PLUS_EXPR
|| TREE_CODE (in
) == MINUS_EXPR
)
1140 tree lhs_var
, rhs_var
;
1141 tree lhs_con
= split_plus (TREE_OPERAND (in
, 0), &lhs_var
);
1142 tree rhs_con
= split_plus (TREE_OPERAND (in
, 1), &rhs_var
);
1144 if (lhs_var
== TREE_OPERAND (in
, 0)
1145 && rhs_var
== TREE_OPERAND (in
, 1))
1146 return bitsize_zero_node
;
1148 *pvar
= size_binop (TREE_CODE (in
), lhs_var
, rhs_var
);
1149 return size_binop (TREE_CODE (in
), lhs_con
, rhs_con
);
1152 return bitsize_zero_node
;
1155 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1156 subprogram. If it is void_type_node, then we are dealing with a procedure,
1157 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1158 PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
1159 copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1160 RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
1161 object. RETURNS_BY_REF is nonzero if the function returns by reference.
1162 RETURNS_WITH_DSP is nonzero if the function is to return with a
1163 depressed stack pointer. RETURNS_BY_TARGET_PTR is true if the function
1164 is to be passed (as its first parameter) the address of the place to copy
1168 create_subprog_type (tree return_type
, tree param_decl_list
, tree cico_list
,
1169 bool returns_unconstrained
, bool returns_by_ref
,
1170 bool returns_with_dsp
, bool returns_by_target_ptr
)
1172 /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1173 the subprogram formal parameters. This list is generated by traversing the
1174 input list of PARM_DECL nodes. */
1175 tree param_type_list
= NULL
;
1179 for (param_decl
= param_decl_list
; param_decl
;
1180 param_decl
= TREE_CHAIN (param_decl
))
1181 param_type_list
= tree_cons (NULL_TREE
, TREE_TYPE (param_decl
),
1184 /* The list of the function parameter types has to be terminated by the void
1185 type to signal to the back-end that we are not dealing with a variable
1186 parameter subprogram, but that the subprogram has a fixed number of
1188 param_type_list
= tree_cons (NULL_TREE
, void_type_node
, param_type_list
);
1190 /* The list of argument types has been created in reverse
1192 param_type_list
= nreverse (param_type_list
);
1194 type
= build_function_type (return_type
, param_type_list
);
1196 /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
1197 or the new type should, make a copy of TYPE. Likewise for
1198 RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
1199 if (TYPE_CI_CO_LIST (type
) || cico_list
1200 || TYPE_RETURNS_UNCONSTRAINED_P (type
) != returns_unconstrained
1201 || TYPE_RETURNS_BY_REF_P (type
) != returns_by_ref
1202 || TYPE_RETURNS_BY_TARGET_PTR_P (type
) != returns_by_target_ptr
)
1203 type
= copy_type (type
);
1205 TYPE_CI_CO_LIST (type
) = cico_list
;
1206 TYPE_RETURNS_UNCONSTRAINED_P (type
) = returns_unconstrained
;
1207 TYPE_RETURNS_STACK_DEPRESSED (type
) = returns_with_dsp
;
1208 TYPE_RETURNS_BY_REF_P (type
) = returns_by_ref
;
1209 TYPE_RETURNS_BY_TARGET_PTR_P (type
) = returns_by_target_ptr
;
1213 /* Return a copy of TYPE but safe to modify in any way. */
1216 copy_type (tree type
)
1218 tree
new = copy_node (type
);
1220 /* copy_node clears this field instead of copying it, because it is
1221 aliased with TREE_CHAIN. */
1222 TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type
);
1224 TYPE_POINTER_TO (new) = 0;
1225 TYPE_REFERENCE_TO (new) = 0;
1226 TYPE_MAIN_VARIANT (new) = new;
1227 TYPE_NEXT_VARIANT (new) = 0;
1232 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1233 TYPE_INDEX_TYPE is INDEX. */
1236 create_index_type (tree min
, tree max
, tree index
)
1238 /* First build a type for the desired range. */
1239 tree type
= build_index_2_type (min
, max
);
1241 /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
1242 doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
1243 is set, but not to INDEX, make a copy of this type with the requested
1244 index type. Note that we have no way of sharing these types, but that's
1245 only a small hole. */
1246 if (TYPE_INDEX_TYPE (type
) == index
)
1248 else if (TYPE_INDEX_TYPE (type
))
1249 type
= copy_type (type
);
1251 SET_TYPE_INDEX_TYPE (type
, index
);
1252 create_type_decl (NULL_TREE
, type
, NULL
, true, false, Empty
);
1256 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1257 string) and TYPE is a ..._TYPE node giving its data type.
1258 ARTIFICIAL_P is true if this is a declaration that was generated
1259 by the compiler. DEBUG_INFO_P is true if we need to write debugging
1260 information about this type. GNAT_NODE is used for the position of
1264 create_type_decl (tree type_name
, tree type
, struct attrib
*attr_list
,
1265 bool artificial_p
, bool debug_info_p
, Node_Id gnat_node
)
1267 tree type_decl
= build_decl (TYPE_DECL
, type_name
, type
);
1268 enum tree_code code
= TREE_CODE (type
);
1270 DECL_ARTIFICIAL (type_decl
) = artificial_p
;
1272 process_attributes (type_decl
, attr_list
);
1274 /* Pass type declaration information to the debugger unless this is an
1275 UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1276 and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
1277 a dummy type, which will be completed later, or a type for which
1278 debugging information was not requested. */
1279 if (code
== UNCONSTRAINED_ARRAY_TYPE
|| TYPE_IS_DUMMY_P (type
)
1281 DECL_IGNORED_P (type_decl
) = 1;
1282 else if (code
!= ENUMERAL_TYPE
&& code
!= RECORD_TYPE
1283 && !((code
== POINTER_TYPE
|| code
== REFERENCE_TYPE
)
1284 && TYPE_IS_DUMMY_P (TREE_TYPE (type
))))
1285 rest_of_decl_compilation (type_decl
, global_bindings_p (), 0);
1287 if (!TYPE_IS_DUMMY_P (type
))
1288 gnat_pushdecl (type_decl
, gnat_node
);
1293 /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
1294 ASM_NAME is its assembler name (if provided). TYPE is its data type
1295 (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
1296 expression; NULL_TREE if none.
1298 CONST_FLAG is true if this variable is constant.
1300 PUBLIC_FLAG is true if this definition is to be made visible outside of
1301 the current compilation unit. This flag should be set when processing the
1302 variable definitions in a package specification. EXTERN_FLAG is nonzero
1303 when processing an external variable declaration (as opposed to a
1304 definition: no storage is to be allocated for the variable here).
1306 STATIC_FLAG is only relevant when not at top level. In that case
1307 it indicates whether to always allocate storage to the variable.
1309 GNAT_NODE is used for the position of the decl. */
1312 create_var_decl (tree var_name
, tree asm_name
, tree type
, tree var_init
,
1313 bool const_flag
, bool public_flag
, bool extern_flag
,
1314 bool static_flag
, struct attrib
*attr_list
, Node_Id gnat_node
)
1319 : (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1320 && (global_bindings_p () || static_flag
1321 ? 0 != initializer_constant_valid_p (var_init
,
1322 TREE_TYPE (var_init
))
1323 : TREE_CONSTANT (var_init
))));
1325 = build_decl ((const_flag
&& init_const
1326 /* Only make a CONST_DECL for sufficiently-small objects.
1327 We consider complex double "sufficiently-small" */
1328 && TYPE_SIZE (type
) != 0
1329 && host_integerp (TYPE_SIZE_UNIT (type
), 1)
1330 && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type
),
1331 GET_MODE_SIZE (DCmode
)))
1332 ? CONST_DECL
: VAR_DECL
, var_name
, type
);
1334 /* If this is external, throw away any initializations unless this is a
1335 CONST_DECL (meaning we have a constant); they will be done elsewhere.
1336 If we are defining a global here, leave a constant initialization and
1337 save any variable elaborations for the elaboration routine. If we are
1338 just annotating types, throw away the initialization if it isn't a
1340 if ((extern_flag
&& TREE_CODE (var_decl
) != CONST_DECL
)
1341 || (type_annotate_only
&& var_init
&& !TREE_CONSTANT (var_init
)))
1342 var_init
= NULL_TREE
;
1344 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
1345 try to fiddle with DECL_COMMON. However, on platforms that don't
1346 support global BSS sections, uninitialized global variables would
1347 go in DATA instead, thus increasing the size of the executable. */
1348 #if !defined(ASM_OUTPUT_BSS) && !defined(ASM_OUTPUT_ALIGNED_BSS)
1349 DECL_COMMON (var_decl
) = !flag_no_common
;
1351 DECL_INITIAL (var_decl
) = var_init
;
1352 TREE_READONLY (var_decl
) = const_flag
;
1353 DECL_EXTERNAL (var_decl
) = extern_flag
;
1354 TREE_PUBLIC (var_decl
) = public_flag
|| extern_flag
;
1355 TREE_CONSTANT (var_decl
) = TREE_CODE (var_decl
) == CONST_DECL
;
1356 TREE_THIS_VOLATILE (var_decl
) = TREE_SIDE_EFFECTS (var_decl
)
1357 = TYPE_VOLATILE (type
);
1359 /* If it's public and not external, always allocate storage for it.
1360 At the global binding level we need to allocate static storage for the
1361 variable if and only if it's not external. If we are not at the top level
1362 we allocate automatic storage unless requested not to. */
1363 TREE_STATIC (var_decl
)
1364 = public_flag
|| (global_bindings_p () ? !extern_flag
: static_flag
);
1367 SET_DECL_ASSEMBLER_NAME (var_decl
, asm_name
);
1369 process_attributes (var_decl
, attr_list
);
1371 /* Add this decl to the current binding level. */
1372 gnat_pushdecl (var_decl
, gnat_node
);
1374 if (TREE_SIDE_EFFECTS (var_decl
))
1375 TREE_ADDRESSABLE (var_decl
) = 1;
1377 if (TREE_CODE (var_decl
) != CONST_DECL
)
1378 rest_of_decl_compilation (var_decl
, global_bindings_p (), 0);
1383 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1384 type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
1385 this field is in a record type with a "pragma pack". If SIZE is nonzero
1386 it is the specified size for this field. If POS is nonzero, it is the bit
1387 position. If ADDRESSABLE is nonzero, it means we are allowed to take
1388 the address of this field for aliasing purposes. If it is negative, we
1389 should not make a bitfield, which is used by make_aligning_type. */
1392 create_field_decl (tree field_name
, tree field_type
, tree record_type
,
1393 int packed
, tree size
, tree pos
, int addressable
)
1395 tree field_decl
= build_decl (FIELD_DECL
, field_name
, field_type
);
1397 DECL_CONTEXT (field_decl
) = record_type
;
1398 TREE_READONLY (field_decl
) = TYPE_READONLY (field_type
);
1400 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1401 byte boundary since GCC cannot handle less-aligned BLKmode bitfields. */
1402 if (packed
&& TYPE_MODE (field_type
) == BLKmode
)
1403 DECL_ALIGN (field_decl
) = BITS_PER_UNIT
;
1405 /* If a size is specified, use it. Otherwise, if the record type is packed
1406 compute a size to use, which may differ from the object's natural size.
1407 We always set a size in this case to trigger the checks for bitfield
1408 creation below, which is typically required when no position has been
1411 size
= convert (bitsizetype
, size
);
1412 else if (packed
== 1)
1414 size
= rm_size (field_type
);
1416 /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1418 if (TREE_CODE (size
) == INTEGER_CST
1419 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) > 0)
1420 size
= round_up (size
, BITS_PER_UNIT
);
1423 /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1424 specified for two reasons: first if the size differs from the natural
1425 size. Second, if the alignment is insufficient. There are a number of
1426 ways the latter can be true.
1428 We never make a bitfield if the type of the field has a nonconstant size,
1429 because no such entity requiring bitfield operations should reach here.
1431 We do *preventively* make a bitfield when there might be the need for it
1432 but we don't have all the necessary information to decide, as is the case
1433 of a field with no specified position in a packed record.
1435 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1436 in layout_decl or finish_record_type to clear the bit_field indication if
1437 it is in fact not needed. */
1438 if (addressable
>= 0
1440 && TREE_CODE (size
) == INTEGER_CST
1441 && TREE_CODE (TYPE_SIZE (field_type
)) == INTEGER_CST
1442 && (!operand_equal_p (TYPE_SIZE (field_type
), size
, 0)
1443 || (pos
&& !value_factor_p (pos
, TYPE_ALIGN (field_type
)))
1445 || (TYPE_ALIGN (record_type
) != 0
1446 && TYPE_ALIGN (record_type
) < TYPE_ALIGN (field_type
))))
1448 DECL_BIT_FIELD (field_decl
) = 1;
1449 DECL_SIZE (field_decl
) = size
;
1450 if (!packed
&& !pos
)
1451 DECL_ALIGN (field_decl
)
1452 = (TYPE_ALIGN (record_type
) != 0
1453 ? MIN (TYPE_ALIGN (record_type
), TYPE_ALIGN (field_type
))
1454 : TYPE_ALIGN (field_type
));
1457 DECL_PACKED (field_decl
) = pos
? DECL_BIT_FIELD (field_decl
) : packed
;
1458 DECL_ALIGN (field_decl
)
1459 = MAX (DECL_ALIGN (field_decl
),
1460 DECL_BIT_FIELD (field_decl
) ? 1
1461 : packed
&& TYPE_MODE (field_type
) != BLKmode
? BITS_PER_UNIT
1462 : TYPE_ALIGN (field_type
));
1466 /* We need to pass in the alignment the DECL is known to have.
1467 This is the lowest-order bit set in POS, but no more than
1468 the alignment of the record, if one is specified. Note
1469 that an alignment of 0 is taken as infinite. */
1470 unsigned int known_align
;
1472 if (host_integerp (pos
, 1))
1473 known_align
= tree_low_cst (pos
, 1) & - tree_low_cst (pos
, 1);
1475 known_align
= BITS_PER_UNIT
;
1477 if (TYPE_ALIGN (record_type
)
1478 && (known_align
== 0 || known_align
> TYPE_ALIGN (record_type
)))
1479 known_align
= TYPE_ALIGN (record_type
);
1481 layout_decl (field_decl
, known_align
);
1482 SET_DECL_OFFSET_ALIGN (field_decl
,
1483 host_integerp (pos
, 1) ? BIGGEST_ALIGNMENT
1485 pos_from_bit (&DECL_FIELD_OFFSET (field_decl
),
1486 &DECL_FIELD_BIT_OFFSET (field_decl
),
1487 DECL_OFFSET_ALIGN (field_decl
), pos
);
1489 DECL_HAS_REP_P (field_decl
) = 1;
1492 /* If the field type is passed by reference, we will have pointers to the
1493 field, so it is addressable. */
1494 if (must_pass_by_ref (field_type
) || default_pass_by_ref (field_type
))
1497 /* ??? For now, we say that any field of aggregate type is addressable
1498 because the front end may take 'Reference of it. */
1499 if (AGGREGATE_TYPE_P (field_type
))
1502 /* Mark the decl as nonaddressable if it is indicated so semantically,
1503 meaning we won't ever attempt to take the address of the field.
1505 It may also be "technically" nonaddressable, meaning that even if we
1506 attempt to take the field's address we will actually get the address of a
1507 copy. This is the case for true bitfields, but the DECL_BIT_FIELD value
1508 we have at this point is not accurate enough, so we don't account for
1509 this here and let finish_record_type decide. */
1510 DECL_NONADDRESSABLE_P (field_decl
) = !addressable
;
1515 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1516 effects, has the value of zero. */
1519 value_zerop (tree exp
)
1521 if (TREE_CODE (exp
) == COMPOUND_EXPR
)
1522 return value_zerop (TREE_OPERAND (exp
, 1));
1524 return integer_zerop (exp
);
1527 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1528 PARAM_TYPE is its type. READONLY is true if the parameter is
1529 readonly (either an IN parameter or an address of a pass-by-ref
1533 create_param_decl (tree param_name
, tree param_type
, bool readonly
)
1535 tree param_decl
= build_decl (PARM_DECL
, param_name
, param_type
);
1537 /* Honor targetm.calls.promote_prototypes(), as not doing so can
1538 lead to various ABI violations. */
1539 if (targetm
.calls
.promote_prototypes (param_type
)
1540 && (TREE_CODE (param_type
) == INTEGER_TYPE
1541 || TREE_CODE (param_type
) == ENUMERAL_TYPE
)
1542 && TYPE_PRECISION (param_type
) < TYPE_PRECISION (integer_type_node
))
1544 /* We have to be careful about biased types here. Make a subtype
1545 of integer_type_node with the proper biasing. */
1546 if (TREE_CODE (param_type
) == INTEGER_TYPE
1547 && TYPE_BIASED_REPRESENTATION_P (param_type
))
1550 = copy_type (build_range_type (integer_type_node
,
1551 TYPE_MIN_VALUE (param_type
),
1552 TYPE_MAX_VALUE (param_type
)));
1554 TYPE_BIASED_REPRESENTATION_P (param_type
) = 1;
1557 param_type
= integer_type_node
;
1560 DECL_ARG_TYPE (param_decl
) = param_type
;
1561 DECL_ARG_TYPE_AS_WRITTEN (param_decl
) = param_type
;
1562 TREE_READONLY (param_decl
) = readonly
;
1566 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1569 process_attributes (tree decl
, struct attrib
*attr_list
)
1571 for (; attr_list
; attr_list
= attr_list
->next
)
1572 switch (attr_list
->type
)
1574 case ATTR_MACHINE_ATTRIBUTE
:
1575 decl_attributes (&decl
, tree_cons (attr_list
->name
, attr_list
->args
,
1577 ATTR_FLAG_TYPE_IN_PLACE
);
1580 case ATTR_LINK_ALIAS
:
1581 TREE_STATIC (decl
) = 1;
1582 assemble_alias (decl
, attr_list
->name
);
1585 case ATTR_WEAK_EXTERNAL
:
1587 declare_weak (decl
);
1589 post_error ("?weak declarations not supported on this target",
1590 attr_list
->error_point
);
1593 case ATTR_LINK_SECTION
:
1594 if (targetm
.have_named_sections
)
1596 DECL_SECTION_NAME (decl
)
1597 = build_string (IDENTIFIER_LENGTH (attr_list
->name
),
1598 IDENTIFIER_POINTER (attr_list
->name
));
1599 DECL_COMMON (decl
) = 0;
1602 post_error ("?section attributes are not supported for this target",
1603 attr_list
->error_point
);
1608 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1612 value_factor_p (tree value
, HOST_WIDE_INT factor
)
1614 if (host_integerp (value
, 1))
1615 return tree_low_cst (value
, 1) % factor
== 0;
1617 if (TREE_CODE (value
) == MULT_EXPR
)
1618 return (value_factor_p (TREE_OPERAND (value
, 0), factor
)
1619 || value_factor_p (TREE_OPERAND (value
, 1), factor
));
1624 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1625 unless we can prove these 2 fields are laid out in such a way that no gap
1626 exist between the end of PREV_FIELD and the begining of CURR_FIELD. OFFSET
1627 is the distance in bits between the end of PREV_FIELD and the starting
1628 position of CURR_FIELD. It is ignored if null. */
1631 potential_alignment_gap (tree prev_field
, tree curr_field
, tree offset
)
1633 /* If this is the first field of the record, there cannot be any gap */
1637 /* If the previous field is a union type, then return False: The only
1638 time when such a field is not the last field of the record is when
1639 there are other components at fixed positions after it (meaning there
1640 was a rep clause for every field), in which case we don't want the
1641 alignment constraint to override them. */
1642 if (TREE_CODE (TREE_TYPE (prev_field
)) == QUAL_UNION_TYPE
)
1645 /* If the distance between the end of prev_field and the begining of
1646 curr_field is constant, then there is a gap if the value of this
1647 constant is not null. */
1648 if (offset
&& host_integerp (offset
, 1))
1649 return !integer_zerop (offset
);
1651 /* If the size and position of the previous field are constant,
1652 then check the sum of this size and position. There will be a gap
1653 iff it is not multiple of the current field alignment. */
1654 if (host_integerp (DECL_SIZE (prev_field
), 1)
1655 && host_integerp (bit_position (prev_field
), 1))
1656 return ((tree_low_cst (bit_position (prev_field
), 1)
1657 + tree_low_cst (DECL_SIZE (prev_field
), 1))
1658 % DECL_ALIGN (curr_field
) != 0);
1660 /* If both the position and size of the previous field are multiples
1661 of the current field alignment, there can not be any gap. */
1662 if (value_factor_p (bit_position (prev_field
), DECL_ALIGN (curr_field
))
1663 && value_factor_p (DECL_SIZE (prev_field
), DECL_ALIGN (curr_field
)))
1666 /* Fallback, return that there may be a potential gap */
1670 /* Returns a LABEL_DECL node for LABEL_NAME. */
1673 create_label_decl (tree label_name
)
1675 tree label_decl
= build_decl (LABEL_DECL
, label_name
, void_type_node
);
1677 DECL_CONTEXT (label_decl
) = current_function_decl
;
1678 DECL_MODE (label_decl
) = VOIDmode
;
1679 DECL_SOURCE_LOCATION (label_decl
) = input_location
;
1684 /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1685 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1686 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1687 PARM_DECL nodes chained through the TREE_CHAIN field).
1689 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1690 appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */
1693 create_subprog_decl (tree subprog_name
, tree asm_name
,
1694 tree subprog_type
, tree param_decl_list
, bool inline_flag
,
1695 bool public_flag
, bool extern_flag
,
1696 struct attrib
*attr_list
, Node_Id gnat_node
)
1698 tree return_type
= TREE_TYPE (subprog_type
);
1699 tree subprog_decl
= build_decl (FUNCTION_DECL
, subprog_name
, subprog_type
);
1701 /* If this is a function nested inside an inlined external function, it
1702 means we aren't going to compile the outer function unless it is
1703 actually inlined, so do the same for us. */
1704 if (current_function_decl
&& DECL_INLINE (current_function_decl
)
1705 && DECL_EXTERNAL (current_function_decl
))
1708 DECL_EXTERNAL (subprog_decl
) = extern_flag
;
1709 TREE_PUBLIC (subprog_decl
) = public_flag
;
1710 TREE_STATIC (subprog_decl
) = 1;
1711 TREE_READONLY (subprog_decl
) = TYPE_READONLY (subprog_type
);
1712 TREE_THIS_VOLATILE (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1713 TREE_SIDE_EFFECTS (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1714 DECL_ARGUMENTS (subprog_decl
) = param_decl_list
;
1715 DECL_RESULT (subprog_decl
) = build_decl (RESULT_DECL
, 0, return_type
);
1716 DECL_ARTIFICIAL (DECL_RESULT (subprog_decl
)) = 1;
1717 DECL_IGNORED_P (DECL_RESULT (subprog_decl
)) = 1;
1720 DECL_DECLARED_INLINE_P (subprog_decl
) = 1;
1723 SET_DECL_ASSEMBLER_NAME (subprog_decl
, asm_name
);
1725 process_attributes (subprog_decl
, attr_list
);
1727 /* Add this decl to the current binding level. */
1728 gnat_pushdecl (subprog_decl
, gnat_node
);
1730 /* Output the assembler code and/or RTL for the declaration. */
1731 rest_of_decl_compilation (subprog_decl
, global_bindings_p (), 0);
1733 return subprog_decl
;
1736 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1737 body. This routine needs to be invoked before processing the declarations
1738 appearing in the subprogram. */
1741 begin_subprog_body (tree subprog_decl
)
1745 current_function_decl
= subprog_decl
;
1746 announce_function (subprog_decl
);
1748 /* Enter a new binding level and show that all the parameters belong to
1751 for (param_decl
= DECL_ARGUMENTS (subprog_decl
); param_decl
;
1752 param_decl
= TREE_CHAIN (param_decl
))
1753 DECL_CONTEXT (param_decl
) = subprog_decl
;
1755 make_decl_rtl (subprog_decl
);
1757 /* We handle pending sizes via the elaboration of types, so we don't need to
1758 save them. This causes them to be marked as part of the outer function
1759 and then discarded. */
1760 get_pending_sizes ();
1763 /* Finish the definition of the current subprogram and compile it all the way
1764 to assembler language output. BODY is the tree corresponding to
1768 end_subprog_body (tree body
)
1770 tree fndecl
= current_function_decl
;
1772 /* Mark the BLOCK for this level as being for this function and pop the
1773 level. Since the vars in it are the parameters, clear them. */
1774 BLOCK_VARS (current_binding_level
->block
) = 0;
1775 BLOCK_SUPERCONTEXT (current_binding_level
->block
) = fndecl
;
1776 DECL_INITIAL (fndecl
) = current_binding_level
->block
;
1779 /* Deal with inline. If declared inline or we should default to inline,
1780 set the flag in the decl. */
1781 DECL_INLINE (fndecl
)
1782 = DECL_DECLARED_INLINE_P (fndecl
) || flag_inline_trees
== 2;
1784 /* We handle pending sizes via the elaboration of types, so we don't
1785 need to save them. */
1786 get_pending_sizes ();
1788 /* Mark the RESULT_DECL as being in this subprogram. */
1789 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
1791 DECL_SAVED_TREE (fndecl
) = body
;
1793 current_function_decl
= DECL_CONTEXT (fndecl
);
1796 /* If we're only annotating types, don't actually compile this function. */
1797 if (type_annotate_only
)
1800 /* We do different things for nested and non-nested functions.
1801 ??? This should be in cgraph. */
1802 if (!DECL_CONTEXT (fndecl
))
1804 gnat_gimplify_function (fndecl
);
1805 cgraph_finalize_function (fndecl
, false);
1808 /* Register this function with cgraph just far enough to get it
1809 added to our parent's nested function list. */
1810 (void) cgraph_node (fndecl
);
1813 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1816 gnat_gimplify_function (tree fndecl
)
1818 struct cgraph_node
*cgn
;
1820 dump_function (TDI_original
, fndecl
);
1821 gimplify_function_tree (fndecl
);
1822 dump_function (TDI_generic
, fndecl
);
1824 /* Convert all nested functions to GIMPLE now. We do things in this order
1825 so that items like VLA sizes are expanded properly in the context of the
1826 correct function. */
1827 cgn
= cgraph_node (fndecl
);
1828 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1829 gnat_gimplify_function (cgn
->decl
);
1832 /* Return a definition for a builtin function named NAME and whose data type
1833 is TYPE. TYPE should be a function type with argument types.
1834 FUNCTION_CODE tells later passes how to compile calls to this function.
1835 See tree.h for its possible values.
1837 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1838 the name to be called if we can't opencode the function. If
1839 ATTRS is nonzero, use that for the function attribute list. */
1842 builtin_function (const char *name
, tree type
, int function_code
,
1843 enum built_in_class
class, const char *library_name
,
1846 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
1848 DECL_EXTERNAL (decl
) = 1;
1849 TREE_PUBLIC (decl
) = 1;
1851 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
1853 gnat_pushdecl (decl
, Empty
);
1854 DECL_BUILT_IN_CLASS (decl
) = class;
1855 DECL_FUNCTION_CODE (decl
) = function_code
;
1857 decl_attributes (&decl
, attrs
, ATTR_FLAG_BUILT_IN
);
1861 /* Return an integer type with the number of bits of precision given by
1862 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
1863 it is a signed type. */
1866 gnat_type_for_size (unsigned precision
, int unsignedp
)
1871 if (precision
<= 2 * MAX_BITS_PER_WORD
1872 && signed_and_unsigned_types
[precision
][unsignedp
])
1873 return signed_and_unsigned_types
[precision
][unsignedp
];
1876 t
= make_unsigned_type (precision
);
1878 t
= make_signed_type (precision
);
1880 if (precision
<= 2 * MAX_BITS_PER_WORD
)
1881 signed_and_unsigned_types
[precision
][unsignedp
] = t
;
1885 sprintf (type_name
, "%sSIGNED_%d", unsignedp
? "UN" : "", precision
);
1886 TYPE_NAME (t
) = get_identifier (type_name
);
1892 /* Likewise for floating-point types. */
1895 float_type_for_precision (int precision
, enum machine_mode mode
)
1900 if (float_types
[(int) mode
])
1901 return float_types
[(int) mode
];
1903 float_types
[(int) mode
] = t
= make_node (REAL_TYPE
);
1904 TYPE_PRECISION (t
) = precision
;
1907 gcc_assert (TYPE_MODE (t
) == mode
);
1910 sprintf (type_name
, "FLOAT_%d", precision
);
1911 TYPE_NAME (t
) = get_identifier (type_name
);
1917 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
1918 an unsigned type; otherwise a signed type is returned. */
1921 gnat_type_for_mode (enum machine_mode mode
, int unsignedp
)
1923 if (mode
== BLKmode
)
1925 else if (mode
== VOIDmode
)
1926 return void_type_node
;
1927 else if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
1928 return float_type_for_precision (GET_MODE_PRECISION (mode
), mode
);
1930 return gnat_type_for_size (GET_MODE_BITSIZE (mode
), unsignedp
);
1933 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
1936 gnat_unsigned_type (tree type_node
)
1938 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 1);
1940 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
1942 type
= copy_node (type
);
1943 TREE_TYPE (type
) = type_node
;
1945 else if (TREE_TYPE (type_node
)
1946 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
1947 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
1949 type
= copy_node (type
);
1950 TREE_TYPE (type
) = TREE_TYPE (type_node
);
1956 /* Return the signed version of a TYPE_NODE, a scalar type. */
1959 gnat_signed_type (tree type_node
)
1961 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 0);
1963 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
1965 type
= copy_node (type
);
1966 TREE_TYPE (type
) = type_node
;
1968 else if (TREE_TYPE (type_node
)
1969 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
1970 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
1972 type
= copy_node (type
);
1973 TREE_TYPE (type
) = TREE_TYPE (type_node
);
1979 /* Return a type the same as TYPE except unsigned or signed according to
1983 gnat_signed_or_unsigned_type (int unsignedp
, tree type
)
1985 if (!INTEGRAL_TYPE_P (type
) || TYPE_UNSIGNED (type
) == unsignedp
)
1988 return gnat_type_for_size (TYPE_PRECISION (type
), unsignedp
);
1991 /* EXP is an expression for the size of an object. If this size contains
1992 discriminant references, replace them with the maximum (if MAX_P) or
1993 minimum (if !MAX_P) possible value of the discriminant. */
1996 max_size (tree exp
, bool max_p
)
1998 enum tree_code code
= TREE_CODE (exp
);
1999 tree type
= TREE_TYPE (exp
);
2001 switch (TREE_CODE_CLASS (code
))
2003 case tcc_declaration
:
2007 case tcc_exceptional
:
2008 if (code
== TREE_LIST
)
2009 return tree_cons (TREE_PURPOSE (exp
),
2010 max_size (TREE_VALUE (exp
), max_p
),
2012 ? max_size (TREE_CHAIN (exp
), max_p
) : NULL_TREE
);
2016 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2017 modify. Otherwise, we treat it like a variable. */
2018 if (!CONTAINS_PLACEHOLDER_P (exp
))
2021 type
= TREE_TYPE (TREE_OPERAND (exp
, 1));
2023 max_size (max_p
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
), true);
2025 case tcc_comparison
:
2026 return max_p
? size_one_node
: size_zero_node
;
2030 case tcc_expression
:
2031 switch (TREE_CODE_LENGTH (code
))
2034 if (code
== NON_LVALUE_EXPR
)
2035 return max_size (TREE_OPERAND (exp
, 0), max_p
);
2038 fold (build1 (code
, type
,
2039 max_size (TREE_OPERAND (exp
, 0),
2040 code
== NEGATE_EXPR
? !max_p
: max_p
)));
2043 if (code
== COMPOUND_EXPR
)
2044 return max_size (TREE_OPERAND (exp
, 1), max_p
);
2047 tree lhs
= max_size (TREE_OPERAND (exp
, 0), max_p
);
2048 tree rhs
= max_size (TREE_OPERAND (exp
, 1),
2049 code
== MINUS_EXPR
? !max_p
: max_p
);
2051 /* Special-case wanting the maximum value of a MIN_EXPR.
2052 In that case, if one side overflows, return the other.
2053 sizetype is signed, but we know sizes are non-negative.
2054 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2055 overflowing or the maximum possible value and the RHS
2057 if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (rhs
))
2059 else if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (lhs
))
2061 else if ((code
== MINUS_EXPR
|| code
== PLUS_EXPR
)
2062 && ((TREE_CONSTANT (lhs
) && TREE_OVERFLOW (lhs
))
2063 || operand_equal_p (lhs
, TYPE_MAX_VALUE (type
), 0))
2064 && !TREE_CONSTANT (rhs
))
2067 return fold (build2 (code
, type
, lhs
, rhs
));
2071 if (code
== SAVE_EXPR
)
2073 else if (code
== COND_EXPR
)
2074 return fold (build2 (max_p
? MAX_EXPR
: MIN_EXPR
, type
,
2075 max_size (TREE_OPERAND (exp
, 1), max_p
),
2076 max_size (TREE_OPERAND (exp
, 2), max_p
)));
2077 else if (code
== CALL_EXPR
&& TREE_OPERAND (exp
, 1))
2078 return build3 (CALL_EXPR
, type
, TREE_OPERAND (exp
, 0),
2079 max_size (TREE_OPERAND (exp
, 1), max_p
), NULL
);
2082 /* Other tree classes cannot happen. */
2090 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2091 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2092 Return a constructor for the template. */
2095 build_template (tree template_type
, tree array_type
, tree expr
)
2097 tree template_elts
= NULL_TREE
;
2098 tree bound_list
= NULL_TREE
;
2101 if (TREE_CODE (array_type
) == RECORD_TYPE
2102 && (TYPE_IS_PADDING_P (array_type
)
2103 || TYPE_JUSTIFIED_MODULAR_P (array_type
)))
2104 array_type
= TREE_TYPE (TYPE_FIELDS (array_type
));
2106 if (TREE_CODE (array_type
) == ARRAY_TYPE
2107 || (TREE_CODE (array_type
) == INTEGER_TYPE
2108 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type
)))
2109 bound_list
= TYPE_ACTUAL_BOUNDS (array_type
);
2111 /* First make the list for a CONSTRUCTOR for the template. Go down the
2112 field list of the template instead of the type chain because this
2113 array might be an Ada array of arrays and we can't tell where the
2114 nested arrays stop being the underlying object. */
2116 for (field
= TYPE_FIELDS (template_type
); field
;
2118 ? (bound_list
= TREE_CHAIN (bound_list
))
2119 : (array_type
= TREE_TYPE (array_type
))),
2120 field
= TREE_CHAIN (TREE_CHAIN (field
)))
2122 tree bounds
, min
, max
;
2124 /* If we have a bound list, get the bounds from there. Likewise
2125 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2126 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2127 This will give us a maximum range. */
2129 bounds
= TREE_VALUE (bound_list
);
2130 else if (TREE_CODE (array_type
) == ARRAY_TYPE
)
2131 bounds
= TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type
));
2132 else if (expr
&& TREE_CODE (expr
) == PARM_DECL
2133 && DECL_BY_COMPONENT_PTR_P (expr
))
2134 bounds
= TREE_TYPE (field
);
2138 min
= convert (TREE_TYPE (TREE_CHAIN (field
)), TYPE_MIN_VALUE (bounds
));
2139 max
= convert (TREE_TYPE (field
), TYPE_MAX_VALUE (bounds
));
2141 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2142 substitute it from OBJECT. */
2143 min
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (min
, expr
);
2144 max
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (max
, expr
);
2146 template_elts
= tree_cons (TREE_CHAIN (field
), max
,
2147 tree_cons (field
, min
, template_elts
));
2150 return gnat_build_constructor (template_type
, nreverse (template_elts
));
2153 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2154 a descriptor type, and the GCC type of an object. Each FIELD_DECL
2155 in the type contains in its DECL_INITIAL the expression to use when
2156 a constructor is made for the type. GNAT_ENTITY is an entity used
2157 to print out an error message if the mechanism cannot be applied to
2158 an object of that type and also for the name. */
2161 build_vms_descriptor (tree type
, Mechanism_Type mech
, Entity_Id gnat_entity
)
2163 tree record_type
= make_node (RECORD_TYPE
);
2164 tree field_list
= 0;
2173 /* If TYPE is an unconstrained array, use the underlying array type. */
2174 if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
2175 type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type
))));
2177 /* If this is an array, compute the number of dimensions in the array,
2178 get the index types, and point to the inner type. */
2179 if (TREE_CODE (type
) != ARRAY_TYPE
)
2182 for (ndim
= 1, inner_type
= type
;
2183 TREE_CODE (TREE_TYPE (inner_type
)) == ARRAY_TYPE
2184 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type
));
2185 ndim
++, inner_type
= TREE_TYPE (inner_type
))
2188 idx_arr
= (tree
*) alloca (ndim
* sizeof (tree
));
2190 if (mech
!= By_Descriptor_NCA
2191 && TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type
))
2192 for (i
= ndim
- 1, inner_type
= type
;
2194 i
--, inner_type
= TREE_TYPE (inner_type
))
2195 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2197 for (i
= 0, inner_type
= type
;
2199 i
++, inner_type
= TREE_TYPE (inner_type
))
2200 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2202 /* Now get the DTYPE value. */
2203 switch (TREE_CODE (type
))
2207 if (TYPE_VAX_FLOATING_POINT_P (type
))
2208 switch (tree_low_cst (TYPE_DIGITS_VALUE (type
), 1))
2221 switch (GET_MODE_BITSIZE (TYPE_MODE (type
)))
2224 dtype
= TYPE_UNSIGNED (type
) ? 2 : 6;
2227 dtype
= TYPE_UNSIGNED (type
) ? 3 : 7;
2230 dtype
= TYPE_UNSIGNED (type
) ? 4 : 8;
2233 dtype
= TYPE_UNSIGNED (type
) ? 5 : 9;
2236 dtype
= TYPE_UNSIGNED (type
) ? 25 : 26;
2242 dtype
= GET_MODE_BITSIZE (TYPE_MODE (type
)) == 32 ? 52 : 53;
2246 if (TREE_CODE (TREE_TYPE (type
)) == INTEGER_TYPE
2247 && TYPE_VAX_FLOATING_POINT_P (type
))
2248 switch (tree_low_cst (TYPE_DIGITS_VALUE (type
), 1))
2260 dtype
= GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type
))) == 32 ? 54: 55;
2271 /* Get the CLASS value. */
2274 case By_Descriptor_A
:
2277 case By_Descriptor_NCA
:
2280 case By_Descriptor_SB
:
2287 /* Make the type for a descriptor for VMS. The first four fields
2288 are the same for all types. */
2291 = chainon (field_list
,
2292 make_descriptor_field
2293 ("LENGTH", gnat_type_for_size (16, 1), record_type
,
2294 size_in_bytes (mech
== By_Descriptor_A
? inner_type
: type
)));
2296 field_list
= chainon (field_list
,
2297 make_descriptor_field ("DTYPE",
2298 gnat_type_for_size (8, 1),
2299 record_type
, size_int (dtype
)));
2300 field_list
= chainon (field_list
,
2301 make_descriptor_field ("CLASS",
2302 gnat_type_for_size (8, 1),
2303 record_type
, size_int (class)));
2306 = chainon (field_list
,
2307 make_descriptor_field
2309 build_pointer_type_for_mode (type
, SImode
, false), record_type
,
2311 build_pointer_type_for_mode (type
, SImode
, false),
2312 build0 (PLACEHOLDER_EXPR
, type
))));
2317 case By_Descriptor_S
:
2320 case By_Descriptor_SB
:
2322 = chainon (field_list
,
2323 make_descriptor_field
2324 ("SB_L1", gnat_type_for_size (32, 1), record_type
,
2325 TREE_CODE (type
) == ARRAY_TYPE
2326 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2328 = chainon (field_list
,
2329 make_descriptor_field
2330 ("SB_L2", gnat_type_for_size (32, 1), record_type
,
2331 TREE_CODE (type
) == ARRAY_TYPE
2332 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2335 case By_Descriptor_A
:
2336 case By_Descriptor_NCA
:
2337 field_list
= chainon (field_list
,
2338 make_descriptor_field ("SCALE",
2339 gnat_type_for_size (8, 1),
2343 field_list
= chainon (field_list
,
2344 make_descriptor_field ("DIGITS",
2345 gnat_type_for_size (8, 1),
2350 = chainon (field_list
,
2351 make_descriptor_field
2352 ("AFLAGS", gnat_type_for_size (8, 1), record_type
,
2353 size_int (mech
== By_Descriptor_NCA
2355 /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
2356 : (TREE_CODE (type
) == ARRAY_TYPE
2357 && TYPE_CONVENTION_FORTRAN_P (type
)
2360 field_list
= chainon (field_list
,
2361 make_descriptor_field ("DIMCT",
2362 gnat_type_for_size (8, 1),
2366 field_list
= chainon (field_list
,
2367 make_descriptor_field ("ARSIZE",
2368 gnat_type_for_size (32, 1),
2370 size_in_bytes (type
)));
2372 /* Now build a pointer to the 0,0,0... element. */
2373 tem
= build0 (PLACEHOLDER_EXPR
, type
);
2374 for (i
= 0, inner_type
= type
; i
< ndim
;
2375 i
++, inner_type
= TREE_TYPE (inner_type
))
2376 tem
= build4 (ARRAY_REF
, TREE_TYPE (inner_type
), tem
,
2377 convert (TYPE_DOMAIN (inner_type
), size_zero_node
),
2378 NULL_TREE
, NULL_TREE
);
2381 = chainon (field_list
,
2382 make_descriptor_field
2384 build_pointer_type_for_mode (inner_type
, SImode
, false),
2387 build_pointer_type_for_mode (inner_type
, SImode
,
2391 /* Next come the addressing coefficients. */
2393 for (i
= 0; i
< ndim
; i
++)
2397 = size_binop (MULT_EXPR
, tem
,
2398 size_binop (PLUS_EXPR
,
2399 size_binop (MINUS_EXPR
,
2400 TYPE_MAX_VALUE (idx_arr
[i
]),
2401 TYPE_MIN_VALUE (idx_arr
[i
])),
2404 fname
[0] = (mech
== By_Descriptor_NCA
? 'S' : 'M');
2405 fname
[1] = '0' + i
, fname
[2] = 0;
2407 = chainon (field_list
,
2408 make_descriptor_field (fname
,
2409 gnat_type_for_size (32, 1),
2410 record_type
, idx_length
));
2412 if (mech
== By_Descriptor_NCA
)
2416 /* Finally here are the bounds. */
2417 for (i
= 0; i
< ndim
; i
++)
2421 fname
[0] = 'L', fname
[1] = '0' + i
, fname
[2] = 0;
2423 = chainon (field_list
,
2424 make_descriptor_field
2425 (fname
, gnat_type_for_size (32, 1), record_type
,
2426 TYPE_MIN_VALUE (idx_arr
[i
])));
2430 = chainon (field_list
,
2431 make_descriptor_field
2432 (fname
, gnat_type_for_size (32, 1), record_type
,
2433 TYPE_MAX_VALUE (idx_arr
[i
])));
2438 post_error ("unsupported descriptor type for &", gnat_entity
);
2441 finish_record_type (record_type
, field_list
, false, true);
2442 create_type_decl (create_concat_name (gnat_entity
, "DESC"), record_type
,
2443 NULL
, true, false, gnat_entity
);
2448 /* Utility routine for above code to make a field. */
2451 make_descriptor_field (const char *name
, tree type
,
2452 tree rec_type
, tree initial
)
2455 = create_field_decl (get_identifier (name
), type
, rec_type
, 0, 0, 0, 0);
2457 DECL_INITIAL (field
) = initial
;
2461 /* Build a type to be used to represent an aliased object whose nominal
2462 type is an unconstrained array. This consists of a RECORD_TYPE containing
2463 a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2464 ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
2465 is used to represent an arbitrary unconstrained object. Use NAME
2466 as the name of the record. */
2469 build_unc_object_type (tree template_type
, tree object_type
, tree name
)
2471 tree type
= make_node (RECORD_TYPE
);
2472 tree template_field
= create_field_decl (get_identifier ("BOUNDS"),
2473 template_type
, type
, 0, 0, 0, 1);
2474 tree array_field
= create_field_decl (get_identifier ("ARRAY"), object_type
,
2477 TYPE_NAME (type
) = name
;
2478 TYPE_CONTAINS_TEMPLATE_P (type
) = 1;
2479 finish_record_type (type
,
2480 chainon (chainon (NULL_TREE
, template_field
),
2487 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
2488 the normal case this is just two adjustments, but we have more to do
2489 if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
2492 update_pointer_to (tree old_type
, tree new_type
)
2494 tree ptr
= TYPE_POINTER_TO (old_type
);
2495 tree ref
= TYPE_REFERENCE_TO (old_type
);
2499 /* If this is the main variant, process all the other variants first. */
2500 if (TYPE_MAIN_VARIANT (old_type
) == old_type
)
2501 for (type
= TYPE_NEXT_VARIANT (old_type
); type
;
2502 type
= TYPE_NEXT_VARIANT (type
))
2503 update_pointer_to (type
, new_type
);
2505 /* If no pointer or reference, we are done. */
2509 /* Merge the old type qualifiers in the new type.
2511 Each old variant has qualifiers for specific reasons, and the new
2512 designated type as well. Each set of qualifiers represents useful
2513 information grabbed at some point, and merging the two simply unifies
2514 these inputs into the final type description.
2516 Consider for instance a volatile type frozen after an access to constant
2517 type designating it. After the designated type freeze, we get here with a
2518 volatile new_type and a dummy old_type with a readonly variant, created
2519 when the access type was processed. We shall make a volatile and readonly
2520 designated type, because that's what it really is.
2522 We might also get here for a non-dummy old_type variant with different
2523 qualifiers than the new_type ones, for instance in some cases of pointers
2524 to private record type elaboration (see the comments around the call to
2525 this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
2526 qualifiers in thoses cases too, to avoid accidentally discarding the
2527 initial set, and will often end up with old_type == new_type then. */
2528 new_type
= build_qualified_type (new_type
,
2529 TYPE_QUALS (old_type
)
2530 | TYPE_QUALS (new_type
));
2532 /* If the new type and the old one are identical, there is nothing to
2534 if (old_type
== new_type
)
2537 /* Otherwise, first handle the simple case. */
2538 if (TREE_CODE (new_type
) != UNCONSTRAINED_ARRAY_TYPE
)
2540 TYPE_POINTER_TO (new_type
) = ptr
;
2541 TYPE_REFERENCE_TO (new_type
) = ref
;
2543 for (; ptr
; ptr
= TYPE_NEXT_PTR_TO (ptr
))
2544 for (ptr1
= TYPE_MAIN_VARIANT (ptr
); ptr1
;
2545 ptr1
= TYPE_NEXT_VARIANT (ptr1
))
2547 TREE_TYPE (ptr1
) = new_type
;
2549 if (TYPE_NAME (ptr1
)
2550 && TREE_CODE (TYPE_NAME (ptr1
)) == TYPE_DECL
2551 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2552 rest_of_decl_compilation (TYPE_NAME (ptr1
),
2553 global_bindings_p (), 0);
2556 for (; ref
; ref
= TYPE_NEXT_PTR_TO (ref
))
2557 for (ref1
= TYPE_MAIN_VARIANT (ref
); ref1
;
2558 ref1
= TYPE_NEXT_VARIANT (ref1
))
2560 TREE_TYPE (ref1
) = new_type
;
2562 if (TYPE_NAME (ref1
)
2563 && TREE_CODE (TYPE_NAME (ref1
)) == TYPE_DECL
2564 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2565 rest_of_decl_compilation (TYPE_NAME (ref1
),
2566 global_bindings_p (), 0);
2570 /* Now deal with the unconstrained array case. In this case the "pointer"
2571 is actually a RECORD_TYPE where the types of both fields are
2572 pointers to void. In that case, copy the field list from the
2573 old type to the new one and update the fields' context. */
2574 else if (TREE_CODE (ptr
) != RECORD_TYPE
|| !TYPE_IS_FAT_POINTER_P (ptr
))
2579 tree new_obj_rec
= TYPE_OBJECT_RECORD_TYPE (new_type
);
2584 SET_DECL_ORIGINAL_FIELD (TYPE_FIELDS (ptr
),
2585 TYPE_FIELDS (TYPE_POINTER_TO (new_type
)));
2586 SET_DECL_ORIGINAL_FIELD (TREE_CHAIN (TYPE_FIELDS (ptr
)),
2587 TREE_CHAIN (TYPE_FIELDS
2588 (TYPE_POINTER_TO (new_type
))));
2590 TYPE_FIELDS (ptr
) = TYPE_FIELDS (TYPE_POINTER_TO (new_type
));
2591 DECL_CONTEXT (TYPE_FIELDS (ptr
)) = ptr
;
2592 DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr
))) = ptr
;
2594 /* Rework the PLACEHOLDER_EXPR inside the reference to the
2597 ??? This is now the only use of gnat_substitute_in_type, which
2598 is now a very "heavy" routine to do this, so it should be replaced
2600 ptr_temp_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr
)));
2601 new_ref
= build3 (COMPONENT_REF
, ptr_temp_type
,
2602 build0 (PLACEHOLDER_EXPR
, ptr
),
2603 TREE_CHAIN (TYPE_FIELDS (ptr
)), NULL_TREE
);
2606 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2607 gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2608 TREE_CHAIN (TYPE_FIELDS (ptr
)), new_ref
));
2610 for (var
= TYPE_MAIN_VARIANT (ptr
); var
; var
= TYPE_NEXT_VARIANT (var
))
2611 SET_TYPE_UNCONSTRAINED_ARRAY (var
, new_type
);
2613 TYPE_POINTER_TO (new_type
) = TYPE_REFERENCE_TO (new_type
)
2614 = TREE_TYPE (new_type
) = ptr
;
2616 /* Now handle updating the allocation record, what the thin pointer
2617 points to. Update all pointers from the old record into the new
2618 one, update the types of the fields, and recompute the size. */
2620 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type
), new_obj_rec
);
2622 TREE_TYPE (TYPE_FIELDS (new_obj_rec
)) = TREE_TYPE (ptr_temp_type
);
2623 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2624 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
)));
2625 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2626 = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2627 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2628 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2630 TYPE_SIZE (new_obj_rec
)
2631 = size_binop (PLUS_EXPR
,
2632 DECL_SIZE (TYPE_FIELDS (new_obj_rec
)),
2633 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2634 TYPE_SIZE_UNIT (new_obj_rec
)
2635 = size_binop (PLUS_EXPR
,
2636 DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec
)),
2637 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2638 rest_of_type_compilation (ptr
, global_bindings_p ());
2642 /* Convert a pointer to a constrained array into a pointer to a fat
2643 pointer. This involves making or finding a template. */
2646 convert_to_fat_pointer (tree type
, tree expr
)
2648 tree template_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
))));
2649 tree
template, template_addr
;
2650 tree etype
= TREE_TYPE (expr
);
2652 /* If EXPR is a constant of zero, we make a fat pointer that has a null
2653 pointer to the template and array. */
2654 if (integer_zerop (expr
))
2656 gnat_build_constructor
2658 tree_cons (TYPE_FIELDS (type
),
2659 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2660 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2661 convert (build_pointer_type (template_type
),
2665 /* If EXPR is a thin pointer, make the template and data from the record. */
2667 else if (TYPE_THIN_POINTER_P (etype
))
2669 tree fields
= TYPE_FIELDS (TREE_TYPE (etype
));
2671 expr
= save_expr (expr
);
2672 if (TREE_CODE (expr
) == ADDR_EXPR
)
2673 expr
= TREE_OPERAND (expr
, 0);
2675 expr
= build1 (INDIRECT_REF
, TREE_TYPE (etype
), expr
);
2677 template = build_component_ref (expr
, NULL_TREE
, fields
, false);
2678 expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
2679 build_component_ref (expr
, NULL_TREE
,
2680 TREE_CHAIN (fields
), false));
2683 /* Otherwise, build the constructor for the template. */
2684 template = build_template (template_type
, TREE_TYPE (etype
), expr
);
2686 template_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, template);
2688 /* The result is a CONSTRUCTOR for the fat pointer.
2690 If expr is an argument of a foreign convention subprogram, the type it
2691 points to is directly the component type. In this case, the expression
2692 type may not match the corresponding FIELD_DECL type at this point, so we
2693 call "convert" here to fix that up if necessary. This type consistency is
2694 required, for instance because it ensures that possible later folding of
2695 component_refs against this constructor always yields something of the
2696 same type as the initial reference.
2698 Note that the call to "build_template" above is still fine, because it
2699 will only refer to the provided template_type in this case. */
2701 gnat_build_constructor
2702 (type
, tree_cons (TYPE_FIELDS (type
),
2703 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2704 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2705 template_addr
, NULL_TREE
)));
2708 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
2709 is something that is a fat pointer, so convert to it first if it EXPR
2710 is not already a fat pointer. */
2713 convert_to_thin_pointer (tree type
, tree expr
)
2715 if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr
)))
2717 = convert_to_fat_pointer
2718 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))), expr
);
2720 /* We get the pointer to the data and use a NOP_EXPR to make it the
2722 expr
= build_component_ref (expr
, NULL_TREE
, TYPE_FIELDS (TREE_TYPE (expr
)),
2724 expr
= build1 (NOP_EXPR
, type
, expr
);
2729 /* Create an expression whose value is that of EXPR,
2730 converted to type TYPE. The TREE_TYPE of the value
2731 is always TYPE. This function implements all reasonable
2732 conversions; callers should filter out those that are
2733 not permitted by the language being compiled. */
2736 convert (tree type
, tree expr
)
2738 enum tree_code code
= TREE_CODE (type
);
2739 tree etype
= TREE_TYPE (expr
);
2740 enum tree_code ecode
= TREE_CODE (etype
);
2743 /* If EXPR is already the right type, we are done. */
2747 /* If the input type has padding, remove it by doing a component reference
2748 to the field. If the output type has padding, make a constructor
2749 to build the record. If both input and output have padding and are
2750 of variable size, do this as an unchecked conversion. */
2751 else if (ecode
== RECORD_TYPE
&& code
== RECORD_TYPE
2752 && TYPE_IS_PADDING_P (type
) && TYPE_IS_PADDING_P (etype
)
2753 && (!TREE_CONSTANT (TYPE_SIZE (type
))
2754 || !TREE_CONSTANT (TYPE_SIZE (etype
))))
2756 else if (ecode
== RECORD_TYPE
&& TYPE_IS_PADDING_P (etype
))
2758 /* If we have just converted to this padded type, just get
2759 the inner expression. */
2760 if (TREE_CODE (expr
) == CONSTRUCTOR
2761 && CONSTRUCTOR_ELTS (expr
)
2762 && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr
)) == TYPE_FIELDS (etype
))
2763 return TREE_VALUE (CONSTRUCTOR_ELTS (expr
));
2765 return convert (type
,
2766 build_component_ref (expr
, NULL_TREE
,
2767 TYPE_FIELDS (etype
), false));
2769 else if (code
== RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
2771 /* If we previously converted from another type and our type is
2772 of variable size, remove the conversion to avoid the need for
2773 variable-size temporaries. */
2774 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
2775 && !TREE_CONSTANT (TYPE_SIZE (type
)))
2776 expr
= TREE_OPERAND (expr
, 0);
2778 /* If we are just removing the padding from expr, convert the original
2779 object if we have variable size. That will avoid the need
2780 for some variable-size temporaries. */
2781 if (TREE_CODE (expr
) == COMPONENT_REF
2782 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == RECORD_TYPE
2783 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr
, 0)))
2784 && !TREE_CONSTANT (TYPE_SIZE (type
)))
2785 return convert (type
, TREE_OPERAND (expr
, 0));
2787 /* If the result type is a padded type with a self-referentially-sized
2788 field and the expression type is a record, do this as an
2789 unchecked converstion. */
2790 else if (TREE_CODE (etype
) == RECORD_TYPE
2791 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type
))))
2792 return unchecked_convert (type
, expr
, false);
2796 gnat_build_constructor (type
,
2797 tree_cons (TYPE_FIELDS (type
),
2799 (TYPE_FIELDS (type
)),
2804 /* If the input is a biased type, adjust first. */
2805 if (ecode
== INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype
))
2806 return convert (type
, fold (build2 (PLUS_EXPR
, TREE_TYPE (etype
),
2807 fold (build1 (NOP_EXPR
,
2810 TYPE_MIN_VALUE (etype
))));
2812 /* If the input is a justified modular type, we need to extract
2813 the actual object before converting it to any other type with the
2814 exception of an unconstrained array. */
2815 if (ecode
== RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (etype
)
2816 && code
!= UNCONSTRAINED_ARRAY_TYPE
)
2817 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2818 TYPE_FIELDS (etype
), false));
2820 /* If converting to a type that contains a template, convert to the data
2821 type and then build the template. */
2822 if (code
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type
))
2824 tree obj_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2826 /* If the source already has a template, get a reference to the
2827 associated array only, as we are going to rebuild a template
2828 for the target type anyway. */
2829 expr
= maybe_unconstrained_array (expr
);
2832 gnat_build_constructor
2834 tree_cons (TYPE_FIELDS (type
),
2835 build_template (TREE_TYPE (TYPE_FIELDS (type
)),
2836 obj_type
, NULL_TREE
),
2837 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2838 convert (obj_type
, expr
), NULL_TREE
)));
2841 /* There are some special cases of expressions that we process
2843 switch (TREE_CODE (expr
))
2849 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
2850 conversion in gnat_expand_expr. NULL_EXPR does not represent
2851 and actual value, so no conversion is needed. */
2852 expr
= copy_node (expr
);
2853 TREE_TYPE (expr
) = type
;
2857 /* If we are converting a STRING_CST to another constrained array type,
2858 just make a new one in the proper type. */
2859 if (code
== ecode
&& AGGREGATE_TYPE_P (etype
)
2860 && !(TREE_CODE (TYPE_SIZE (etype
)) == INTEGER_CST
2861 && TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2862 && (TREE_CODE (expr
) == STRING_CST
2863 || get_alias_set (etype
) == get_alias_set (type
)))
2865 expr
= copy_node (expr
);
2866 TREE_TYPE (expr
) = type
;
2871 case UNCONSTRAINED_ARRAY_REF
:
2872 /* Convert this to the type of the inner array by getting the address of
2873 the array from the template. */
2874 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2875 build_component_ref (TREE_OPERAND (expr
, 0),
2876 get_identifier ("P_ARRAY"),
2878 etype
= TREE_TYPE (expr
);
2879 ecode
= TREE_CODE (etype
);
2882 case VIEW_CONVERT_EXPR
:
2883 if (AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
2884 && !TYPE_FAT_POINTER_P (type
) && !TYPE_FAT_POINTER_P (etype
))
2885 return convert (type
, TREE_OPERAND (expr
, 0));
2889 /* If both types are record types, just convert the pointer and
2890 make a new INDIRECT_REF.
2892 ??? Disable this for now since it causes problems with the
2893 code in build_binary_op for MODIFY_EXPR which wants to
2894 strip off conversions. But that code really is a mess and
2895 we need to do this a much better way some time. */
2897 && (TREE_CODE (type
) == RECORD_TYPE
2898 || TREE_CODE (type
) == UNION_TYPE
)
2899 && (TREE_CODE (etype
) == RECORD_TYPE
2900 || TREE_CODE (etype
) == UNION_TYPE
)
2901 && !TYPE_FAT_POINTER_P (type
) && !TYPE_FAT_POINTER_P (etype
))
2902 return build_unary_op (INDIRECT_REF
, NULL_TREE
,
2903 convert (build_pointer_type (type
),
2904 TREE_OPERAND (expr
, 0)));
2911 /* Check for converting to a pointer to an unconstrained array. */
2912 if (TYPE_FAT_POINTER_P (type
) && !TYPE_FAT_POINTER_P (etype
))
2913 return convert_to_fat_pointer (type
, expr
);
2915 /* If we're converting between two aggregate types that have the same main
2916 variant, just make a VIEW_CONVER_EXPR. */
2917 else if (AGGREGATE_TYPE_P (type
)
2918 && TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
))
2919 return build1 (VIEW_CONVERT_EXPR
, type
, expr
);
2921 /* In all other cases of related types, make a NOP_EXPR. */
2922 else if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
)
2923 || (code
== INTEGER_CST
&& ecode
== INTEGER_CST
2924 && (type
== TREE_TYPE (etype
) || etype
== TREE_TYPE (type
))))
2925 return fold (build1 (NOP_EXPR
, type
, expr
));
2930 return build1 (CONVERT_EXPR
, type
, expr
);
2933 return fold (build1 (NOP_EXPR
, type
, gnat_truthvalue_conversion (expr
)));
2936 if (TYPE_HAS_ACTUAL_BOUNDS_P (type
)
2937 && (ecode
== ARRAY_TYPE
|| ecode
== UNCONSTRAINED_ARRAY_TYPE
2938 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))))
2939 return unchecked_convert (type
, expr
, false);
2940 else if (TYPE_BIASED_REPRESENTATION_P (type
))
2941 return fold (build1 (CONVERT_EXPR
, type
,
2942 fold (build2 (MINUS_EXPR
, TREE_TYPE (type
),
2943 convert (TREE_TYPE (type
), expr
),
2944 TYPE_MIN_VALUE (type
)))));
2946 /* ... fall through ... */
2949 return fold (convert_to_integer (type
, expr
));
2952 case REFERENCE_TYPE
:
2953 /* If converting between two pointers to records denoting
2954 both a template and type, adjust if needed to account
2955 for any differing offsets, since one might be negative. */
2956 if (TYPE_THIN_POINTER_P (etype
) && TYPE_THIN_POINTER_P (type
))
2959 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype
))),
2960 bit_position (TYPE_FIELDS (TREE_TYPE (type
))));
2961 tree byte_diff
= size_binop (CEIL_DIV_EXPR
, bit_diff
,
2962 sbitsize_int (BITS_PER_UNIT
));
2964 expr
= build1 (NOP_EXPR
, type
, expr
);
2965 TREE_CONSTANT (expr
) = TREE_CONSTANT (TREE_OPERAND (expr
, 0));
2966 if (integer_zerop (byte_diff
))
2969 return build_binary_op (PLUS_EXPR
, type
, expr
,
2970 fold (convert_to_pointer (type
, byte_diff
)));
2973 /* If converting to a thin pointer, handle specially. */
2974 if (TYPE_THIN_POINTER_P (type
)
2975 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)))
2976 return convert_to_thin_pointer (type
, expr
);
2978 /* If converting fat pointer to normal pointer, get the pointer to the
2979 array and then convert it. */
2980 else if (TYPE_FAT_POINTER_P (etype
))
2981 expr
= build_component_ref (expr
, get_identifier ("P_ARRAY"),
2984 return fold (convert_to_pointer (type
, expr
));
2987 return fold (convert_to_real (type
, expr
));
2990 if (TYPE_JUSTIFIED_MODULAR_P (type
) && !AGGREGATE_TYPE_P (etype
))
2992 gnat_build_constructor
2993 (type
, tree_cons (TYPE_FIELDS (type
),
2994 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2997 /* ... fall through ... */
3000 /* In these cases, assume the front-end has validated the conversion.
3001 If the conversion is valid, it will be a bit-wise conversion, so
3002 it can be viewed as an unchecked conversion. */
3003 return unchecked_convert (type
, expr
, false);
3006 /* Just validate that the type is indeed that of a field
3007 of the type. Then make the simple conversion. */
3008 for (tem
= TYPE_FIELDS (type
); tem
; tem
= TREE_CHAIN (tem
))
3010 if (TREE_TYPE (tem
) == etype
)
3011 return build1 (CONVERT_EXPR
, type
, expr
);
3012 else if (TREE_CODE (TREE_TYPE (tem
)) == RECORD_TYPE
3013 && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem
))
3014 || TYPE_IS_PADDING_P (TREE_TYPE (tem
)))
3015 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem
))) == etype
)
3016 return build1 (CONVERT_EXPR
, type
,
3017 convert (TREE_TYPE (tem
), expr
));
3022 case UNCONSTRAINED_ARRAY_TYPE
:
3023 /* If EXPR is a constrained array, take its address, convert it to a
3024 fat pointer, and then dereference it. Likewise if EXPR is a
3025 record containing both a template and a constrained array.
3026 Note that a record representing a justified modular type
3027 always represents a packed constrained array. */
3028 if (ecode
== ARRAY_TYPE
3029 || (ecode
== INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (etype
))
3030 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))
3031 || (ecode
== RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (etype
)))
3034 (INDIRECT_REF
, NULL_TREE
,
3035 convert_to_fat_pointer (TREE_TYPE (type
),
3036 build_unary_op (ADDR_EXPR
,
3039 /* Do something very similar for converting one unconstrained
3040 array to another. */
3041 else if (ecode
== UNCONSTRAINED_ARRAY_TYPE
)
3043 build_unary_op (INDIRECT_REF
, NULL_TREE
,
3044 convert (TREE_TYPE (type
),
3045 build_unary_op (ADDR_EXPR
,
3051 return fold (convert_to_complex (type
, expr
));
3058 /* Remove all conversions that are done in EXP. This includes converting
3059 from a padded type or to a justified modular type. If TRUE_ADDRESS
3060 is true, always return the address of the containing object even if
3061 the address is not bit-aligned. */
3064 remove_conversions (tree exp
, bool true_address
)
3066 switch (TREE_CODE (exp
))
3070 && TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
3071 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp
)))
3072 return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp
)), true);
3076 if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp
, 0))) == RECORD_TYPE
3077 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp
, 0))))
3078 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3081 case VIEW_CONVERT_EXPR
: case NON_LVALUE_EXPR
:
3082 case NOP_EXPR
: case CONVERT_EXPR
:
3083 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3092 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3093 refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
3094 likewise return an expression pointing to the underlying array. */
3097 maybe_unconstrained_array (tree exp
)
3099 enum tree_code code
= TREE_CODE (exp
);
3102 switch (TREE_CODE (TREE_TYPE (exp
)))
3104 case UNCONSTRAINED_ARRAY_TYPE
:
3105 if (code
== UNCONSTRAINED_ARRAY_REF
)
3108 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
3109 build_component_ref (TREE_OPERAND (exp
, 0),
3110 get_identifier ("P_ARRAY"),
3112 TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp
);
3116 else if (code
== NULL_EXPR
)
3117 return build1 (NULL_EXPR
,
3118 TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3119 (TREE_TYPE (TREE_TYPE (exp
))))),
3120 TREE_OPERAND (exp
, 0));
3123 /* If this is a padded type, convert to the unpadded type and see if
3124 it contains a template. */
3125 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
3127 new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
3128 if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3129 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
3131 build_component_ref (new, NULL_TREE
,
3132 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
3135 else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp
)))
3137 build_component_ref (exp
, NULL_TREE
,
3138 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp
))), 0);
3148 /* Return an expression that does an unchecked converstion of EXPR to TYPE.
3149 If NOTRUNC_P is true, truncation operations should be suppressed. */
3152 unchecked_convert (tree type
, tree expr
, bool notrunc_p
)
3154 tree etype
= TREE_TYPE (expr
);
3156 /* If the expression is already the right type, we are done. */
3160 /* If both types types are integral just do a normal conversion.
3161 Likewise for a conversion to an unconstrained array. */
3162 if ((((INTEGRAL_TYPE_P (type
)
3163 && !(TREE_CODE (type
) == INTEGER_TYPE
3164 && TYPE_VAX_FLOATING_POINT_P (type
)))
3165 || (POINTER_TYPE_P (type
) && ! TYPE_THIN_POINTER_P (type
))
3166 || (TREE_CODE (type
) == RECORD_TYPE
3167 && TYPE_JUSTIFIED_MODULAR_P (type
)))
3168 && ((INTEGRAL_TYPE_P (etype
)
3169 && !(TREE_CODE (etype
) == INTEGER_TYPE
3170 && TYPE_VAX_FLOATING_POINT_P (etype
)))
3171 || (POINTER_TYPE_P (etype
) && !TYPE_THIN_POINTER_P (etype
))
3172 || (TREE_CODE (etype
) == RECORD_TYPE
3173 && TYPE_JUSTIFIED_MODULAR_P (etype
))))
3174 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3178 if (TREE_CODE (etype
) == INTEGER_TYPE
3179 && TYPE_BIASED_REPRESENTATION_P (etype
))
3181 tree ntype
= copy_type (etype
);
3183 TYPE_BIASED_REPRESENTATION_P (ntype
) = 0;
3184 TYPE_MAIN_VARIANT (ntype
) = ntype
;
3185 expr
= build1 (NOP_EXPR
, ntype
, expr
);
3188 if (TREE_CODE (type
) == INTEGER_TYPE
3189 && TYPE_BIASED_REPRESENTATION_P (type
))
3191 rtype
= copy_type (type
);
3192 TYPE_BIASED_REPRESENTATION_P (rtype
) = 0;
3193 TYPE_MAIN_VARIANT (rtype
) = rtype
;
3196 expr
= convert (rtype
, expr
);
3198 expr
= build1 (NOP_EXPR
, type
, expr
);
3201 /* If we are converting TO an integral type whose precision is not the
3202 same as its size, first unchecked convert to a record that contains
3203 an object of the output type. Then extract the field. */
3204 else if (INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
)
3205 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3206 GET_MODE_BITSIZE (TYPE_MODE (type
))))
3208 tree rec_type
= make_node (RECORD_TYPE
);
3209 tree field
= create_field_decl (get_identifier ("OBJ"), type
,
3210 rec_type
, 1, 0, 0, 0);
3212 TYPE_FIELDS (rec_type
) = field
;
3213 layout_type (rec_type
);
3215 expr
= unchecked_convert (rec_type
, expr
, notrunc_p
);
3216 expr
= build_component_ref (expr
, NULL_TREE
, field
, 0);
3219 /* Similarly for integral input type whose precision is not equal to its
3221 else if (INTEGRAL_TYPE_P (etype
) && TYPE_RM_SIZE (etype
)
3222 && 0 != compare_tree_int (TYPE_RM_SIZE (etype
),
3223 GET_MODE_BITSIZE (TYPE_MODE (etype
))))
3225 tree rec_type
= make_node (RECORD_TYPE
);
3227 = create_field_decl (get_identifier ("OBJ"), etype
, rec_type
,
3230 TYPE_FIELDS (rec_type
) = field
;
3231 layout_type (rec_type
);
3233 expr
= gnat_build_constructor (rec_type
, build_tree_list (field
, expr
));
3234 expr
= unchecked_convert (type
, expr
, notrunc_p
);
3237 /* We have a special case when we are converting between two
3238 unconstrained array types. In that case, take the address,
3239 convert the fat pointer types, and dereference. */
3240 else if (TREE_CODE (etype
) == UNCONSTRAINED_ARRAY_TYPE
3241 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3242 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3243 build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (type
),
3244 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3248 expr
= maybe_unconstrained_array (expr
);
3250 /* There's no point in doing two unchecked conversions in a row. */
3251 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
)
3252 expr
= TREE_OPERAND (expr
, 0);
3254 etype
= TREE_TYPE (expr
);
3255 expr
= build1 (VIEW_CONVERT_EXPR
, type
, expr
);
3258 /* If the result is an integral type whose size is not equal to
3259 the size of the underlying machine type, sign- or zero-extend
3260 the result. We need not do this in the case where the input is
3261 an integral type of the same precision and signedness or if the output
3262 is a biased type or if both the input and output are unsigned. */
3264 && INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
)
3265 && !(TREE_CODE (type
) == INTEGER_TYPE
3266 && TYPE_BIASED_REPRESENTATION_P (type
))
3267 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3268 GET_MODE_BITSIZE (TYPE_MODE (type
)))
3269 && !(INTEGRAL_TYPE_P (etype
)
3270 && TYPE_UNSIGNED (type
) == TYPE_UNSIGNED (etype
)
3271 && operand_equal_p (TYPE_RM_SIZE (type
),
3272 (TYPE_RM_SIZE (etype
) != 0
3273 ? TYPE_RM_SIZE (etype
) : TYPE_SIZE (etype
)),
3275 && !(TYPE_UNSIGNED (type
) && TYPE_UNSIGNED (etype
)))
3277 tree base_type
= gnat_type_for_mode (TYPE_MODE (type
),
3278 TYPE_UNSIGNED (type
));
3280 = convert (base_type
,
3281 size_binop (MINUS_EXPR
,
3283 (GET_MODE_BITSIZE (TYPE_MODE (type
))),
3284 TYPE_RM_SIZE (type
)));
3287 build_binary_op (RSHIFT_EXPR
, base_type
,
3288 build_binary_op (LSHIFT_EXPR
, base_type
,
3289 convert (base_type
, expr
),
3294 /* An unchecked conversion should never raise Constraint_Error. The code
3295 below assumes that GCC's conversion routines overflow the same way that
3296 the underlying hardware does. This is probably true. In the rare case
3297 when it is false, we can rely on the fact that such conversions are
3298 erroneous anyway. */
3299 if (TREE_CODE (expr
) == INTEGER_CST
)
3300 TREE_OVERFLOW (expr
) = TREE_CONSTANT_OVERFLOW (expr
) = 0;
3302 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3303 show no longer constant. */
3304 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
3305 && !operand_equal_p (TYPE_SIZE_UNIT (type
), TYPE_SIZE_UNIT (etype
),
3307 TREE_CONSTANT (expr
) = 0;
3312 /* Search the chain of currently reachable declarations for a builtin
3313 FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
3314 Return the first node found, if any, or NULL_TREE otherwise. */
3316 builtin_decl_for (tree name
__attribute__ ((unused
)))
3318 /* ??? not clear yet how to implement this function in tree-ssa, so
3319 return NULL_TREE for now */
3323 #include "gt-ada-utils.h"
3324 #include "gtype-ada.h"