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 void gnat_finalize (tree
);
129 static tree
float_type_for_precision (int, enum machine_mode
);
130 static tree
convert_to_fat_pointer (tree
, tree
);
131 static tree
convert_to_thin_pointer (tree
, tree
);
132 static tree
make_descriptor_field (const char *,tree
, tree
, tree
);
133 static bool value_factor_p (tree
, HOST_WIDE_INT
);
134 static bool potential_alignment_gap (tree
, tree
, tree
);
136 /* Initialize the association of GNAT nodes to GCC trees. */
139 init_gnat_to_gnu (void)
141 associate_gnat_to_gnu
142 = (tree
*) ggc_alloc_cleared (max_gnat_nodes
* sizeof (tree
));
145 /* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
146 which is to be associated with GNAT_ENTITY. Such GCC tree node is always
147 a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
149 If GNU_DECL is zero, a previous association is to be reset. */
152 save_gnu_tree (Entity_Id gnat_entity
, tree gnu_decl
, int no_check
)
154 /* Check that GNAT_ENTITY is not already defined and that it is being set
155 to something which is a decl. Raise gigi 401 if not. Usually, this
156 means GNAT_ENTITY is defined twice, but occasionally is due to some
159 && (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
]
160 || (! no_check
&& ! DECL_P (gnu_decl
))))
163 associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] = gnu_decl
;
166 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
167 Return the ..._DECL node that was associated with it. If there is no tree
168 node associated with GNAT_ENTITY, abort.
170 In some cases, such as delayed elaboration or expressions that need to
171 be elaborated only once, GNAT_ENTITY is really not an entity. */
174 get_gnu_tree (Entity_Id gnat_entity
)
176 if (! associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
])
179 return associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
];
182 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
185 present_gnu_tree (Entity_Id gnat_entity
)
187 return (associate_gnat_to_gnu
[gnat_entity
- First_Node_Id
] != NULL_TREE
);
191 /* Return non-zero if we are currently in the global binding level. */
194 global_bindings_p (void)
196 return (force_global
!= 0 || current_binding_level
== 0
197 || current_binding_level
->chain
== 0 ? -1 : 0);
200 /* Enter a new binding level. */
205 struct gnat_binding_level
*newlevel
= NULL
;
207 /* Reuse a struct for this binding level, if there is one. */
208 if (free_binding_level
)
210 newlevel
= free_binding_level
;
211 free_binding_level
= free_binding_level
->chain
;
215 = (struct gnat_binding_level
*)
216 ggc_alloc (sizeof (struct gnat_binding_level
));
218 /* Use a free BLOCK, if any; otherwise, allocate one. */
219 if (free_block_chain
)
221 newlevel
->block
= free_block_chain
;
222 free_block_chain
= TREE_CHAIN (free_block_chain
);
223 TREE_CHAIN (newlevel
->block
) = NULL_TREE
;
226 newlevel
->block
= make_node (BLOCK
);
228 /* Point the BLOCK we just made to its parent. */
229 if (current_binding_level
)
230 BLOCK_SUPERCONTEXT (newlevel
->block
) = current_binding_level
->block
;
232 BLOCK_VARS (newlevel
->block
) = BLOCK_SUBBLOCKS (newlevel
->block
) = NULL_TREE
;
233 TREE_USED (newlevel
->block
) = 1;
235 /* Add this level to the front of the chain (stack) of levels that are
237 newlevel
->chain
= current_binding_level
;
238 newlevel
->jmpbuf_decl
= NULL_TREE
;
239 current_binding_level
= newlevel
;
242 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
243 and point FNDECL to this BLOCK. */
246 set_current_block_context (tree fndecl
)
248 BLOCK_SUPERCONTEXT (current_binding_level
->block
) = fndecl
;
249 DECL_INITIAL (fndecl
) = current_binding_level
->block
;
252 /* Set the jmpbuf_decl for the current binding level to DECL. */
255 set_block_jmpbuf_decl (tree decl
)
257 current_binding_level
->jmpbuf_decl
= decl
;
260 /* Get the jmpbuf_decl, if any, for the current binding level. */
263 get_block_jmpbuf_decl ()
265 return current_binding_level
->jmpbuf_decl
;
268 /* Exit a binding level. Set any BLOCK into the current code group. */
273 struct gnat_binding_level
*level
= current_binding_level
;
274 tree block
= level
->block
;
276 BLOCK_VARS (block
) = nreverse (BLOCK_VARS (block
));
277 BLOCK_SUBBLOCKS (block
) = nreverse (BLOCK_SUBBLOCKS (block
));
279 /* If this is a function-level BLOCK don't do anything. Otherwise, if there
280 are no variables free the block and merge its subblocks into those of its
281 parent block. Otherwise, add it to the list of its parent. */
282 if (TREE_CODE (BLOCK_SUPERCONTEXT (block
)) == FUNCTION_DECL
)
284 else if (BLOCK_VARS (block
) == NULL_TREE
)
286 BLOCK_SUBBLOCKS (level
->chain
->block
)
287 = chainon (BLOCK_SUBBLOCKS (block
),
288 BLOCK_SUBBLOCKS (level
->chain
->block
));
289 TREE_CHAIN (block
) = free_block_chain
;
290 free_block_chain
= block
;
294 TREE_CHAIN (block
) = BLOCK_SUBBLOCKS (level
->chain
->block
);
295 BLOCK_SUBBLOCKS (level
->chain
->block
) = block
;
296 TREE_USED (block
) = 1;
297 set_block_for_group (block
);
300 /* Free this binding structure. */
301 current_binding_level
= level
->chain
;
302 level
->chain
= free_binding_level
;
303 free_binding_level
= level
;
306 /* Insert BLOCK at the end of the list of subblocks of the
307 current binding level. This is used when a BIND_EXPR is expanded,
308 to handle the BLOCK node inside the BIND_EXPR. */
311 insert_block (tree block
)
313 TREE_USED (block
) = 1;
314 TREE_CHAIN (block
) = BLOCK_SUBBLOCKS (current_binding_level
->block
);
315 BLOCK_SUBBLOCKS (current_binding_level
->block
) = block
;
318 /* Records a ..._DECL node DECL as belonging to the current lexical scope
319 and uses GNAT_NODE for location information. */
322 gnat_pushdecl (tree decl
, Node_Id gnat_node
)
324 /* If at top level, there is no context. But PARM_DECLs always go in the
325 level of its function. */
326 if (global_bindings_p () && TREE_CODE (decl
) != PARM_DECL
)
327 DECL_CONTEXT (decl
) = 0;
329 DECL_CONTEXT (decl
) = current_function_decl
;
331 /* Set the location of DECL and emit a declaration for it. */
332 if (Present (gnat_node
))
333 Sloc_to_locus (Sloc (gnat_node
), &DECL_SOURCE_LOCATION (decl
));
334 add_decl_expr (decl
, gnat_node
);
336 /* Put the declaration on the list. The list of declarations is in reverse
337 order. The list will be reversed later. We don't do this for global
338 variables. Also, don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
339 the list. They will cause trouble with the debugger and aren't needed
341 if (!global_bindings_p ()
342 && (TREE_CODE (decl
) != TYPE_DECL
343 || TREE_CODE (TREE_TYPE (decl
)) != UNCONSTRAINED_ARRAY_TYPE
))
345 TREE_CHAIN (decl
) = BLOCK_VARS (current_binding_level
->block
);
346 BLOCK_VARS (current_binding_level
->block
) = decl
;
349 /* For the declaration of a type, set its name if it either is not already
350 set, was set to an IDENTIFIER_NODE, indicating an internal name,
351 or if the previous type name was not derived from a source name.
352 We'd rather have the type named with a real name and all the pointer
353 types to the same object have the same POINTER_TYPE node. Code in this
354 function in c-decl.c makes a copy of the type node here, but that may
355 cause us trouble with incomplete types, so let's not try it (at least
358 if (TREE_CODE (decl
) == TYPE_DECL
359 && DECL_NAME (decl
) != 0
360 && (TYPE_NAME (TREE_TYPE (decl
)) == 0
361 || TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == IDENTIFIER_NODE
362 || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl
))) == TYPE_DECL
363 && DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl
)))
364 && ! DECL_ARTIFICIAL (decl
))))
365 TYPE_NAME (TREE_TYPE (decl
)) = decl
;
367 if (TREE_CODE (decl
) != CONST_DECL
)
368 rest_of_decl_compilation (decl
, NULL
, global_bindings_p (), 0);
371 /* Do little here. Set up the standard declarations later after the
372 front end has been run. */
375 gnat_init_decl_processing (void)
379 /* Make the binding_level structure for global names. */
380 current_function_decl
= 0;
381 current_binding_level
= 0;
382 free_binding_level
= 0;
385 build_common_tree_nodes (0);
387 /* In Ada, we use a signed type for SIZETYPE. Use the signed type
388 corresponding to the size of Pmode. In most cases when ptr_mode and
389 Pmode differ, C will use the width of ptr_mode as sizetype. But we get
390 far better code using the width of Pmode. Make this here since we need
391 this before we can expand the GNAT types. */
392 size_type_node
= gnat_type_for_size (GET_MODE_BITSIZE (Pmode
), 0);
393 set_sizetype (size_type_node
);
394 build_common_tree_nodes_2 (0);
396 /* Give names and make TYPE_DECLs for common types. */
397 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier (SIZE_TYPE
), sizetype
),
399 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
402 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
405 gnat_pushdecl (build_decl (TYPE_DECL
, get_identifier ("long integer"),
406 long_integer_type_node
),
409 ptr_void_type_node
= build_pointer_type (void_type_node
);
411 gnat_install_builtins ();
414 /* Define a builtin function. This is temporary and is just being done
415 to initialize implicit_built_in_decls for the middle-end. We'll want
416 to do full builtin processing soon. */
419 gnat_define_builtin (const char *name
, tree type
,
420 int function_code
, const char *library_name
, bool const_p
)
422 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
424 DECL_EXTERNAL (decl
) = 1;
425 TREE_PUBLIC (decl
) = 1;
427 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
428 make_decl_rtl (decl
, NULL
);
429 gnat_pushdecl (decl
, Empty
);
430 DECL_BUILT_IN_CLASS (decl
) = BUILT_IN_NORMAL
;
431 DECL_FUNCTION_CODE (decl
) = function_code
;
432 TREE_READONLY (decl
) = const_p
;
434 implicit_built_in_decls
[function_code
] = decl
;
437 /* Install the builtin functions the middle-end needs. */
440 gnat_install_builtins ()
445 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, void_list_node
);
446 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, tmp
);
447 ftype
= build_function_type (long_integer_type_node
, tmp
);
448 gnat_define_builtin ("__builtin_expect", ftype
, BUILT_IN_EXPECT
,
449 "__builtin_expect", true);
451 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
452 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
453 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
454 ftype
= build_function_type (ptr_void_type_node
, tmp
);
455 gnat_define_builtin ("__builtin_memcpy", ftype
, BUILT_IN_MEMCPY
,
458 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
459 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
460 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
461 ftype
= build_function_type (integer_type_node
, tmp
);
462 gnat_define_builtin ("__builtin_memcmp", ftype
, BUILT_IN_MEMCMP
,
465 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
466 tmp
= tree_cons (NULL_TREE
, integer_type_node
, tmp
);
467 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
468 ftype
= build_function_type (integer_type_node
, tmp
);
469 gnat_define_builtin ("__builtin_memset", ftype
, BUILT_IN_MEMSET
,
472 tmp
= tree_cons (NULL_TREE
, integer_type_node
, void_list_node
);
473 ftype
= build_function_type (integer_type_node
, tmp
);
474 gnat_define_builtin ("__builtin_clz", ftype
, BUILT_IN_CLZ
, "clz", true);
476 tmp
= tree_cons (NULL_TREE
, long_integer_type_node
, void_list_node
);
477 ftype
= build_function_type (integer_type_node
, tmp
);
478 gnat_define_builtin ("__builtin_clzl", ftype
, BUILT_IN_CLZL
, "clzl", true);
480 tmp
= tree_cons (NULL_TREE
, long_long_integer_type_node
, void_list_node
);
481 ftype
= build_function_type (integer_type_node
, tmp
);
482 gnat_define_builtin ("__builtin_clzll", ftype
, BUILT_IN_CLZLL
, "clzll",
485 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
486 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
487 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, tmp
);
488 ftype
= build_function_type (void_type_node
, tmp
);
489 gnat_define_builtin ("__builtin_init_trampoline", ftype
,
490 BUILT_IN_INIT_TRAMPOLINE
, "init_trampoline", false);
492 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
493 ftype
= build_function_type (ptr_void_type_node
, tmp
);
494 gnat_define_builtin ("__builtin_adjust_trampoline", ftype
,
495 BUILT_IN_ADJUST_TRAMPOLINE
, "adjust_trampoline", true);
497 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
498 tmp
= tree_cons (NULL_TREE
, size_type_node
, void_list_node
);
499 ftype
= build_function_type (ptr_void_type_node
, tmp
);
500 gnat_define_builtin ("__builtin_stack_alloc", ftype
, BUILT_IN_STACK_ALLOC
,
501 "stack_alloc", false);
503 /* The stack_save and stack_restore builtins aren't used directly. They
504 are inserted during gimplification to implement stack_alloc calls. */
505 ftype
= build_function_type (ptr_void_type_node
, void_list_node
);
506 gnat_define_builtin ("__builtin_stack_save", ftype
, BUILT_IN_STACK_SAVE
,
507 "stack_save", false);
508 tmp
= tree_cons (NULL_TREE
, ptr_void_type_node
, void_list_node
);
509 ftype
= build_function_type (void_type_node
, tmp
);
510 gnat_define_builtin ("__builtin_stack_restore", ftype
,
511 BUILT_IN_STACK_RESTORE
, "stack_restore", false);
514 /* Create the predefined scalar types such as `integer_type_node' needed
515 in the gcc back-end and initialize the global binding level. */
518 init_gigi_decls (tree long_long_float_type
, tree exception_type
)
523 /* Set the types that GCC and Gigi use from the front end. We would like
524 to do this for char_type_node, but it needs to correspond to the C
526 if (TREE_CODE (TREE_TYPE (long_long_float_type
)) == INTEGER_TYPE
)
528 /* In this case, the builtin floating point types are VAX float,
529 so make up a type for use. */
530 longest_float_type_node
= make_node (REAL_TYPE
);
531 TYPE_PRECISION (longest_float_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
532 layout_type (longest_float_type_node
);
533 create_type_decl (get_identifier ("longest float type"),
534 longest_float_type_node
, NULL
, 0, 1, Empty
);
537 longest_float_type_node
= TREE_TYPE (long_long_float_type
);
539 except_type_node
= TREE_TYPE (exception_type
);
541 unsigned_type_node
= gnat_type_for_size (INT_TYPE_SIZE
, 1);
542 create_type_decl (get_identifier ("unsigned int"), unsigned_type_node
,
545 void_type_decl_node
= create_type_decl (get_identifier ("void"),
546 void_type_node
, NULL
, 0, 1, Empty
);
548 void_ftype
= build_function_type (void_type_node
, NULL_TREE
);
549 ptr_void_ftype
= build_pointer_type (void_ftype
);
551 /* Now declare runtime functions. */
552 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
554 /* malloc is a function declaration tree for a function to allocate
556 malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"),
558 build_function_type (ptr_void_type_node
,
559 tree_cons (NULL_TREE
,
562 NULL_TREE
, 0, 1, 1, 0, Empty
);
564 /* free is a function declaration tree for a function to free memory. */
566 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE
,
567 build_function_type (void_type_node
,
568 tree_cons (NULL_TREE
,
571 NULL_TREE
, 0, 1, 1, 0, Empty
);
573 /* Make the types and functions used for exception processing. */
575 = build_array_type (gnat_type_for_mode (Pmode
, 0),
576 build_index_type (build_int_2 (5, 0)));
577 create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type
, NULL
,
579 jmpbuf_ptr_type
= build_pointer_type (jmpbuf_type
);
581 /* Functions to get and set the jumpbuf pointer for the current thread. */
583 = create_subprog_decl
584 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
585 NULL_TREE
, build_function_type (jmpbuf_ptr_type
, NULL_TREE
),
586 NULL_TREE
, 0, 1, 1, 0, Empty
);
589 = create_subprog_decl
590 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
592 build_function_type (void_type_node
,
593 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
594 NULL_TREE
, 0, 1, 1, 0, Empty
);
596 /* Function to get the current exception. */
598 = create_subprog_decl
599 (get_identifier ("system__soft_links__get_gnat_exception"),
601 build_function_type (build_pointer_type (except_type_node
), NULL_TREE
),
602 NULL_TREE
, 0, 1, 1, 0, Empty
);
604 /* Functions that raise exceptions. */
606 = create_subprog_decl
607 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE
,
608 build_function_type (void_type_node
,
609 tree_cons (NULL_TREE
,
610 build_pointer_type (except_type_node
),
612 NULL_TREE
, 0, 1, 1, 0, Empty
);
614 /* Hooks to call when entering/leaving an exception handler. */
616 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE
,
617 build_function_type (void_type_node
,
618 tree_cons (NULL_TREE
,
621 NULL_TREE
, 0, 1, 1, 0, Empty
);
624 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE
,
625 build_function_type (void_type_node
,
626 tree_cons (NULL_TREE
,
629 NULL_TREE
, 0, 1, 1, 0, Empty
);
631 /* If in no exception handlers mode, all raise statements are redirected to
632 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
633 this procedure will never be called in this mode. */
634 if (No_Exception_Handlers_Set ())
637 = create_subprog_decl
638 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE
,
639 build_function_type (void_type_node
,
640 tree_cons (NULL_TREE
,
641 build_pointer_type (char_type_node
),
642 tree_cons (NULL_TREE
,
645 NULL_TREE
, 0, 1, 1, 0, Empty
);
647 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
648 gnat_raise_decls
[i
] = decl
;
651 /* Otherwise, make one decl for each exception reason. */
652 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
656 sprintf (name
, "__gnat_rcheck_%.2d", i
);
658 = create_subprog_decl
659 (get_identifier (name
), NULL_TREE
,
660 build_function_type (void_type_node
,
661 tree_cons (NULL_TREE
,
664 tree_cons (NULL_TREE
,
667 NULL_TREE
, 0, 1, 1, 0, Empty
);
670 /* Indicate that these never return. */
671 TREE_THIS_VOLATILE (raise_nodefer_decl
) = 1;
672 TREE_SIDE_EFFECTS (raise_nodefer_decl
) = 1;
673 TREE_TYPE (raise_nodefer_decl
)
674 = build_qualified_type (TREE_TYPE (raise_nodefer_decl
),
677 for (i
= 0; i
< ARRAY_SIZE (gnat_raise_decls
); i
++)
679 TREE_THIS_VOLATILE (gnat_raise_decls
[i
]) = 1;
680 TREE_SIDE_EFFECTS (gnat_raise_decls
[i
]) = 1;
681 TREE_TYPE (gnat_raise_decls
[i
])
682 = build_qualified_type (TREE_TYPE (gnat_raise_decls
[i
]),
686 /* setjmp returns an integer and has one operand, which is a pointer to
689 = create_subprog_decl
690 (get_identifier ("__builtin_setjmp"), NULL_TREE
,
691 build_function_type (integer_type_node
,
692 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
693 NULL_TREE
, 0, 1, 1, 0, Empty
);
695 DECL_BUILT_IN_CLASS (setjmp_decl
) = BUILT_IN_NORMAL
;
696 DECL_FUNCTION_CODE (setjmp_decl
) = BUILT_IN_SETJMP
;
698 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
700 update_setjmp_buf_decl
701 = create_subprog_decl
702 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE
,
703 build_function_type (void_type_node
,
704 tree_cons (NULL_TREE
, jmpbuf_ptr_type
, endlink
)),
705 NULL_TREE
, 0, 1, 1, 0, Empty
);
707 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl
) = BUILT_IN_NORMAL
;
708 DECL_FUNCTION_CODE (update_setjmp_buf_decl
) = BUILT_IN_UPDATE_SETJMP_BUF
;
710 main_identifier_node
= get_identifier ("main");
713 /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes
714 (FIELDLIST), finish constructing the record or union type. If HAS_REP is
715 nonzero, this record has a rep clause; don't call layout_type but merely set
716 the size and alignment ourselves. If DEFER_DEBUG is nonzero, do not call
717 the debugging routines on this type; it will be done later. */
720 finish_record_type (tree record_type
, tree fieldlist
, int has_rep
,
723 enum tree_code code
= TREE_CODE (record_type
);
724 tree ada_size
= bitsize_zero_node
;
725 tree size
= bitsize_zero_node
;
726 tree size_unit
= size_zero_node
;
730 TYPE_FIELDS (record_type
) = fieldlist
;
731 TYPE_STUB_DECL (record_type
)
732 = build_decl (TYPE_DECL
, NULL_TREE
, record_type
);
734 /* We don't need both the typedef name and the record name output in
735 the debugging information, since they are the same. */
736 DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type
)) = 1;
738 /* Globally initialize the record first. If this is a rep'ed record,
739 that just means some initializations; otherwise, layout the record. */
743 TYPE_ALIGN (record_type
) = MAX (BITS_PER_UNIT
, TYPE_ALIGN (record_type
));
744 TYPE_MODE (record_type
) = BLKmode
;
745 if (TYPE_SIZE (record_type
) == 0)
747 TYPE_SIZE (record_type
) = bitsize_zero_node
;
748 TYPE_SIZE_UNIT (record_type
) = size_zero_node
;
750 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
751 out just like a UNION_TYPE, since the size will be fixed. */
752 else if (code
== QUAL_UNION_TYPE
)
757 /* Ensure there isn't a size already set. There can be in an error
758 case where there is a rep clause but all fields have errors and
759 no longer have a position. */
760 TYPE_SIZE (record_type
) = 0;
761 layout_type (record_type
);
764 /* At this point, the position and size of each field is known. It was
765 either set before entry by a rep clause, or by laying out the type above.
767 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
768 to compute the Ada size; the GCC size and alignment (for rep'ed records
769 that are not padding types); and the mode (for rep'ed records). We also
770 clear the DECL_BIT_FIELD indication for the cases we know have not been
771 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
773 if (code
== QUAL_UNION_TYPE
)
774 fieldlist
= nreverse (fieldlist
);
776 for (field
= fieldlist
; field
; field
= TREE_CHAIN (field
))
778 tree pos
= bit_position (field
);
780 tree type
= TREE_TYPE (field
);
781 tree this_size
= DECL_SIZE (field
);
782 tree this_size_unit
= DECL_SIZE_UNIT (field
);
783 tree this_ada_size
= DECL_SIZE (field
);
785 /* We need to make an XVE/XVU record if any field has variable size,
786 whether or not the record does. For example, if we have an union,
787 it may be that all fields, rounded up to the alignment, have the
788 same size, in which case we'll use that size. But the debug
789 output routines (except Dwarf2) won't be able to output the fields,
790 so we need to make the special record. */
791 if (TREE_CODE (this_size
) != INTEGER_CST
)
794 if ((TREE_CODE (type
) == RECORD_TYPE
|| TREE_CODE (type
) == UNION_TYPE
795 || TREE_CODE (type
) == QUAL_UNION_TYPE
)
796 && ! TYPE_IS_FAT_POINTER_P (type
)
797 && ! TYPE_CONTAINS_TEMPLATE_P (type
)
798 && TYPE_ADA_SIZE (type
) != 0)
799 this_ada_size
= TYPE_ADA_SIZE (type
);
801 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
802 if (DECL_BIT_FIELD (field
) && !STRICT_ALIGNMENT
803 && value_factor_p (pos
, BITS_PER_UNIT
)
804 && operand_equal_p (this_size
, TYPE_SIZE (type
), 0))
805 DECL_BIT_FIELD (field
) = 0;
807 /* If we still have DECL_BIT_FIELD set at this point, we know the field
808 is technically not addressable. Except that it can actually be
809 addressed if the field is BLKmode and happens to be properly
811 DECL_NONADDRESSABLE_P (field
)
812 |= DECL_BIT_FIELD (field
) && DECL_MODE (field
) != BLKmode
;
814 if (has_rep
&& ! DECL_BIT_FIELD (field
))
815 TYPE_ALIGN (record_type
)
816 = MAX (TYPE_ALIGN (record_type
), DECL_ALIGN (field
));
821 ada_size
= size_binop (MAX_EXPR
, ada_size
, this_ada_size
);
822 size
= size_binop (MAX_EXPR
, size
, this_size
);
823 size_unit
= size_binop (MAX_EXPR
, size_unit
, this_size_unit
);
826 case QUAL_UNION_TYPE
:
828 = fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
829 this_ada_size
, ada_size
));
830 size
= fold (build (COND_EXPR
, bitsizetype
, DECL_QUALIFIER (field
),
832 size_unit
= fold (build (COND_EXPR
, sizetype
, DECL_QUALIFIER (field
),
833 this_size_unit
, size_unit
));
837 /* Since we know here that all fields are sorted in order of
838 increasing bit position, the size of the record is one
839 higher than the ending bit of the last field processed
840 unless we have a rep clause, since in that case we might
841 have a field outside a QUAL_UNION_TYPE that has a higher ending
842 position. So use a MAX in that case. Also, if this field is a
843 QUAL_UNION_TYPE, we need to take into account the previous size in
844 the case of empty variants. */
846 = merge_sizes (ada_size
, pos
, this_ada_size
,
847 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
848 size
= merge_sizes (size
, pos
, this_size
,
849 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
851 = merge_sizes (size_unit
, byte_position (field
), this_size_unit
,
852 TREE_CODE (type
) == QUAL_UNION_TYPE
, has_rep
);
860 if (code
== QUAL_UNION_TYPE
)
861 nreverse (fieldlist
);
863 /* If this is a padding record, we never want to make the size smaller than
864 what was specified in it, if any. */
865 if (TREE_CODE (record_type
) == RECORD_TYPE
866 && TYPE_IS_PADDING_P (record_type
) && TYPE_SIZE (record_type
) != 0)
868 size
= TYPE_SIZE (record_type
);
869 size_unit
= TYPE_SIZE_UNIT (record_type
);
872 /* Now set any of the values we've just computed that apply. */
873 if (! TYPE_IS_FAT_POINTER_P (record_type
)
874 && ! TYPE_CONTAINS_TEMPLATE_P (record_type
))
875 SET_TYPE_ADA_SIZE (record_type
, ada_size
);
879 if (! (TREE_CODE (record_type
) == RECORD_TYPE
880 && TYPE_IS_PADDING_P (record_type
)
881 && CONTAINS_PLACEHOLDER_P (size
)))
883 TYPE_SIZE (record_type
) = round_up (size
, TYPE_ALIGN (record_type
));
884 TYPE_SIZE_UNIT (record_type
)
885 = round_up (size_unit
,
886 TYPE_ALIGN (record_type
) / BITS_PER_UNIT
);
889 compute_record_mode (record_type
);
894 /* If this record is of variable size, rename it so that the
895 debugger knows it is and make a new, parallel, record
896 that tells the debugger how the record is laid out. See
897 exp_dbug.ads. But don't do this for records that are padding
898 since they confuse GDB. */
900 && ! (TREE_CODE (record_type
) == RECORD_TYPE
901 && TYPE_IS_PADDING_P (record_type
)))
904 = make_node (TREE_CODE (record_type
) == QUAL_UNION_TYPE
905 ? UNION_TYPE
: TREE_CODE (record_type
));
906 tree orig_name
= TYPE_NAME (record_type
);
908 = (TREE_CODE (orig_name
) == TYPE_DECL
? DECL_NAME (orig_name
)
911 = concat_id_with_name (orig_id
,
912 TREE_CODE (record_type
) == QUAL_UNION_TYPE
914 tree last_pos
= bitsize_zero_node
;
916 tree prev_old_field
= 0;
918 TYPE_NAME (new_record_type
) = new_id
;
919 TYPE_ALIGN (new_record_type
) = BIGGEST_ALIGNMENT
;
920 TYPE_STUB_DECL (new_record_type
)
921 = build_decl (TYPE_DECL
, NULL_TREE
, new_record_type
);
922 DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type
)) = 1;
923 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type
))
924 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type
));
925 TYPE_SIZE (new_record_type
) = size_int (TYPE_ALIGN (record_type
));
927 /* Now scan all the fields, replacing each field with a new
928 field corresponding to the new encoding. */
929 for (old_field
= TYPE_FIELDS (record_type
); old_field
!= 0;
930 old_field
= TREE_CHAIN (old_field
))
932 tree field_type
= TREE_TYPE (old_field
);
933 tree field_name
= DECL_NAME (old_field
);
935 tree curpos
= bit_position (old_field
);
937 unsigned int align
= 0;
940 /* See how the position was modified from the last position.
942 There are two basic cases we support: a value was added
943 to the last position or the last position was rounded to
944 a boundary and they something was added. Check for the
945 first case first. If not, see if there is any evidence
946 of rounding. If so, round the last position and try
949 If this is a union, the position can be taken as zero. */
951 if (TREE_CODE (new_record_type
) == UNION_TYPE
)
952 pos
= bitsize_zero_node
, align
= 0;
954 pos
= compute_related_constant (curpos
, last_pos
);
956 if (pos
== 0 && TREE_CODE (curpos
) == MULT_EXPR
957 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
)
959 align
= TREE_INT_CST_LOW (TREE_OPERAND (curpos
, 1));
960 pos
= compute_related_constant (curpos
,
961 round_up (last_pos
, align
));
963 else if (pos
== 0 && TREE_CODE (curpos
) == PLUS_EXPR
964 && TREE_CODE (TREE_OPERAND (curpos
, 1)) == INTEGER_CST
965 && TREE_CODE (TREE_OPERAND (curpos
, 0)) == MULT_EXPR
966 && host_integerp (TREE_OPERAND
967 (TREE_OPERAND (curpos
, 0), 1),
972 (TREE_OPERAND (TREE_OPERAND (curpos
, 0), 1), 1);
973 pos
= compute_related_constant (curpos
,
974 round_up (last_pos
, align
));
976 else if (potential_alignment_gap (prev_old_field
, old_field
,
979 align
= TYPE_ALIGN (field_type
);
980 pos
= compute_related_constant (curpos
,
981 round_up (last_pos
, align
));
984 /* If we can't compute a position, set it to zero.
986 ??? We really should abort here, but it's too much work
987 to get this correct for all cases. */
990 pos
= bitsize_zero_node
;
992 /* See if this type is variable-size and make a new type
993 and indicate the indirection if so. */
994 if (TREE_CODE (DECL_SIZE (old_field
)) != INTEGER_CST
)
996 field_type
= build_pointer_type (field_type
);
1000 /* Make a new field name, if necessary. */
1001 if (var
|| align
!= 0)
1006 sprintf (suffix
, "XV%c%u", var
? 'L' : 'A',
1007 align
/ BITS_PER_UNIT
);
1009 strcpy (suffix
, "XVL");
1011 field_name
= concat_id_with_name (field_name
, suffix
);
1014 new_field
= create_field_decl (field_name
, field_type
,
1016 DECL_SIZE (old_field
), pos
, 0);
1017 TREE_CHAIN (new_field
) = TYPE_FIELDS (new_record_type
);
1018 TYPE_FIELDS (new_record_type
) = new_field
;
1020 /* If old_field is a QUAL_UNION_TYPE, take its size as being
1021 zero. The only time it's not the last field of the record
1022 is when there are other components at fixed positions after
1023 it (meaning there was a rep clause for every field) and we
1024 want to be able to encode them. */
1025 last_pos
= size_binop (PLUS_EXPR
, bit_position (old_field
),
1026 (TREE_CODE (TREE_TYPE (old_field
))
1029 : DECL_SIZE (old_field
));
1030 prev_old_field
= old_field
;
1033 TYPE_FIELDS (new_record_type
)
1034 = nreverse (TYPE_FIELDS (new_record_type
));
1036 rest_of_type_compilation (new_record_type
, global_bindings_p ());
1039 rest_of_type_compilation (record_type
, global_bindings_p ());
1043 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1044 with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
1045 if this represents a QUAL_UNION_TYPE in which case we must look for
1046 COND_EXPRs and replace a value of zero with the old size. If HAS_REP
1047 is nonzero, we must take the MAX of the end position of this field
1048 with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
1050 We return an expression for the size. */
1053 merge_sizes (tree last_size
, tree first_bit
, tree size
, bool special
,
1056 tree type
= TREE_TYPE (last_size
);
1059 if (! special
|| TREE_CODE (size
) != COND_EXPR
)
1061 new = size_binop (PLUS_EXPR
, first_bit
, size
);
1063 new = size_binop (MAX_EXPR
, last_size
, new);
1067 new = fold (build (COND_EXPR
, type
, TREE_OPERAND (size
, 0),
1068 integer_zerop (TREE_OPERAND (size
, 1))
1069 ? last_size
: merge_sizes (last_size
, first_bit
,
1070 TREE_OPERAND (size
, 1),
1072 integer_zerop (TREE_OPERAND (size
, 2))
1073 ? last_size
: merge_sizes (last_size
, first_bit
,
1074 TREE_OPERAND (size
, 2),
1077 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1078 when fed through substitute_in_expr) into thinking that a constant
1079 size is not constant. */
1080 while (TREE_CODE (new) == NON_LVALUE_EXPR
)
1081 new = TREE_OPERAND (new, 0);
1086 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1087 related by the addition of a constant. Return that constant if so. */
1090 compute_related_constant (tree op0
, tree op1
)
1092 tree op0_var
, op1_var
;
1093 tree op0_con
= split_plus (op0
, &op0_var
);
1094 tree op1_con
= split_plus (op1
, &op1_var
);
1095 tree result
= size_binop (MINUS_EXPR
, op0_con
, op1_con
);
1097 if (operand_equal_p (op0_var
, op1_var
, 0))
1099 else if (operand_equal_p (op0
, size_binop (PLUS_EXPR
, op1_var
, result
), 0))
1105 /* Utility function of above to split a tree OP which may be a sum, into a
1106 constant part, which is returned, and a variable part, which is stored
1107 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
1111 split_plus (tree in
, tree
*pvar
)
1113 /* Strip NOPS in order to ease the tree traversal and maximize the
1114 potential for constant or plus/minus discovery. We need to be careful
1115 to always return and set *pvar to bitsizetype trees, but it's worth
1119 *pvar
= convert (bitsizetype
, in
);
1121 if (TREE_CODE (in
) == INTEGER_CST
)
1123 *pvar
= bitsize_zero_node
;
1124 return convert (bitsizetype
, in
);
1126 else if (TREE_CODE (in
) == PLUS_EXPR
|| TREE_CODE (in
) == MINUS_EXPR
)
1128 tree lhs_var
, rhs_var
;
1129 tree lhs_con
= split_plus (TREE_OPERAND (in
, 0), &lhs_var
);
1130 tree rhs_con
= split_plus (TREE_OPERAND (in
, 1), &rhs_var
);
1132 if (lhs_var
== TREE_OPERAND (in
, 0)
1133 && rhs_var
== TREE_OPERAND (in
, 1))
1134 return bitsize_zero_node
;
1136 *pvar
= size_binop (TREE_CODE (in
), lhs_var
, rhs_var
);
1137 return size_binop (TREE_CODE (in
), lhs_con
, rhs_con
);
1140 return bitsize_zero_node
;
1143 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1144 subprogram. If it is void_type_node, then we are dealing with a procedure,
1145 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1146 PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
1147 copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1148 RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
1149 object. RETURNS_BY_REF is nonzero if the function returns by reference.
1150 RETURNS_WITH_DSP is nonzero if the function is to return with a
1151 depressed stack pointer. */
1153 create_subprog_type (tree return_type
, tree param_decl_list
, tree cico_list
,
1154 int returns_unconstrained
, int returns_by_ref
,
1155 int returns_with_dsp
)
1157 /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1158 the subprogram formal parameters. This list is generated by traversing the
1159 input list of PARM_DECL nodes. */
1160 tree param_type_list
= NULL
;
1164 for (param_decl
= param_decl_list
; param_decl
;
1165 param_decl
= TREE_CHAIN (param_decl
))
1166 param_type_list
= tree_cons (NULL_TREE
, TREE_TYPE (param_decl
),
1169 /* The list of the function parameter types has to be terminated by the void
1170 type to signal to the back-end that we are not dealing with a variable
1171 parameter subprogram, but that the subprogram has a fixed number of
1173 param_type_list
= tree_cons (NULL_TREE
, void_type_node
, param_type_list
);
1175 /* The list of argument types has been created in reverse
1177 param_type_list
= nreverse (param_type_list
);
1179 type
= build_function_type (return_type
, param_type_list
);
1181 /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
1182 or the new type should, make a copy of TYPE. Likewise for
1183 RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
1184 if (TYPE_CI_CO_LIST (type
) != 0 || cico_list
!= 0
1185 || TYPE_RETURNS_UNCONSTRAINED_P (type
) != returns_unconstrained
1186 || TYPE_RETURNS_BY_REF_P (type
) != returns_by_ref
)
1187 type
= copy_type (type
);
1189 SET_TYPE_CI_CO_LIST (type
, cico_list
);
1190 TYPE_RETURNS_UNCONSTRAINED_P (type
) = returns_unconstrained
;
1191 TYPE_RETURNS_STACK_DEPRESSED (type
) = returns_with_dsp
;
1192 TYPE_RETURNS_BY_REF_P (type
) = returns_by_ref
;
1196 /* Return a copy of TYPE but safe to modify in any way. */
1199 copy_type (tree type
)
1201 tree
new = copy_node (type
);
1203 /* copy_node clears this field instead of copying it, because it is
1204 aliased with TREE_CHAIN. */
1205 TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type
);
1207 TYPE_POINTER_TO (new) = 0;
1208 TYPE_REFERENCE_TO (new) = 0;
1209 TYPE_MAIN_VARIANT (new) = new;
1210 TYPE_NEXT_VARIANT (new) = 0;
1215 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1216 TYPE_INDEX_TYPE is INDEX. */
1219 create_index_type (tree min
, tree max
, tree index
)
1221 /* First build a type for the desired range. */
1222 tree type
= build_index_2_type (min
, max
);
1224 /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
1225 doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
1226 is set, but not to INDEX, make a copy of this type with the requested
1227 index type. Note that we have no way of sharing these types, but that's
1228 only a small hole. */
1229 if (TYPE_INDEX_TYPE (type
) == index
)
1231 else if (TYPE_INDEX_TYPE (type
) != 0)
1232 type
= copy_type (type
);
1234 SET_TYPE_INDEX_TYPE (type
, index
);
1235 create_type_decl (NULL_TREE
, type
, NULL
, 1, 0, Empty
);
1239 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1240 string) and TYPE is a ..._TYPE node giving its data type.
1241 ARTIFICIAL_P is nonzero if this is a declaration that was generated
1242 by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
1243 information about this type. GNAT_NODE is used for the position of
1247 create_type_decl (tree type_name
, tree type
, struct attrib
*attr_list
,
1248 int artificial_p
, int debug_info_p
, Node_Id gnat_node
)
1250 tree type_decl
= build_decl (TYPE_DECL
, type_name
, type
);
1251 enum tree_code code
= TREE_CODE (type
);
1253 DECL_ARTIFICIAL (type_decl
) = artificial_p
;
1255 process_attributes (type_decl
, attr_list
);
1257 /* Pass type declaration information to the debugger unless this is an
1258 UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1259 and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
1260 a dummy type, which will be completed later, or a type for which
1261 debugging information was not requested. */
1262 if (code
== UNCONSTRAINED_ARRAY_TYPE
|| TYPE_IS_DUMMY_P (type
)
1264 DECL_IGNORED_P (type_decl
) = 1;
1265 else if (code
!= ENUMERAL_TYPE
&& code
!= RECORD_TYPE
1266 && ! ((code
== POINTER_TYPE
|| code
== REFERENCE_TYPE
)
1267 && TYPE_IS_DUMMY_P (TREE_TYPE (type
))))
1268 rest_of_decl_compilation (type_decl
, NULL
, global_bindings_p (), 0);
1270 if (!TYPE_IS_DUMMY_P (type
))
1271 gnat_pushdecl (type_decl
, gnat_node
);
1276 /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable.
1277 ASM_NAME is its assembler name (if provided). TYPE is its data type
1278 (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial
1279 expression; NULL_TREE if none.
1281 CONST_FLAG is nonzero if this variable is constant.
1283 PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
1284 the current compilation unit. This flag should be set when processing the
1285 variable definitions in a package specification. EXTERN_FLAG is nonzero
1286 when processing an external variable declaration (as opposed to a
1287 definition: no storage is to be allocated for the variable here).
1289 STATIC_FLAG is only relevant when not at top level. In that case
1290 it indicates whether to always allocate storage to the variable.
1292 GNAT_NODE is used for the position of the decl. */
1295 create_var_decl (tree var_name
, tree asm_name
, tree type
, tree var_init
,
1296 int const_flag
, int public_flag
, int extern_flag
,
1297 int static_flag
, struct attrib
*attr_list
, Node_Id gnat_node
)
1302 : (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init
))
1303 && (global_bindings_p () || static_flag
1304 ? 0 != initializer_constant_valid_p (var_init
,
1305 TREE_TYPE (var_init
))
1306 : TREE_CONSTANT (var_init
))));
1308 = build_decl ((const_flag
&& init_const
1309 /* Only make a CONST_DECL for sufficiently-small objects.
1310 We consider complex double "sufficiently-small" */
1311 && TYPE_SIZE (type
) != 0
1312 && host_integerp (TYPE_SIZE_UNIT (type
), 1)
1313 && 0 >= compare_tree_int (TYPE_SIZE_UNIT (type
),
1314 GET_MODE_SIZE (DCmode
)))
1315 ? CONST_DECL
: VAR_DECL
, var_name
, type
);
1317 /* If this is external, throw away any initializations unless this is a
1318 CONST_DECL (meaning we have a constant); they will be done elsewhere.
1319 If we are defining a global here, leave a constant initialization and
1320 save any variable elaborations for the elaboration routine. If we are
1321 just annotating types, throw away the initialization if it isn't a
1323 if ((extern_flag
&& TREE_CODE (var_decl
) != CONST_DECL
)
1324 || (type_annotate_only
&& var_init
!= 0 && ! TREE_CONSTANT (var_init
)))
1327 DECL_INITIAL (var_decl
) = var_init
;
1328 TREE_READONLY (var_decl
) = const_flag
;
1329 DECL_EXTERNAL (var_decl
) = extern_flag
;
1330 TREE_PUBLIC (var_decl
) = public_flag
|| extern_flag
;
1331 TREE_CONSTANT (var_decl
) = TREE_CODE (var_decl
) == CONST_DECL
;
1332 TREE_THIS_VOLATILE (var_decl
) = TREE_SIDE_EFFECTS (var_decl
)
1333 = TYPE_VOLATILE (type
);
1335 /* At the global binding level we need to allocate static storage for the
1336 variable if and only if its not external. If we are not at the top level
1337 we allocate automatic storage unless requested not to. */
1338 TREE_STATIC (var_decl
) = global_bindings_p () ? !extern_flag
: static_flag
;
1341 SET_DECL_ASSEMBLER_NAME (var_decl
, asm_name
);
1343 process_attributes (var_decl
, attr_list
);
1345 /* Add this decl to the current binding level. */
1346 gnat_pushdecl (var_decl
, gnat_node
);
1348 if (TREE_SIDE_EFFECTS (var_decl
))
1349 TREE_ADDRESSABLE (var_decl
) = 1;
1351 if (TREE_CODE (var_decl
) != CONST_DECL
)
1352 rest_of_decl_compilation (var_decl
, 0, global_bindings_p (), 0);
1357 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1358 type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
1359 this field is in a record type with a "pragma pack". If SIZE is nonzero
1360 it is the specified size for this field. If POS is nonzero, it is the bit
1361 position. If ADDRESSABLE is nonzero, it means we are allowed to take
1362 the address of this field for aliasing purposes. */
1365 create_field_decl (tree field_name
, tree field_type
, tree record_type
,
1366 int packed
, tree size
, tree pos
, int addressable
)
1368 tree field_decl
= build_decl (FIELD_DECL
, field_name
, field_type
);
1370 DECL_CONTEXT (field_decl
) = record_type
;
1371 TREE_READONLY (field_decl
) = TYPE_READONLY (field_type
);
1373 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1374 byte boundary since GCC cannot handle less-aligned BLKmode bitfields. */
1375 if (packed
&& TYPE_MODE (field_type
) == BLKmode
)
1376 DECL_ALIGN (field_decl
) = BITS_PER_UNIT
;
1378 /* If a size is specified, use it. Otherwise, if the record type is packed
1379 compute a size to use, which may differ from the object's natural size.
1380 We always set a size in this case to trigger the checks for bitfield
1381 creation below, which is typically required when no position has been
1384 size
= convert (bitsizetype
, size
);
1385 else if (packed
== 1)
1387 size
= rm_size (field_type
);
1389 /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1391 if (TREE_CODE (size
) == INTEGER_CST
1392 && compare_tree_int (size
, MAX_FIXED_MODE_SIZE
) > 0)
1393 size
= round_up (size
, BITS_PER_UNIT
);
1396 /* Make a bitfield if a size is specified for two reasons: first if the size
1397 differs from the natural size. Second, if the alignment is insufficient.
1398 There are a number of ways the latter can be true.
1400 We never make a bitfield if the type of the field has a nonconstant size,
1401 or if it is claimed to be addressable, because no such entity requiring
1402 bitfield operations should reach here.
1404 We do *preventively* make a bitfield when there might be the need for it
1405 but we don't have all the necessary information to decide, as is the case
1406 of a field with no specified position in a packed record.
1408 We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1409 in layout_decl or finish_record_type to clear the bit_field indication if
1410 it is in fact not needed. */
1411 if (size
!= 0 && TREE_CODE (size
) == INTEGER_CST
1412 && TREE_CODE (TYPE_SIZE (field_type
)) == INTEGER_CST
1414 && (! operand_equal_p (TYPE_SIZE (field_type
), size
, 0)
1416 && ! value_zerop (size_binop (TRUNC_MOD_EXPR
, pos
,
1417 bitsize_int (TYPE_ALIGN
1420 || (TYPE_ALIGN (record_type
) != 0
1421 && TYPE_ALIGN (record_type
) < TYPE_ALIGN (field_type
))))
1423 DECL_BIT_FIELD (field_decl
) = 1;
1424 DECL_SIZE (field_decl
) = size
;
1425 if (! packed
&& pos
== 0)
1426 DECL_ALIGN (field_decl
)
1427 = (TYPE_ALIGN (record_type
) != 0
1428 ? MIN (TYPE_ALIGN (record_type
), TYPE_ALIGN (field_type
))
1429 : TYPE_ALIGN (field_type
));
1432 DECL_PACKED (field_decl
) = pos
!= 0 ? DECL_BIT_FIELD (field_decl
) : packed
;
1433 DECL_ALIGN (field_decl
)
1434 = MAX (DECL_ALIGN (field_decl
),
1435 DECL_BIT_FIELD (field_decl
) ? 1
1436 : packed
&& TYPE_MODE (field_type
) != BLKmode
? BITS_PER_UNIT
1437 : TYPE_ALIGN (field_type
));
1441 /* We need to pass in the alignment the DECL is known to have.
1442 This is the lowest-order bit set in POS, but no more than
1443 the alignment of the record, if one is specified. Note
1444 that an alignment of 0 is taken as infinite. */
1445 unsigned int known_align
;
1447 if (host_integerp (pos
, 1))
1448 known_align
= tree_low_cst (pos
, 1) & - tree_low_cst (pos
, 1);
1450 known_align
= BITS_PER_UNIT
;
1452 if (TYPE_ALIGN (record_type
)
1453 && (known_align
== 0 || known_align
> TYPE_ALIGN (record_type
)))
1454 known_align
= TYPE_ALIGN (record_type
);
1456 layout_decl (field_decl
, known_align
);
1457 SET_DECL_OFFSET_ALIGN (field_decl
,
1458 host_integerp (pos
, 1) ? BIGGEST_ALIGNMENT
1460 pos_from_bit (&DECL_FIELD_OFFSET (field_decl
),
1461 &DECL_FIELD_BIT_OFFSET (field_decl
),
1462 DECL_OFFSET_ALIGN (field_decl
), pos
);
1464 DECL_HAS_REP_P (field_decl
) = 1;
1467 /* If the field type is passed by reference, we will have pointers to the
1468 field, so it is addressable. */
1469 if (must_pass_by_ref (field_type
) || default_pass_by_ref (field_type
))
1472 /* ??? For now, we say that any field of aggregate type is addressable
1473 because the front end may take 'Reference of it. */
1474 if (AGGREGATE_TYPE_P (field_type
))
1477 /* Mark the decl as nonaddressable if it is indicated so semantically,
1478 meaning we won't ever attempt to take the address of the field.
1480 It may also be "technically" nonaddressable, meaning that even if we
1481 attempt to take the field's address we will actually get the address of a
1482 copy. This is the case for true bitfields, but the DECL_BIT_FIELD value
1483 we have at this point is not accurate enough, so we don't account for
1484 this here and let finish_record_type decide. */
1485 DECL_NONADDRESSABLE_P (field_decl
) = ! addressable
;
1490 /* Subroutine of previous function: return nonzero if EXP, ignoring any side
1491 effects, has the value of zero. */
1494 value_zerop (tree exp
)
1496 if (TREE_CODE (exp
) == COMPOUND_EXPR
)
1497 return value_zerop (TREE_OPERAND (exp
, 1));
1499 return integer_zerop (exp
);
1502 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1503 PARAM_TYPE is its type. READONLY is nonzero if the parameter is
1504 readonly (either an IN parameter or an address of a pass-by-ref
1508 create_param_decl (tree param_name
, tree param_type
, int readonly
)
1510 tree param_decl
= build_decl (PARM_DECL
, param_name
, param_type
);
1512 /* Honor targetm.calls.promote_prototypes(), as not doing so can
1513 lead to various ABI violations. */
1514 if (targetm
.calls
.promote_prototypes (param_type
)
1515 && (TREE_CODE (param_type
) == INTEGER_TYPE
1516 || TREE_CODE (param_type
) == ENUMERAL_TYPE
)
1517 && TYPE_PRECISION (param_type
) < TYPE_PRECISION (integer_type_node
))
1519 /* We have to be careful about biased types here. Make a subtype
1520 of integer_type_node with the proper biasing. */
1521 if (TREE_CODE (param_type
) == INTEGER_TYPE
1522 && TYPE_BIASED_REPRESENTATION_P (param_type
))
1525 = copy_type (build_range_type (integer_type_node
,
1526 TYPE_MIN_VALUE (param_type
),
1527 TYPE_MAX_VALUE (param_type
)));
1529 TYPE_BIASED_REPRESENTATION_P (param_type
) = 1;
1532 param_type
= integer_type_node
;
1535 DECL_ARG_TYPE (param_decl
) = param_type
;
1536 DECL_ARG_TYPE_AS_WRITTEN (param_decl
) = param_type
;
1537 TREE_READONLY (param_decl
) = readonly
;
1541 /* Given a DECL and ATTR_LIST, process the listed attributes. */
1544 process_attributes (tree decl
, struct attrib
*attr_list
)
1546 for (; attr_list
; attr_list
= attr_list
->next
)
1547 switch (attr_list
->type
)
1549 case ATTR_MACHINE_ATTRIBUTE
:
1550 decl_attributes (&decl
, tree_cons (attr_list
->name
, attr_list
->arg
,
1552 ATTR_FLAG_TYPE_IN_PLACE
);
1555 case ATTR_LINK_ALIAS
:
1556 TREE_STATIC (decl
) = 1;
1557 assemble_alias (decl
, attr_list
->name
);
1560 case ATTR_WEAK_EXTERNAL
:
1562 declare_weak (decl
);
1564 post_error ("?weak declarations not supported on this target",
1565 attr_list
->error_point
);
1568 case ATTR_LINK_SECTION
:
1569 if (targetm
.have_named_sections
)
1571 DECL_SECTION_NAME (decl
)
1572 = build_string (IDENTIFIER_LENGTH (attr_list
->name
),
1573 IDENTIFIER_POINTER (attr_list
->name
));
1576 post_error ("?section attributes are not supported for this target",
1577 attr_list
->error_point
);
1582 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1586 value_factor_p (tree value
, HOST_WIDE_INT factor
)
1588 if (host_integerp (value
, 1))
1589 return tree_low_cst (value
, 1) % factor
== 0;
1591 if (TREE_CODE (value
) == MULT_EXPR
)
1592 return (value_factor_p (TREE_OPERAND (value
, 0), factor
)
1593 || value_factor_p (TREE_OPERAND (value
, 1), factor
));
1598 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1599 unless we can prove these 2 fields are laid out in such a way that no gap
1600 exist between the end of PREV_FIELD and the begining of CURR_FIELD. OFFSET
1601 is the distance in bits between the end of PREV_FIELD and the starting
1602 position of CURR_FIELD. It is ignored if null. */
1605 potential_alignment_gap (tree prev_field
, tree curr_field
, tree offset
)
1607 /* If this is the first field of the record, there cannot be any gap */
1611 /* If the previous field is a union type, then return False: The only
1612 time when such a field is not the last field of the record is when
1613 there are other components at fixed positions after it (meaning there
1614 was a rep clause for every field), in which case we don't want the
1615 alignment constraint to override them. */
1616 if (TREE_CODE (TREE_TYPE (prev_field
)) == QUAL_UNION_TYPE
)
1619 /* If the distance between the end of prev_field and the begining of
1620 curr_field is constant, then there is a gap if the value of this
1621 constant is not null. */
1622 if (offset
&& host_integerp (offset
, 1))
1623 return (!integer_zerop (offset
));
1625 /* If the size and position of the previous field are constant,
1626 then check the sum of this size and position. There will be a gap
1627 iff it is not multiple of the current field alignment. */
1628 if (host_integerp (DECL_SIZE (prev_field
), 1)
1629 && host_integerp (bit_position (prev_field
), 1))
1630 return ((tree_low_cst (bit_position (prev_field
), 1)
1631 + tree_low_cst (DECL_SIZE (prev_field
), 1))
1632 % DECL_ALIGN (curr_field
) != 0);
1634 /* If both the position and size of the previous field are multiples
1635 of the current field alignment, there can not be any gap. */
1636 if (value_factor_p (bit_position (prev_field
), DECL_ALIGN (curr_field
))
1637 && value_factor_p (DECL_SIZE (prev_field
), DECL_ALIGN (curr_field
)))
1640 /* Fallback, return that there may be a potential gap */
1644 /* Returns a LABEL_DECL node for LABEL_NAME. */
1647 create_label_decl (tree label_name
)
1649 tree label_decl
= build_decl (LABEL_DECL
, label_name
, void_type_node
);
1651 DECL_CONTEXT (label_decl
) = current_function_decl
;
1652 DECL_MODE (label_decl
) = VOIDmode
;
1653 DECL_SOURCE_LOCATION (label_decl
) = input_location
;
1658 /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
1659 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1660 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1661 PARM_DECL nodes chained through the TREE_CHAIN field).
1663 INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1664 appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */
1667 create_subprog_decl (tree subprog_name
, tree asm_name
,
1668 tree subprog_type
, tree param_decl_list
, int inline_flag
,
1669 int public_flag
, int extern_flag
,
1670 struct attrib
*attr_list
, Node_Id gnat_node
)
1672 tree return_type
= TREE_TYPE (subprog_type
);
1673 tree subprog_decl
= build_decl (FUNCTION_DECL
, subprog_name
, subprog_type
);
1675 /* If this is a function nested inside an inlined external function, it
1676 means we aren't going to compile the outer function unless it is
1677 actually inlined, so do the same for us. */
1678 if (current_function_decl
!= 0 && DECL_INLINE (current_function_decl
)
1679 && DECL_EXTERNAL (current_function_decl
))
1682 DECL_EXTERNAL (subprog_decl
) = extern_flag
;
1683 TREE_PUBLIC (subprog_decl
) = public_flag
;
1684 TREE_STATIC (subprog_decl
) = 1;
1685 TREE_READONLY (subprog_decl
) = TYPE_READONLY (subprog_type
);
1686 TREE_THIS_VOLATILE (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1687 TREE_SIDE_EFFECTS (subprog_decl
) = TYPE_VOLATILE (subprog_type
);
1688 DECL_ARGUMENTS (subprog_decl
) = param_decl_list
;
1689 DECL_RESULT (subprog_decl
) = build_decl (RESULT_DECL
, 0, return_type
);
1690 DECL_ARTIFICIAL (DECL_RESULT (subprog_decl
)) = 1;
1691 DECL_IGNORED_P (DECL_RESULT (subprog_decl
)) = 1;
1694 DECL_DECLARED_INLINE_P (subprog_decl
) = 1;
1697 SET_DECL_ASSEMBLER_NAME (subprog_decl
, asm_name
);
1699 process_attributes (subprog_decl
, attr_list
);
1701 /* Add this decl to the current binding level. */
1702 gnat_pushdecl (subprog_decl
, gnat_node
);
1704 /* Output the assembler code and/or RTL for the declaration. */
1705 rest_of_decl_compilation (subprog_decl
, 0, global_bindings_p (), 0);
1707 return subprog_decl
;
1710 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1711 body. This routine needs to be invoked before processing the declarations
1712 appearing in the subprogram. */
1715 begin_subprog_body (tree subprog_decl
)
1719 current_function_decl
= subprog_decl
;
1720 announce_function (subprog_decl
);
1722 /* Enter a new binding level and show that all the parameters belong to
1725 for (param_decl
= DECL_ARGUMENTS (subprog_decl
); param_decl
;
1726 param_decl
= TREE_CHAIN (param_decl
))
1727 DECL_CONTEXT (param_decl
) = subprog_decl
;
1729 make_decl_rtl (subprog_decl
, NULL
);
1731 /* We handle pending sizes via the elaboration of types, so we don't need to
1732 save them. This causes them to be marked as part of the outer function
1733 and then discarded. */
1734 get_pending_sizes ();
1737 /* Finish the definition of the current subprogram and compile it all the way
1738 to assembler language output. BODY is the tree corresponding to
1742 end_subprog_body (tree body
)
1744 tree fndecl
= current_function_decl
;
1746 /* Mark the BLOCK for this level as being for this function and pop the
1747 level. Since the vars in it are the parameters, clear them. */
1748 BLOCK_VARS (current_binding_level
->block
) = 0;
1749 BLOCK_SUPERCONTEXT (current_binding_level
->block
) = fndecl
;
1750 DECL_INITIAL (fndecl
) = current_binding_level
->block
;
1753 /* Deal with inline. If declared inline or we should default to inline,
1754 set the flag in the decl. */
1755 DECL_INLINE (fndecl
)
1756 = DECL_DECLARED_INLINE_P (fndecl
) || flag_inline_trees
== 2;
1758 /* We handle pending sizes via the elaboration of types, so we don't
1759 need to save them. */
1760 get_pending_sizes ();
1762 /* Mark the RESULT_DECL as being in this subprogram. */
1763 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
1765 DECL_SAVED_TREE (fndecl
) = body
;
1767 current_function_decl
= DECL_CONTEXT (fndecl
);
1770 /* If we're only annotating types, don't actually compile this function. */
1771 if (type_annotate_only
)
1774 /* We do different things for nested and non-nested functions.
1775 ??? This should be in cgraph. */
1776 if (!DECL_CONTEXT (fndecl
))
1778 gnat_gimplify_function (fndecl
);
1779 lower_nested_functions (fndecl
);
1780 gnat_finalize (fndecl
);
1783 /* Register this function with cgraph just far enough to get it
1784 added to our parent's nested function list. */
1785 (void) cgraph_node (fndecl
);
1788 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1791 gnat_gimplify_function (tree fndecl
)
1793 struct cgraph_node
*cgn
;
1795 dump_function (TDI_original
, fndecl
);
1796 gimplify_function_tree (fndecl
);
1797 dump_function (TDI_generic
, fndecl
);
1799 /* Convert all nested functions to GIMPLE now. We do things in this order
1800 so that items like VLA sizes are expanded properly in the context of the
1801 correct function. */
1802 cgn
= cgraph_node (fndecl
);
1803 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1804 gnat_gimplify_function (cgn
->decl
);
1807 /* Give FNDECL and all its nested functions to cgraph for compilation. */
1810 gnat_finalize (tree fndecl
)
1812 struct cgraph_node
*cgn
;
1814 /* Finalize all nested functions now. */
1815 cgn
= cgraph_node (fndecl
);
1816 for (cgn
= cgn
->nested
; cgn
; cgn
= cgn
->next_nested
)
1817 gnat_finalize (cgn
->decl
);
1819 cgraph_finalize_function (fndecl
, false);
1822 /* Return a definition for a builtin function named NAME and whose data type
1823 is TYPE. TYPE should be a function type with argument types.
1824 FUNCTION_CODE tells later passes how to compile calls to this function.
1825 See tree.h for its possible values.
1827 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
1828 the name to be called if we can't opencode the function. If
1829 ATTRS is nonzero, use that for the function attribute list. */
1832 builtin_function (const char *name
, tree type
, int function_code
,
1833 enum built_in_class
class, const char *library_name
,
1836 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
1838 DECL_EXTERNAL (decl
) = 1;
1839 TREE_PUBLIC (decl
) = 1;
1841 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
1843 gnat_pushdecl (decl
, Empty
);
1844 DECL_BUILT_IN_CLASS (decl
) = class;
1845 DECL_FUNCTION_CODE (decl
) = function_code
;
1847 decl_attributes (&decl
, attrs
, ATTR_FLAG_BUILT_IN
);
1851 /* Return an integer type with the number of bits of precision given by
1852 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
1853 it is a signed type. */
1856 gnat_type_for_size (unsigned precision
, int unsignedp
)
1861 if (precision
<= 2 * MAX_BITS_PER_WORD
1862 && signed_and_unsigned_types
[precision
][unsignedp
] != 0)
1863 return signed_and_unsigned_types
[precision
][unsignedp
];
1866 t
= make_unsigned_type (precision
);
1868 t
= make_signed_type (precision
);
1870 if (precision
<= 2 * MAX_BITS_PER_WORD
)
1871 signed_and_unsigned_types
[precision
][unsignedp
] = t
;
1873 if (TYPE_NAME (t
) == 0)
1875 sprintf (type_name
, "%sSIGNED_%d", unsignedp
? "UN" : "", precision
);
1876 TYPE_NAME (t
) = get_identifier (type_name
);
1882 /* Likewise for floating-point types. */
1885 float_type_for_precision (int precision
, enum machine_mode mode
)
1890 if (float_types
[(int) mode
] != 0)
1891 return float_types
[(int) mode
];
1893 float_types
[(int) mode
] = t
= make_node (REAL_TYPE
);
1894 TYPE_PRECISION (t
) = precision
;
1897 if (TYPE_MODE (t
) != mode
)
1900 if (TYPE_NAME (t
) == 0)
1902 sprintf (type_name
, "FLOAT_%d", precision
);
1903 TYPE_NAME (t
) = get_identifier (type_name
);
1909 /* Return a data type that has machine mode MODE. UNSIGNEDP selects
1910 an unsigned type; otherwise a signed type is returned. */
1913 gnat_type_for_mode (enum machine_mode mode
, int unsignedp
)
1915 if (mode
== BLKmode
)
1917 else if (mode
== VOIDmode
)
1918 return void_type_node
;
1919 else if (GET_MODE_CLASS (mode
) == MODE_FLOAT
)
1920 return float_type_for_precision (GET_MODE_PRECISION (mode
), mode
);
1922 return gnat_type_for_size (GET_MODE_BITSIZE (mode
), unsignedp
);
1925 /* Return the unsigned version of a TYPE_NODE, a scalar type. */
1928 gnat_unsigned_type (tree type_node
)
1930 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 1);
1932 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
1934 type
= copy_node (type
);
1935 TREE_TYPE (type
) = type_node
;
1937 else if (TREE_TYPE (type_node
) != 0
1938 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
1939 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
1941 type
= copy_node (type
);
1942 TREE_TYPE (type
) = TREE_TYPE (type_node
);
1948 /* Return the signed version of a TYPE_NODE, a scalar type. */
1951 gnat_signed_type (tree type_node
)
1953 tree type
= gnat_type_for_size (TYPE_PRECISION (type_node
), 0);
1955 if (TREE_CODE (type_node
) == INTEGER_TYPE
&& TYPE_MODULAR_P (type_node
))
1957 type
= copy_node (type
);
1958 TREE_TYPE (type
) = type_node
;
1960 else if (TREE_TYPE (type_node
) != 0
1961 && TREE_CODE (TREE_TYPE (type_node
)) == INTEGER_TYPE
1962 && TYPE_MODULAR_P (TREE_TYPE (type_node
)))
1964 type
= copy_node (type
);
1965 TREE_TYPE (type
) = TREE_TYPE (type_node
);
1971 /* Return a type the same as TYPE except unsigned or signed according to
1975 gnat_signed_or_unsigned_type (int unsignedp
, tree type
)
1977 if (! INTEGRAL_TYPE_P (type
) || TYPE_UNSIGNED (type
) == unsignedp
)
1980 return gnat_type_for_size (TYPE_PRECISION (type
), unsignedp
);
1983 /* EXP is an expression for the size of an object. If this size contains
1984 discriminant references, replace them with the maximum (if MAX_P) or
1985 minimum (if ! MAX_P) possible value of the discriminant. */
1988 max_size (tree exp
, int max_p
)
1990 enum tree_code code
= TREE_CODE (exp
);
1991 tree type
= TREE_TYPE (exp
);
1993 switch (TREE_CODE_CLASS (code
))
2000 if (code
== TREE_LIST
)
2001 return tree_cons (TREE_PURPOSE (exp
),
2002 max_size (TREE_VALUE (exp
), max_p
),
2003 TREE_CHAIN (exp
) != 0
2004 ? max_size (TREE_CHAIN (exp
), max_p
) : 0);
2008 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2009 modify. Otherwise, we treat it like a variable. */
2010 if (! CONTAINS_PLACEHOLDER_P (exp
))
2013 type
= TREE_TYPE (TREE_OPERAND (exp
, 1));
2015 max_size (max_p
? TYPE_MAX_VALUE (type
) : TYPE_MIN_VALUE (type
), 1);
2018 return max_p
? size_one_node
: size_zero_node
;
2023 switch (TREE_CODE_LENGTH (code
))
2026 if (code
== NON_LVALUE_EXPR
)
2027 return max_size (TREE_OPERAND (exp
, 0), max_p
);
2030 fold (build1 (code
, type
,
2031 max_size (TREE_OPERAND (exp
, 0),
2032 code
== NEGATE_EXPR
? ! max_p
: max_p
)));
2035 if (code
== COMPOUND_EXPR
)
2036 return max_size (TREE_OPERAND (exp
, 1), max_p
);
2039 tree lhs
= max_size (TREE_OPERAND (exp
, 0), max_p
);
2040 tree rhs
= max_size (TREE_OPERAND (exp
, 1),
2041 code
== MINUS_EXPR
? ! max_p
: max_p
);
2043 /* Special-case wanting the maximum value of a MIN_EXPR.
2044 In that case, if one side overflows, return the other.
2045 sizetype is signed, but we know sizes are non-negative.
2046 Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2047 overflowing or the maximum possible value and the RHS
2049 if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (rhs
))
2051 else if (max_p
&& code
== MIN_EXPR
&& TREE_OVERFLOW (lhs
))
2053 else if ((code
== MINUS_EXPR
|| code
== PLUS_EXPR
)
2054 && ((TREE_CONSTANT (lhs
) && TREE_OVERFLOW (lhs
))
2055 || operand_equal_p (lhs
, TYPE_MAX_VALUE (type
), 0))
2056 && ! TREE_CONSTANT (rhs
))
2059 return fold (build (code
, type
, lhs
, rhs
));
2063 if (code
== SAVE_EXPR
)
2065 else if (code
== COND_EXPR
)
2066 return fold (build (max_p
? MAX_EXPR
: MIN_EXPR
, type
,
2067 max_size (TREE_OPERAND (exp
, 1), max_p
),
2068 max_size (TREE_OPERAND (exp
, 2), max_p
)));
2069 else if (code
== CALL_EXPR
&& TREE_OPERAND (exp
, 1) != 0)
2070 return build (CALL_EXPR
, type
, TREE_OPERAND (exp
, 0),
2071 max_size (TREE_OPERAND (exp
, 1), max_p
), NULL
);
2078 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2079 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2080 Return a constructor for the template. */
2083 build_template (tree template_type
, tree array_type
, tree expr
)
2085 tree template_elts
= NULL_TREE
;
2086 tree bound_list
= NULL_TREE
;
2089 if (TREE_CODE (array_type
) == RECORD_TYPE
2090 && (TYPE_IS_PADDING_P (array_type
)
2091 || TYPE_LEFT_JUSTIFIED_MODULAR_P (array_type
)))
2092 array_type
= TREE_TYPE (TYPE_FIELDS (array_type
));
2094 if (TREE_CODE (array_type
) == ARRAY_TYPE
2095 || (TREE_CODE (array_type
) == INTEGER_TYPE
2096 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type
)))
2097 bound_list
= TYPE_ACTUAL_BOUNDS (array_type
);
2099 /* First make the list for a CONSTRUCTOR for the template. Go down the
2100 field list of the template instead of the type chain because this
2101 array might be an Ada array of arrays and we can't tell where the
2102 nested arrays stop being the underlying object. */
2104 for (field
= TYPE_FIELDS (template_type
); field
;
2106 ? (bound_list
= TREE_CHAIN (bound_list
))
2107 : (array_type
= TREE_TYPE (array_type
))),
2108 field
= TREE_CHAIN (TREE_CHAIN (field
)))
2110 tree bounds
, min
, max
;
2112 /* If we have a bound list, get the bounds from there. Likewise
2113 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
2114 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2115 This will give us a maximum range. */
2116 if (bound_list
!= 0)
2117 bounds
= TREE_VALUE (bound_list
);
2118 else if (TREE_CODE (array_type
) == ARRAY_TYPE
)
2119 bounds
= TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type
));
2120 else if (expr
!= 0 && TREE_CODE (expr
) == PARM_DECL
2121 && DECL_BY_COMPONENT_PTR_P (expr
))
2122 bounds
= TREE_TYPE (field
);
2126 min
= convert (TREE_TYPE (TREE_CHAIN (field
)), TYPE_MIN_VALUE (bounds
));
2127 max
= convert (TREE_TYPE (field
), TYPE_MAX_VALUE (bounds
));
2129 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2130 substitute it from OBJECT. */
2131 min
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (min
, expr
);
2132 max
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (max
, expr
);
2134 template_elts
= tree_cons (TREE_CHAIN (field
), max
,
2135 tree_cons (field
, min
, template_elts
));
2138 return gnat_build_constructor (template_type
, nreverse (template_elts
));
2141 /* Build a VMS descriptor from a Mechanism_Type, which must specify
2142 a descriptor type, and the GCC type of an object. Each FIELD_DECL
2143 in the type contains in its DECL_INITIAL the expression to use when
2144 a constructor is made for the type. GNAT_ENTITY is an entity used
2145 to print out an error message if the mechanism cannot be applied to
2146 an object of that type and also for the name. */
2149 build_vms_descriptor (tree type
, Mechanism_Type mech
, Entity_Id gnat_entity
)
2151 tree record_type
= make_node (RECORD_TYPE
);
2152 tree field_list
= 0;
2161 /* If TYPE is an unconstrained array, use the underlying array type. */
2162 if (TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
2163 type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type
))));
2165 /* If this is an array, compute the number of dimensions in the array,
2166 get the index types, and point to the inner type. */
2167 if (TREE_CODE (type
) != ARRAY_TYPE
)
2170 for (ndim
= 1, inner_type
= type
;
2171 TREE_CODE (TREE_TYPE (inner_type
)) == ARRAY_TYPE
2172 && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type
));
2173 ndim
++, inner_type
= TREE_TYPE (inner_type
))
2176 idx_arr
= (tree
*) alloca (ndim
* sizeof (tree
));
2178 if (mech
!= By_Descriptor_NCA
2179 && TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type
))
2180 for (i
= ndim
- 1, inner_type
= type
;
2182 i
--, inner_type
= TREE_TYPE (inner_type
))
2183 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2185 for (i
= 0, inner_type
= type
;
2187 i
++, inner_type
= TREE_TYPE (inner_type
))
2188 idx_arr
[i
] = TYPE_DOMAIN (inner_type
);
2190 /* Now get the DTYPE value. */
2191 switch (TREE_CODE (type
))
2195 if (TYPE_VAX_FLOATING_POINT_P (type
))
2196 switch (tree_low_cst (TYPE_DIGITS_VALUE (type
), 1))
2209 switch (GET_MODE_BITSIZE (TYPE_MODE (type
)))
2212 dtype
= TYPE_UNSIGNED (type
) ? 2 : 6;
2215 dtype
= TYPE_UNSIGNED (type
) ? 3 : 7;
2218 dtype
= TYPE_UNSIGNED (type
) ? 4 : 8;
2221 dtype
= TYPE_UNSIGNED (type
) ? 5 : 9;
2224 dtype
= TYPE_UNSIGNED (type
) ? 25 : 26;
2230 dtype
= GET_MODE_BITSIZE (TYPE_MODE (type
)) == 32 ? 52 : 53;
2234 if (TREE_CODE (TREE_TYPE (type
)) == INTEGER_TYPE
2235 && TYPE_VAX_FLOATING_POINT_P (type
))
2236 switch (tree_low_cst (TYPE_DIGITS_VALUE (type
), 1))
2248 dtype
= GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type
))) == 32 ? 54: 55;
2259 /* Get the CLASS value. */
2262 case By_Descriptor_A
:
2265 case By_Descriptor_NCA
:
2268 case By_Descriptor_SB
:
2275 /* Make the type for a descriptor for VMS. The first four fields
2276 are the same for all types. */
2279 = chainon (field_list
,
2280 make_descriptor_field
2281 ("LENGTH", gnat_type_for_size (16, 1), record_type
,
2282 size_in_bytes (mech
== By_Descriptor_A
? inner_type
: type
)));
2284 field_list
= chainon (field_list
,
2285 make_descriptor_field ("DTYPE",
2286 gnat_type_for_size (8, 1),
2287 record_type
, size_int (dtype
)));
2288 field_list
= chainon (field_list
,
2289 make_descriptor_field ("CLASS",
2290 gnat_type_for_size (8, 1),
2291 record_type
, size_int (class)));
2294 = chainon (field_list
,
2295 make_descriptor_field
2297 build_pointer_type_for_mode (type
, SImode
, false), record_type
,
2299 build_pointer_type_for_mode (type
, SImode
, false),
2300 build (PLACEHOLDER_EXPR
, type
))));
2305 case By_Descriptor_S
:
2308 case By_Descriptor_SB
:
2310 = chainon (field_list
,
2311 make_descriptor_field
2312 ("SB_L1", gnat_type_for_size (32, 1), record_type
,
2313 TREE_CODE (type
) == ARRAY_TYPE
2314 ? TYPE_MIN_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2316 = chainon (field_list
,
2317 make_descriptor_field
2318 ("SB_L2", gnat_type_for_size (32, 1), record_type
,
2319 TREE_CODE (type
) == ARRAY_TYPE
2320 ? TYPE_MAX_VALUE (TYPE_DOMAIN (type
)) : size_zero_node
));
2323 case By_Descriptor_A
:
2324 case By_Descriptor_NCA
:
2325 field_list
= chainon (field_list
,
2326 make_descriptor_field ("SCALE",
2327 gnat_type_for_size (8, 1),
2331 field_list
= chainon (field_list
,
2332 make_descriptor_field ("DIGITS",
2333 gnat_type_for_size (8, 1),
2338 = chainon (field_list
,
2339 make_descriptor_field
2340 ("AFLAGS", gnat_type_for_size (8, 1), record_type
,
2341 size_int (mech
== By_Descriptor_NCA
2343 /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
2344 : (TREE_CODE (type
) == ARRAY_TYPE
2345 && TYPE_CONVENTION_FORTRAN_P (type
)
2348 field_list
= chainon (field_list
,
2349 make_descriptor_field ("DIMCT",
2350 gnat_type_for_size (8, 1),
2354 field_list
= chainon (field_list
,
2355 make_descriptor_field ("ARSIZE",
2356 gnat_type_for_size (32, 1),
2358 size_in_bytes (type
)));
2360 /* Now build a pointer to the 0,0,0... element. */
2361 tem
= build (PLACEHOLDER_EXPR
, type
);
2362 for (i
= 0, inner_type
= type
; i
< ndim
;
2363 i
++, inner_type
= TREE_TYPE (inner_type
))
2364 tem
= build (ARRAY_REF
, TREE_TYPE (inner_type
), tem
,
2365 convert (TYPE_DOMAIN (inner_type
), size_zero_node
),
2366 NULL_TREE
, NULL_TREE
);
2369 = chainon (field_list
,
2370 make_descriptor_field
2372 build_pointer_type_for_mode (inner_type
, SImode
, false),
2375 build_pointer_type_for_mode (inner_type
, SImode
,
2379 /* Next come the addressing coefficients. */
2381 for (i
= 0; i
< ndim
; i
++)
2385 = size_binop (MULT_EXPR
, tem
,
2386 size_binop (PLUS_EXPR
,
2387 size_binop (MINUS_EXPR
,
2388 TYPE_MAX_VALUE (idx_arr
[i
]),
2389 TYPE_MIN_VALUE (idx_arr
[i
])),
2392 fname
[0] = (mech
== By_Descriptor_NCA
? 'S' : 'M');
2393 fname
[1] = '0' + i
, fname
[2] = 0;
2395 = chainon (field_list
,
2396 make_descriptor_field (fname
,
2397 gnat_type_for_size (32, 1),
2398 record_type
, idx_length
));
2400 if (mech
== By_Descriptor_NCA
)
2404 /* Finally here are the bounds. */
2405 for (i
= 0; i
< ndim
; i
++)
2409 fname
[0] = 'L', fname
[1] = '0' + i
, fname
[2] = 0;
2411 = chainon (field_list
,
2412 make_descriptor_field
2413 (fname
, gnat_type_for_size (32, 1), record_type
,
2414 TYPE_MIN_VALUE (idx_arr
[i
])));
2418 = chainon (field_list
,
2419 make_descriptor_field
2420 (fname
, gnat_type_for_size (32, 1), record_type
,
2421 TYPE_MAX_VALUE (idx_arr
[i
])));
2426 post_error ("unsupported descriptor type for &", gnat_entity
);
2429 finish_record_type (record_type
, field_list
, 0, 1);
2430 create_type_decl (create_concat_name (gnat_entity
, "DESC"), record_type
,
2431 NULL
, 1, 0, gnat_entity
);
2436 /* Utility routine for above code to make a field. */
2439 make_descriptor_field (const char *name
, tree type
,
2440 tree rec_type
, tree initial
)
2443 = create_field_decl (get_identifier (name
), type
, rec_type
, 0, 0, 0, 0);
2445 DECL_INITIAL (field
) = initial
;
2449 /* Build a type to be used to represent an aliased object whose nominal
2450 type is an unconstrained array. This consists of a RECORD_TYPE containing
2451 a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
2452 ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
2453 is used to represent an arbitrary unconstrained object. Use NAME
2454 as the name of the record. */
2457 build_unc_object_type (tree template_type
, tree object_type
, tree name
)
2459 tree type
= make_node (RECORD_TYPE
);
2460 tree template_field
= create_field_decl (get_identifier ("BOUNDS"),
2461 template_type
, type
, 0, 0, 0, 1);
2462 tree array_field
= create_field_decl (get_identifier ("ARRAY"), object_type
,
2465 TYPE_NAME (type
) = name
;
2466 TYPE_CONTAINS_TEMPLATE_P (type
) = 1;
2467 finish_record_type (type
,
2468 chainon (chainon (NULL_TREE
, template_field
),
2475 /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
2476 the normal case this is just two adjustments, but we have more to do
2477 if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
2480 update_pointer_to (tree old_type
, tree new_type
)
2482 tree ptr
= TYPE_POINTER_TO (old_type
);
2483 tree ref
= TYPE_REFERENCE_TO (old_type
);
2487 /* If this is the main variant, process all the other variants first. */
2488 if (TYPE_MAIN_VARIANT (old_type
) == old_type
)
2489 for (type
= TYPE_NEXT_VARIANT (old_type
); type
!= 0;
2490 type
= TYPE_NEXT_VARIANT (type
))
2491 update_pointer_to (type
, new_type
);
2493 /* If no pointer or reference, we are done. */
2494 if (ptr
== 0 && ref
== 0)
2497 /* Merge the old type qualifiers in the new type.
2499 Each old variant has qualifiers for specific reasons, and the new
2500 designated type as well. Each set of qualifiers represents useful
2501 information grabbed at some point, and merging the two simply unifies
2502 these inputs into the final type description.
2504 Consider for instance a volatile type frozen after an access to constant
2505 type designating it. After the designated type freeze, we get here with a
2506 volatile new_type and a dummy old_type with a readonly variant, created
2507 when the access type was processed. We shall make a volatile and readonly
2508 designated type, because that's what it really is.
2510 We might also get here for a non-dummy old_type variant with different
2511 qualifiers than the new_type ones, for instance in some cases of pointers
2512 to private record type elaboration (see the comments around the call to
2513 this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
2514 qualifiers in thoses cases too, to avoid accidentally discarding the
2515 initial set, and will often end up with old_type == new_type then. */
2516 new_type
= build_qualified_type (new_type
,
2517 TYPE_QUALS (old_type
)
2518 | TYPE_QUALS (new_type
));
2520 /* If the new type and the old one are identical, there is nothing to
2522 if (old_type
== new_type
)
2525 /* Otherwise, first handle the simple case. */
2526 if (TREE_CODE (new_type
) != UNCONSTRAINED_ARRAY_TYPE
)
2528 TYPE_POINTER_TO (new_type
) = ptr
;
2529 TYPE_REFERENCE_TO (new_type
) = ref
;
2531 for (; ptr
; ptr
= TYPE_NEXT_PTR_TO (ptr
))
2532 for (ptr1
= TYPE_MAIN_VARIANT (ptr
); ptr1
;
2533 ptr1
= TYPE_NEXT_VARIANT (ptr1
))
2535 TREE_TYPE (ptr1
) = new_type
;
2537 if (TYPE_NAME (ptr1
) != 0
2538 && TREE_CODE (TYPE_NAME (ptr1
)) == TYPE_DECL
2539 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2540 rest_of_decl_compilation (TYPE_NAME (ptr1
), NULL
,
2541 global_bindings_p (), 0);
2544 for (; ref
; ref
= TYPE_NEXT_PTR_TO (ref
))
2545 for (ref1
= TYPE_MAIN_VARIANT (ref
); ref1
;
2546 ref1
= TYPE_NEXT_VARIANT (ref1
))
2548 TREE_TYPE (ref1
) = new_type
;
2550 if (TYPE_NAME (ref1
) != 0
2551 && TREE_CODE (TYPE_NAME (ref1
)) == TYPE_DECL
2552 && TREE_CODE (new_type
) != ENUMERAL_TYPE
)
2553 rest_of_decl_compilation (TYPE_NAME (ref1
), NULL
,
2554 global_bindings_p (), 0);
2558 /* Now deal with the unconstrained array case. In this case the "pointer"
2559 is actually a RECORD_TYPE where the types of both fields are
2560 pointers to void. In that case, copy the field list from the
2561 old type to the new one and update the fields' context. */
2562 else if (TREE_CODE (ptr
) != RECORD_TYPE
|| ! TYPE_IS_FAT_POINTER_P (ptr
))
2567 tree new_obj_rec
= TYPE_OBJECT_RECORD_TYPE (new_type
);
2572 TYPE_FIELDS (ptr
) = TYPE_FIELDS (TYPE_POINTER_TO (new_type
));
2573 DECL_CONTEXT (TYPE_FIELDS (ptr
)) = ptr
;
2574 DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr
))) = ptr
;
2576 /* Rework the PLACEHOLDER_EXPR inside the reference to the
2579 ??? This is now the only use of gnat_substitute_in_type, which
2580 is now a very "heavy" routine to do this, so it should be replaced
2582 ptr_temp_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr
)));
2583 new_ref
= build (COMPONENT_REF
, ptr_temp_type
,
2584 build (PLACEHOLDER_EXPR
, ptr
),
2585 TREE_CHAIN (TYPE_FIELDS (ptr
)), NULL_TREE
);
2588 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2589 gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))),
2590 TREE_CHAIN (TYPE_FIELDS (ptr
)), new_ref
));
2592 for (var
= TYPE_MAIN_VARIANT (ptr
); var
; var
= TYPE_NEXT_VARIANT (var
))
2593 SET_TYPE_UNCONSTRAINED_ARRAY (var
, new_type
);
2595 TYPE_POINTER_TO (new_type
) = TYPE_REFERENCE_TO (new_type
)
2596 = TREE_TYPE (new_type
) = ptr
;
2598 /* Now handle updating the allocation record, what the thin pointer
2599 points to. Update all pointers from the old record into the new
2600 one, update the types of the fields, and recompute the size. */
2602 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type
), new_obj_rec
);
2604 TREE_TYPE (TYPE_FIELDS (new_obj_rec
)) = TREE_TYPE (ptr_temp_type
);
2605 TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2606 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
)));
2607 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2608 = TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2609 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
)))
2610 = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr
))));
2612 TYPE_SIZE (new_obj_rec
)
2613 = size_binop (PLUS_EXPR
,
2614 DECL_SIZE (TYPE_FIELDS (new_obj_rec
)),
2615 DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2616 TYPE_SIZE_UNIT (new_obj_rec
)
2617 = size_binop (PLUS_EXPR
,
2618 DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec
)),
2619 DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec
))));
2620 rest_of_type_compilation (ptr
, global_bindings_p ());
2624 /* Convert a pointer to a constrained array into a pointer to a fat
2625 pointer. This involves making or finding a template. */
2628 convert_to_fat_pointer (tree type
, tree expr
)
2630 tree template_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
))));
2631 tree
template, template_addr
;
2632 tree etype
= TREE_TYPE (expr
);
2634 /* If EXPR is a constant of zero, we make a fat pointer that has a null
2635 pointer to the template and array. */
2636 if (integer_zerop (expr
))
2638 gnat_build_constructor
2640 tree_cons (TYPE_FIELDS (type
),
2641 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2642 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2643 convert (build_pointer_type (template_type
),
2647 /* If EXPR is a thin pointer, make the template and data from the record. */
2649 else if (TYPE_THIN_POINTER_P (etype
))
2651 tree fields
= TYPE_FIELDS (TREE_TYPE (etype
));
2653 expr
= save_expr (expr
);
2654 if (TREE_CODE (expr
) == ADDR_EXPR
)
2655 expr
= TREE_OPERAND (expr
, 0);
2657 expr
= build1 (INDIRECT_REF
, TREE_TYPE (etype
), expr
);
2659 template = build_component_ref (expr
, NULL_TREE
, fields
, 0);
2660 expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
2661 build_component_ref (expr
, NULL_TREE
,
2662 TREE_CHAIN (fields
), 0));
2665 /* Otherwise, build the constructor for the template. */
2666 template = build_template (template_type
, TREE_TYPE (etype
), expr
);
2668 template_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, template);
2670 /* The result is a CONSTRUCTOR for the fat pointer.
2672 If expr is an argument of a foreign convention subprogram, the type it
2673 points to is directly the component type. In this case, the expression
2674 type may not match the corresponding FIELD_DECL type at this point, so we
2675 call "convert" here to fix that up if necessary. This type consistency is
2676 required, for instance because it ensures that possible later folding of
2677 component_refs against this constructor always yields something of the
2678 same type as the initial reference.
2680 Note that the call to "build_template" above is still fine, because it
2681 will only refer to the provided template_type in this case. */
2683 gnat_build_constructor
2684 (type
, tree_cons (TYPE_FIELDS (type
),
2685 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2686 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2687 template_addr
, NULL_TREE
)));
2690 /* Convert to a thin pointer type, TYPE. The only thing we know how to convert
2691 is something that is a fat pointer, so convert to it first if it EXPR
2692 is not already a fat pointer. */
2695 convert_to_thin_pointer (tree type
, tree expr
)
2697 if (! TYPE_FAT_POINTER_P (TREE_TYPE (expr
)))
2699 = convert_to_fat_pointer
2700 (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
))), expr
);
2702 /* We get the pointer to the data and use a NOP_EXPR to make it the
2705 = build_component_ref (expr
, NULL_TREE
, TYPE_FIELDS (TREE_TYPE (expr
)), 0);
2706 expr
= build1 (NOP_EXPR
, type
, expr
);
2711 /* Create an expression whose value is that of EXPR,
2712 converted to type TYPE. The TREE_TYPE of the value
2713 is always TYPE. This function implements all reasonable
2714 conversions; callers should filter out those that are
2715 not permitted by the language being compiled. */
2718 convert (tree type
, tree expr
)
2720 enum tree_code code
= TREE_CODE (type
);
2721 tree etype
= TREE_TYPE (expr
);
2722 enum tree_code ecode
= TREE_CODE (etype
);
2725 /* If EXPR is already the right type, we are done. */
2729 /* If the input type has padding, remove it by doing a component reference
2730 to the field. If the output type has padding, make a constructor
2731 to build the record. If both input and output have padding and are
2732 of variable size, do this as an unchecked conversion. */
2733 else if (ecode
== RECORD_TYPE
&& code
== RECORD_TYPE
2734 && TYPE_IS_PADDING_P (type
) && TYPE_IS_PADDING_P (etype
)
2735 && (! TREE_CONSTANT (TYPE_SIZE (type
))
2736 || ! TREE_CONSTANT (TYPE_SIZE (etype
))))
2738 else if (ecode
== RECORD_TYPE
&& TYPE_IS_PADDING_P (etype
))
2740 /* If we have just converted to this padded type, just get
2741 the inner expression. */
2742 if (TREE_CODE (expr
) == CONSTRUCTOR
2743 && CONSTRUCTOR_ELTS (expr
) != 0
2744 && TREE_PURPOSE (CONSTRUCTOR_ELTS (expr
)) == TYPE_FIELDS (etype
))
2745 return TREE_VALUE (CONSTRUCTOR_ELTS (expr
));
2747 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2748 TYPE_FIELDS (etype
), 0));
2750 else if (code
== RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
2752 /* If we previously converted from another type and our type is
2753 of variable size, remove the conversion to avoid the need for
2754 variable-size temporaries. */
2755 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
2756 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2757 expr
= TREE_OPERAND (expr
, 0);
2759 /* If we are just removing the padding from expr, convert the original
2760 object if we have variable size. That will avoid the need
2761 for some variable-size temporaries. */
2762 if (TREE_CODE (expr
) == COMPONENT_REF
2763 && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == RECORD_TYPE
2764 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr
, 0)))
2765 && ! TREE_CONSTANT (TYPE_SIZE (type
)))
2766 return convert (type
, TREE_OPERAND (expr
, 0));
2768 /* If the result type is a padded type with a self-referentially-sized
2769 field and the expression type is a record, do this as an
2770 unchecked converstion. */
2771 else if (TREE_CODE (etype
) == RECORD_TYPE
2772 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type
))))
2773 return unchecked_convert (type
, expr
, 0);
2777 gnat_build_constructor (type
,
2778 tree_cons (TYPE_FIELDS (type
),
2780 (TYPE_FIELDS (type
)),
2785 /* If the input is a biased type, adjust first. */
2786 if (ecode
== INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype
))
2787 return convert (type
, fold (build (PLUS_EXPR
, TREE_TYPE (etype
),
2788 fold (build1 (NOP_EXPR
,
2789 TREE_TYPE (etype
), expr
)),
2790 TYPE_MIN_VALUE (etype
))));
2792 /* If the input is a left-justified modular type, we need to extract
2793 the actual object before converting it to any other type with the
2794 exception of an unconstrained array. */
2795 if (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)
2796 && code
!= UNCONSTRAINED_ARRAY_TYPE
)
2797 return convert (type
, build_component_ref (expr
, NULL_TREE
,
2798 TYPE_FIELDS (etype
), 0));
2800 /* If converting to a type that contains a template, convert to the data
2801 type and then build the template. */
2802 if (code
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (type
))
2804 tree obj_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type
)));
2806 /* If the source already has a template, get a reference to the
2807 associated array only, as we are going to rebuild a template
2808 for the target type anyway. */
2809 expr
= maybe_unconstrained_array (expr
);
2812 gnat_build_constructor
2814 tree_cons (TYPE_FIELDS (type
),
2815 build_template (TREE_TYPE (TYPE_FIELDS (type
)),
2816 obj_type
, NULL_TREE
),
2817 tree_cons (TREE_CHAIN (TYPE_FIELDS (type
)),
2818 convert (obj_type
, expr
), NULL_TREE
)));
2821 /* There are some special cases of expressions that we process
2823 switch (TREE_CODE (expr
))
2829 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
2830 conversion in gnat_expand_expr. NULL_EXPR does not represent
2831 and actual value, so no conversion is needed. */
2832 expr
= copy_node (expr
);
2833 TREE_TYPE (expr
) = type
;
2837 /* If we are converting a STRING_CST to another constrained array type,
2838 just make a new one in the proper type. */
2839 if (code
== ecode
&& AGGREGATE_TYPE_P (etype
)
2840 && ! (TREE_CODE (TYPE_SIZE (etype
)) == INTEGER_CST
2841 && TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2842 && (TREE_CODE (expr
) == STRING_CST
2843 || get_alias_set (etype
) == get_alias_set (type
)))
2845 expr
= copy_node (expr
);
2846 TREE_TYPE (expr
) = type
;
2851 case UNCONSTRAINED_ARRAY_REF
:
2852 /* Convert this to the type of the inner array by getting the address of
2853 the array from the template. */
2854 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2855 build_component_ref (TREE_OPERAND (expr
, 0),
2856 get_identifier ("P_ARRAY"),
2858 etype
= TREE_TYPE (expr
);
2859 ecode
= TREE_CODE (etype
);
2862 case VIEW_CONVERT_EXPR
:
2863 if (AGGREGATE_TYPE_P (type
) && AGGREGATE_TYPE_P (etype
)
2864 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2865 return convert (type
, TREE_OPERAND (expr
, 0));
2869 /* If both types are record types, just convert the pointer and
2870 make a new INDIRECT_REF.
2872 ??? Disable this for now since it causes problems with the
2873 code in build_binary_op for MODIFY_EXPR which wants to
2874 strip off conversions. But that code really is a mess and
2875 we need to do this a much better way some time. */
2877 && (TREE_CODE (type
) == RECORD_TYPE
2878 || TREE_CODE (type
) == UNION_TYPE
)
2879 && (TREE_CODE (etype
) == RECORD_TYPE
2880 || TREE_CODE (etype
) == UNION_TYPE
)
2881 && ! TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2882 return build_unary_op (INDIRECT_REF
, NULL_TREE
,
2883 convert (build_pointer_type (type
),
2884 TREE_OPERAND (expr
, 0)));
2891 /* Check for converting to a pointer to an unconstrained array. */
2892 if (TYPE_FAT_POINTER_P (type
) && ! TYPE_FAT_POINTER_P (etype
))
2893 return convert_to_fat_pointer (type
, expr
);
2895 /* If we're converting between two aggregate types that have the same main
2896 variant, just make a VIEW_CONVER_EXPR. */
2897 else if (AGGREGATE_TYPE_P (type
)
2898 && TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
))
2899 return build1 (VIEW_CONVERT_EXPR
, type
, expr
);
2901 /* In all other cases of related types, make a NOP_EXPR. */
2902 else if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (etype
)
2903 || (code
== INTEGER_CST
&& ecode
== INTEGER_CST
2904 && (type
== TREE_TYPE (etype
) || etype
== TREE_TYPE (type
))))
2905 return fold (build1 (NOP_EXPR
, type
, expr
));
2910 return build1 (CONVERT_EXPR
, type
, expr
);
2913 return fold (build1 (NOP_EXPR
, type
, gnat_truthvalue_conversion (expr
)));
2916 if (TYPE_HAS_ACTUAL_BOUNDS_P (type
)
2917 && (ecode
== ARRAY_TYPE
|| ecode
== UNCONSTRAINED_ARRAY_TYPE
2918 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))))
2919 return unchecked_convert (type
, expr
, 0);
2920 else if (TYPE_BIASED_REPRESENTATION_P (type
))
2921 return fold (build1 (CONVERT_EXPR
, type
,
2922 fold (build (MINUS_EXPR
, TREE_TYPE (type
),
2923 convert (TREE_TYPE (type
), expr
),
2924 TYPE_MIN_VALUE (type
)))));
2926 /* ... fall through ... */
2929 return fold (convert_to_integer (type
, expr
));
2932 case REFERENCE_TYPE
:
2933 /* If converting between two pointers to records denoting
2934 both a template and type, adjust if needed to account
2935 for any differing offsets, since one might be negative. */
2936 if (TYPE_THIN_POINTER_P (etype
) && TYPE_THIN_POINTER_P (type
))
2939 = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype
))),
2940 bit_position (TYPE_FIELDS (TREE_TYPE (type
))));
2941 tree byte_diff
= size_binop (CEIL_DIV_EXPR
, bit_diff
,
2942 sbitsize_int (BITS_PER_UNIT
));
2944 expr
= build1 (NOP_EXPR
, type
, expr
);
2945 TREE_CONSTANT (expr
) = TREE_CONSTANT (TREE_OPERAND (expr
, 0));
2946 if (integer_zerop (byte_diff
))
2949 return build_binary_op (PLUS_EXPR
, type
, expr
,
2950 fold (convert_to_pointer (type
, byte_diff
)));
2953 /* If converting to a thin pointer, handle specially. */
2954 if (TYPE_THIN_POINTER_P (type
)
2955 && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type
)) != 0)
2956 return convert_to_thin_pointer (type
, expr
);
2958 /* If converting fat pointer to normal pointer, get the pointer to the
2959 array and then convert it. */
2960 else if (TYPE_FAT_POINTER_P (etype
))
2961 expr
= build_component_ref (expr
, get_identifier ("P_ARRAY"),
2964 return fold (convert_to_pointer (type
, expr
));
2967 return fold (convert_to_real (type
, expr
));
2970 if (TYPE_LEFT_JUSTIFIED_MODULAR_P (type
) && ! AGGREGATE_TYPE_P (etype
))
2972 gnat_build_constructor
2973 (type
, tree_cons (TYPE_FIELDS (type
),
2974 convert (TREE_TYPE (TYPE_FIELDS (type
)), expr
),
2977 /* ... fall through ... */
2980 /* In these cases, assume the front-end has validated the conversion.
2981 If the conversion is valid, it will be a bit-wise conversion, so
2982 it can be viewed as an unchecked conversion. */
2983 return unchecked_convert (type
, expr
, 0);
2986 /* Just validate that the type is indeed that of a field
2987 of the type. Then make the simple conversion. */
2988 for (tem
= TYPE_FIELDS (type
); tem
; tem
= TREE_CHAIN (tem
))
2990 if (TREE_TYPE (tem
) == etype
)
2991 return build1 (CONVERT_EXPR
, type
, expr
);
2992 else if (TREE_CODE (TREE_TYPE (tem
)) == RECORD_TYPE
2993 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (tem
))
2994 || TYPE_IS_PADDING_P (TREE_TYPE (tem
)))
2995 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem
))) == etype
)
2996 return build1 (CONVERT_EXPR
, type
,
2997 convert (TREE_TYPE (tem
), expr
));
3002 case UNCONSTRAINED_ARRAY_TYPE
:
3003 /* If EXPR is a constrained array, take its address, convert it to a
3004 fat pointer, and then dereference it. Likewise if EXPR is a
3005 record containing both a template and a constrained array.
3006 Note that a record representing a left justified modular type
3007 always represents a packed constrained array. */
3008 if (ecode
== ARRAY_TYPE
3009 || (ecode
== INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (etype
))
3010 || (ecode
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (etype
))
3011 || (ecode
== RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
)))
3014 (INDIRECT_REF
, NULL_TREE
,
3015 convert_to_fat_pointer (TREE_TYPE (type
),
3016 build_unary_op (ADDR_EXPR
,
3019 /* Do something very similar for converting one unconstrained
3020 array to another. */
3021 else if (ecode
== UNCONSTRAINED_ARRAY_TYPE
)
3023 build_unary_op (INDIRECT_REF
, NULL_TREE
,
3024 convert (TREE_TYPE (type
),
3025 build_unary_op (ADDR_EXPR
,
3031 return fold (convert_to_complex (type
, expr
));
3038 /* Remove all conversions that are done in EXP. This includes converting
3039 from a padded type or to a left-justified modular type. If TRUE_ADDRESS
3040 is nonzero, always return the address of the containing object even if
3041 the address is not bit-aligned. */
3044 remove_conversions (tree exp
, int true_address
)
3046 switch (TREE_CODE (exp
))
3050 && TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
3051 && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp
)))
3052 return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp
)), 1);
3056 if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp
, 0))) == RECORD_TYPE
3057 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp
, 0))))
3058 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3061 case VIEW_CONVERT_EXPR
: case NON_LVALUE_EXPR
:
3062 case NOP_EXPR
: case CONVERT_EXPR
:
3063 return remove_conversions (TREE_OPERAND (exp
, 0), true_address
);
3072 /* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
3073 refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
3074 likewise return an expression pointing to the underlying array. */
3077 maybe_unconstrained_array (tree exp
)
3079 enum tree_code code
= TREE_CODE (exp
);
3082 switch (TREE_CODE (TREE_TYPE (exp
)))
3084 case UNCONSTRAINED_ARRAY_TYPE
:
3085 if (code
== UNCONSTRAINED_ARRAY_REF
)
3088 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
3089 build_component_ref (TREE_OPERAND (exp
, 0),
3090 get_identifier ("P_ARRAY"),
3092 TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp
);
3096 else if (code
== NULL_EXPR
)
3097 return build1 (NULL_EXPR
,
3098 TREE_TYPE (TREE_TYPE (TYPE_FIELDS
3099 (TREE_TYPE (TREE_TYPE (exp
))))),
3100 TREE_OPERAND (exp
, 0));
3103 /* If this is a padded type, convert to the unpadded type and see if
3104 it contains a template. */
3105 if (TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
3107 new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
3108 if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
3109 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
3111 build_component_ref (new, NULL_TREE
,
3112 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
3115 else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp
)))
3117 build_component_ref (exp
, NULL_TREE
,
3118 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp
))), 0);
3128 /* Return an expression that does an unchecked converstion of EXPR to TYPE.
3129 If NOTRUNC_P is set, truncation operations should be suppressed. */
3132 unchecked_convert (tree type
, tree expr
, int notrunc_p
)
3134 tree etype
= TREE_TYPE (expr
);
3136 /* If the expression is already the right type, we are done. */
3140 /* If both types types are integral just do a normal conversion.
3141 Likewise for a conversion to an unconstrained array. */
3142 if ((((INTEGRAL_TYPE_P (type
)
3143 && ! (TREE_CODE (type
) == INTEGER_TYPE
3144 && TYPE_VAX_FLOATING_POINT_P (type
)))
3145 || (POINTER_TYPE_P (type
) && ! TYPE_THIN_POINTER_P (type
))
3146 || (TREE_CODE (type
) == RECORD_TYPE
3147 && TYPE_LEFT_JUSTIFIED_MODULAR_P (type
)))
3148 && ((INTEGRAL_TYPE_P (etype
)
3149 && ! (TREE_CODE (etype
) == INTEGER_TYPE
3150 && TYPE_VAX_FLOATING_POINT_P (etype
)))
3151 || (POINTER_TYPE_P (etype
) && ! TYPE_THIN_POINTER_P (etype
))
3152 || (TREE_CODE (etype
) == RECORD_TYPE
3153 && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype
))))
3154 || TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3158 if (TREE_CODE (etype
) == INTEGER_TYPE
3159 && TYPE_BIASED_REPRESENTATION_P (etype
))
3161 tree ntype
= copy_type (etype
);
3163 TYPE_BIASED_REPRESENTATION_P (ntype
) = 0;
3164 TYPE_MAIN_VARIANT (ntype
) = ntype
;
3165 expr
= build1 (NOP_EXPR
, ntype
, expr
);
3168 if (TREE_CODE (type
) == INTEGER_TYPE
3169 && TYPE_BIASED_REPRESENTATION_P (type
))
3171 rtype
= copy_type (type
);
3172 TYPE_BIASED_REPRESENTATION_P (rtype
) = 0;
3173 TYPE_MAIN_VARIANT (rtype
) = rtype
;
3176 expr
= convert (rtype
, expr
);
3178 expr
= build1 (NOP_EXPR
, type
, expr
);
3181 /* If we are converting TO an integral type whose precision is not the
3182 same as its size, first unchecked convert to a record that contains
3183 an object of the output type. Then extract the field. */
3184 else if (INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3185 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3186 GET_MODE_BITSIZE (TYPE_MODE (type
))))
3188 tree rec_type
= make_node (RECORD_TYPE
);
3189 tree field
= create_field_decl (get_identifier ("OBJ"), type
,
3190 rec_type
, 1, 0, 0, 0);
3192 TYPE_FIELDS (rec_type
) = field
;
3193 layout_type (rec_type
);
3195 expr
= unchecked_convert (rec_type
, expr
, notrunc_p
);
3196 expr
= build_component_ref (expr
, NULL_TREE
, field
, 0);
3199 /* Similarly for integral input type whose precision is not equal to its
3201 else if (INTEGRAL_TYPE_P (etype
) && TYPE_RM_SIZE (etype
) != 0
3202 && 0 != compare_tree_int (TYPE_RM_SIZE (etype
),
3203 GET_MODE_BITSIZE (TYPE_MODE (etype
))))
3205 tree rec_type
= make_node (RECORD_TYPE
);
3207 = create_field_decl (get_identifier ("OBJ"), etype
, rec_type
,
3210 TYPE_FIELDS (rec_type
) = field
;
3211 layout_type (rec_type
);
3213 expr
= gnat_build_constructor (rec_type
, build_tree_list (field
, expr
));
3214 expr
= unchecked_convert (type
, expr
, notrunc_p
);
3217 /* We have a special case when we are converting between two
3218 unconstrained array types. In that case, take the address,
3219 convert the fat pointer types, and dereference. */
3220 else if (TREE_CODE (etype
) == UNCONSTRAINED_ARRAY_TYPE
3221 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
)
3222 expr
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3223 build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (type
),
3224 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3228 expr
= maybe_unconstrained_array (expr
);
3230 /* There's no point in doing two unchecked conversions in a row. */
3231 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
)
3232 expr
= TREE_OPERAND (expr
, 0);
3234 etype
= TREE_TYPE (expr
);
3235 expr
= build1 (VIEW_CONVERT_EXPR
, type
, expr
);
3238 /* If the result is an integral type whose size is not equal to
3239 the size of the underlying machine type, sign- or zero-extend
3240 the result. We need not do this in the case where the input is
3241 an integral type of the same precision and signedness or if the output
3242 is a biased type or if both the input and output are unsigned. */
3244 && INTEGRAL_TYPE_P (type
) && TYPE_RM_SIZE (type
) != 0
3245 && ! (TREE_CODE (type
) == INTEGER_TYPE
3246 && TYPE_BIASED_REPRESENTATION_P (type
))
3247 && 0 != compare_tree_int (TYPE_RM_SIZE (type
),
3248 GET_MODE_BITSIZE (TYPE_MODE (type
)))
3249 && ! (INTEGRAL_TYPE_P (etype
)
3250 && TYPE_UNSIGNED (type
) == TYPE_UNSIGNED (etype
)
3251 && operand_equal_p (TYPE_RM_SIZE (type
),
3252 (TYPE_RM_SIZE (etype
) != 0
3253 ? TYPE_RM_SIZE (etype
) : TYPE_SIZE (etype
)),
3255 && ! (TYPE_UNSIGNED (type
) && TYPE_UNSIGNED (etype
)))
3257 tree base_type
= gnat_type_for_mode (TYPE_MODE (type
),
3258 TYPE_UNSIGNED (type
));
3260 = convert (base_type
,
3261 size_binop (MINUS_EXPR
,
3263 (GET_MODE_BITSIZE (TYPE_MODE (type
))),
3264 TYPE_RM_SIZE (type
)));
3267 build_binary_op (RSHIFT_EXPR
, base_type
,
3268 build_binary_op (LSHIFT_EXPR
, base_type
,
3269 convert (base_type
, expr
),
3274 /* An unchecked conversion should never raise Constraint_Error. The code
3275 below assumes that GCC's conversion routines overflow the same way that
3276 the underlying hardware does. This is probably true. In the rare case
3277 when it is false, we can rely on the fact that such conversions are
3278 erroneous anyway. */
3279 if (TREE_CODE (expr
) == INTEGER_CST
)
3280 TREE_OVERFLOW (expr
) = TREE_CONSTANT_OVERFLOW (expr
) = 0;
3282 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
3283 show no longer constant. */
3284 if (TREE_CODE (expr
) == VIEW_CONVERT_EXPR
3285 && ! operand_equal_p (TYPE_SIZE_UNIT (type
), TYPE_SIZE_UNIT (etype
),
3287 TREE_CONSTANT (expr
) = 0;
3292 #include "gt-ada-utils.h"
3293 #include "gtype-ada.h"