OSDN Git Service

gcc/
[pf3gnuchains/gcc-fork.git] / gcc / ada / gcc-interface / utils.c
1 /****************************************************************************
2  *                                                                          *
3  *                         GNAT COMPILER COMPONENTS                         *
4  *                                                                          *
5  *                                U T I L S                                 *
6  *                                                                          *
7  *                          C Implementation File                           *
8  *                                                                          *
9  *          Copyright (C) 1992-2008, Free Software Foundation, Inc.         *
10  *                                                                          *
11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
12  * terms of the  GNU General Public License as published  by the Free Soft- *
13  * ware  Foundation;  either version 3,  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 along with GCC; see the file COPYING3.  If not see        *
19  * <http://www.gnu.org/licenses/>.                                          *
20  *                                                                          *
21  * GNAT was originally developed  by the GNAT team at  New York University. *
22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
23  *                                                                          *
24  ****************************************************************************/
25
26 /* We have attribute handlers using C specific format specifiers in warning
27    messages.  Make sure they are properly recognized.  */
28 #define GCC_DIAG_STYLE __gcc_cdiag__
29
30 #include "config.h"
31 #include "system.h"
32 #include "coretypes.h"
33 #include "tm.h"
34 #include "tree.h"
35 #include "flags.h"
36 #include "defaults.h"
37 #include "toplev.h"
38 #include "output.h"
39 #include "ggc.h"
40 #include "debug.h"
41 #include "convert.h"
42 #include "target.h"
43 #include "function.h"
44 #include "cgraph.h"
45 #include "tree-inline.h"
46 #include "tree-iterator.h"
47 #include "gimple.h"
48 #include "tree-dump.h"
49 #include "pointer-set.h"
50 #include "langhooks.h"
51
52 #include "ada.h"
53 #include "types.h"
54 #include "atree.h"
55 #include "elists.h"
56 #include "namet.h"
57 #include "nlists.h"
58 #include "stringt.h"
59 #include "uintp.h"
60 #include "fe.h"
61 #include "sinfo.h"
62 #include "einfo.h"
63 #include "ada-tree.h"
64 #include "gigi.h"
65
66 #ifndef MAX_FIXED_MODE_SIZE
67 #define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
68 #endif
69
70 #ifndef MAX_BITS_PER_WORD
71 #define MAX_BITS_PER_WORD  BITS_PER_WORD
72 #endif
73
74 /* If nonzero, pretend we are allocating at global level.  */
75 int force_global;
76
77 /* Tree nodes for the various types and decls we create.  */
78 tree gnat_std_decls[(int) ADT_LAST];
79
80 /* Functions to call for each of the possible raise reasons.  */
81 tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
82
83 /* Forward declarations for handlers of attributes.  */
84 static tree handle_const_attribute (tree *, tree, tree, int, bool *);
85 static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
86 static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
87 static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
88 static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
89 static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *);
90 static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
91 static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
92 static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
93
94 /* Fake handler for attributes we don't properly support, typically because
95    they'd require dragging a lot of the common-c front-end circuitry.  */
96 static tree fake_attribute_handler      (tree *, tree, tree, int, bool *);
97
98 /* Table of machine-independent internal attributes for Ada.  We support
99    this minimal set of attributes to accommodate the needs of builtins.  */
100 const struct attribute_spec gnat_internal_attribute_table[] =
101 {
102   /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */
103   { "const",        0, 0,  true,  false, false, handle_const_attribute   },
104   { "nothrow",      0, 0,  true,  false, false, handle_nothrow_attribute },
105   { "pure",         0, 0,  true,  false, false, handle_pure_attribute },
106   { "no vops",      0, 0,  true,  false, false, handle_novops_attribute },
107   { "nonnull",      0, -1, false, true,  true,  handle_nonnull_attribute },
108   { "sentinel",     0, 1,  false, true,  true,  handle_sentinel_attribute },
109   { "noreturn",     0, 0,  true,  false, false, handle_noreturn_attribute },
110   { "malloc",       0, 0,  true,  false, false, handle_malloc_attribute },
111   { "type generic", 0, 0, false, true, true, handle_type_generic_attribute },
112
113   /* ??? format and format_arg are heavy and not supported, which actually
114      prevents support for stdio builtins, which we however declare as part
115      of the common builtins.def contents.  */
116   { "format",     3, 3,  false, true,  true,  fake_attribute_handler },
117   { "format_arg", 1, 1,  false, true,  true,  fake_attribute_handler },
118
119   { NULL,         0, 0, false, false, false, NULL }
120 };
121
122 /* Associates a GNAT tree node to a GCC tree node. It is used in
123    `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
124    of `save_gnu_tree' for more info.  */
125 static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
126
127 #define GET_GNU_TREE(GNAT_ENTITY)       \
128   associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
129
130 #define SET_GNU_TREE(GNAT_ENTITY,VAL)   \
131   associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
132
133 #define PRESENT_GNU_TREE(GNAT_ENTITY)   \
134   (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
135
136 /* Associates a GNAT entity to a GCC tree node used as a dummy, if any.  */
137 static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
138
139 #define GET_DUMMY_NODE(GNAT_ENTITY)     \
140   dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
141
142 #define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
143   dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
144
145 #define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
146   (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
147
148 /* This variable keeps a table for types for each precision so that we only
149    allocate each of them once. Signed and unsigned types are kept separate.
150
151    Note that these types are only used when fold-const requests something
152    special.  Perhaps we should NOT share these types; we'll see how it
153    goes later.  */
154 static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
155
156 /* Likewise for float types, but record these by mode.  */
157 static GTY(()) tree float_types[NUM_MACHINE_MODES];
158
159 /* For each binding contour we allocate a binding_level structure to indicate
160    the binding depth.  */
161
162 struct gnat_binding_level GTY((chain_next ("%h.chain")))
163 {
164   /* The binding level containing this one (the enclosing binding level). */
165   struct gnat_binding_level *chain;
166   /* The BLOCK node for this level.  */
167   tree block;
168   /* If nonzero, the setjmp buffer that needs to be updated for any
169      variable-sized definition within this context.  */
170   tree jmpbuf_decl;
171 };
172
173 /* The binding level currently in effect.  */
174 static GTY(()) struct gnat_binding_level *current_binding_level;
175
176 /* A chain of gnat_binding_level structures awaiting reuse.  */
177 static GTY((deletable)) struct gnat_binding_level *free_binding_level;
178
179 /* An array of global declarations.  */
180 static GTY(()) VEC(tree,gc) *global_decls;
181
182 /* An array of builtin function declarations.  */
183 static GTY(()) VEC(tree,gc) *builtin_decls;
184
185 /* An array of global renaming pointers.  */
186 static GTY(()) VEC(tree,gc) *global_renaming_pointers;
187
188 /* A chain of unused BLOCK nodes. */
189 static GTY((deletable)) tree free_block_chain;
190
191 static void gnat_install_builtins (void);
192 static tree merge_sizes (tree, tree, tree, bool, bool);
193 static tree compute_related_constant (tree, tree);
194 static tree split_plus (tree, tree *);
195 static void gnat_gimplify_function (tree);
196 static tree float_type_for_precision (int, enum machine_mode);
197 static tree convert_to_fat_pointer (tree, tree);
198 static tree convert_to_thin_pointer (tree, tree);
199 static tree make_descriptor_field (const char *,tree, tree, tree);
200 static bool potential_alignment_gap (tree, tree, tree);
201 \f
202 /* Initialize the association of GNAT nodes to GCC trees.  */
203
204 void
205 init_gnat_to_gnu (void)
206 {
207   associate_gnat_to_gnu
208     = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
209 }
210
211 /* GNAT_ENTITY is a GNAT tree node for an entity.   GNU_DECL is the GCC tree
212    which is to be associated with GNAT_ENTITY. Such GCC tree node is always
213    a ..._DECL node.  If NO_CHECK is nonzero, the latter check is suppressed.
214
215    If GNU_DECL is zero, a previous association is to be reset.  */
216
217 void
218 save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
219 {
220   /* Check that GNAT_ENTITY is not already defined and that it is being set
221      to something which is a decl.  Raise gigi 401 if not.  Usually, this
222      means GNAT_ENTITY is defined twice, but occasionally is due to some
223      Gigi problem.  */
224   gcc_assert (!(gnu_decl
225                 && (PRESENT_GNU_TREE (gnat_entity)
226                     || (!no_check && !DECL_P (gnu_decl)))));
227
228   SET_GNU_TREE (gnat_entity, gnu_decl);
229 }
230
231 /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
232    Return the ..._DECL node that was associated with it.  If there is no tree
233    node associated with GNAT_ENTITY, abort.
234
235    In some cases, such as delayed elaboration or expressions that need to
236    be elaborated only once, GNAT_ENTITY is really not an entity.  */
237
238 tree
239 get_gnu_tree (Entity_Id gnat_entity)
240 {
241   gcc_assert (PRESENT_GNU_TREE (gnat_entity));
242   return GET_GNU_TREE (gnat_entity);
243 }
244
245 /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY.  */
246
247 bool
248 present_gnu_tree (Entity_Id gnat_entity)
249 {
250   return PRESENT_GNU_TREE (gnat_entity);
251 }
252 \f
253 /* Initialize the association of GNAT nodes to GCC trees as dummies.  */
254
255 void
256 init_dummy_type (void)
257 {
258   dummy_node_table
259     = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
260 }
261
262 /* Make a dummy type corresponding to GNAT_TYPE.  */
263
264 tree
265 make_dummy_type (Entity_Id gnat_type)
266 {
267   Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
268   tree gnu_type;
269
270   /* If there is an equivalent type, get its underlying type.  */
271   if (Present (gnat_underlying))
272     gnat_underlying = Underlying_Type (gnat_underlying);
273
274   /* If there was no equivalent type (can only happen when just annotating
275      types) or underlying type, go back to the original type.  */
276   if (No (gnat_underlying))
277     gnat_underlying = gnat_type;
278
279   /* If it there already a dummy type, use that one.  Else make one.  */
280   if (PRESENT_DUMMY_NODE (gnat_underlying))
281     return GET_DUMMY_NODE (gnat_underlying);
282
283   /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
284      an ENUMERAL_TYPE.  */
285   gnu_type = make_node (Is_Record_Type (gnat_underlying)
286                         ? tree_code_for_record_type (gnat_underlying)
287                         : ENUMERAL_TYPE);
288   TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
289   TYPE_DUMMY_P (gnu_type) = 1;
290   if (AGGREGATE_TYPE_P (gnu_type))
291     {
292       TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
293       TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
294     }
295
296   SET_DUMMY_NODE (gnat_underlying, gnu_type);
297
298   return gnu_type;
299 }
300 \f
301 /* Return nonzero if we are currently in the global binding level.  */
302
303 int
304 global_bindings_p (void)
305 {
306   return ((force_global || !current_function_decl) ? -1 : 0);
307 }
308
309 /* Enter a new binding level. */
310
311 void
312 gnat_pushlevel ()
313 {
314   struct gnat_binding_level *newlevel = NULL;
315
316   /* Reuse a struct for this binding level, if there is one.  */
317   if (free_binding_level)
318     {
319       newlevel = free_binding_level;
320       free_binding_level = free_binding_level->chain;
321     }
322   else
323     newlevel
324       = (struct gnat_binding_level *)
325         ggc_alloc (sizeof (struct gnat_binding_level));
326
327   /* Use a free BLOCK, if any; otherwise, allocate one.  */
328   if (free_block_chain)
329     {
330       newlevel->block = free_block_chain;
331       free_block_chain = BLOCK_CHAIN (free_block_chain);
332       BLOCK_CHAIN (newlevel->block) = NULL_TREE;
333     }
334   else
335     newlevel->block = make_node (BLOCK);
336
337   /* Point the BLOCK we just made to its parent.  */
338   if (current_binding_level)
339     BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
340
341   BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
342   TREE_USED (newlevel->block) = 1;
343
344   /* Add this level to the front of the chain (stack) of levels that are
345      active.  */
346   newlevel->chain = current_binding_level;
347   newlevel->jmpbuf_decl = NULL_TREE;
348   current_binding_level = newlevel;
349 }
350
351 /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
352    and point FNDECL to this BLOCK.  */
353
354 void
355 set_current_block_context (tree fndecl)
356 {
357   BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
358   DECL_INITIAL (fndecl) = current_binding_level->block;
359 }
360
361 /* Set the jmpbuf_decl for the current binding level to DECL.  */
362
363 void
364 set_block_jmpbuf_decl (tree decl)
365 {
366   current_binding_level->jmpbuf_decl = decl;
367 }
368
369 /* Get the jmpbuf_decl, if any, for the current binding level.  */
370
371 tree
372 get_block_jmpbuf_decl ()
373 {
374   return current_binding_level->jmpbuf_decl;
375 }
376
377 /* Exit a binding level. Set any BLOCK into the current code group.  */
378
379 void
380 gnat_poplevel ()
381 {
382   struct gnat_binding_level *level = current_binding_level;
383   tree block = level->block;
384
385   BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
386   BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block));
387
388   /* If this is a function-level BLOCK don't do anything.  Otherwise, if there
389      are no variables free the block and merge its subblocks into those of its
390      parent block. Otherwise, add it to the list of its parent.  */
391   if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
392     ;
393   else if (BLOCK_VARS (block) == NULL_TREE)
394     {
395       BLOCK_SUBBLOCKS (level->chain->block)
396         = chainon (BLOCK_SUBBLOCKS (block),
397                    BLOCK_SUBBLOCKS (level->chain->block));
398       BLOCK_CHAIN (block) = free_block_chain;
399       free_block_chain = block;
400     }
401   else
402     {
403       BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
404       BLOCK_SUBBLOCKS (level->chain->block) = block;
405       TREE_USED (block) = 1;
406       set_block_for_group (block);
407     }
408
409   /* Free this binding structure.  */
410   current_binding_level = level->chain;
411   level->chain = free_binding_level;
412   free_binding_level = level;
413 }
414
415 \f
416 /* Records a ..._DECL node DECL as belonging to the current lexical scope
417    and uses GNAT_NODE for location information and propagating flags.  */
418
419 void
420 gnat_pushdecl (tree decl, Node_Id gnat_node)
421 {
422   /* If this decl is public external or at toplevel, there is no context.
423      But PARM_DECLs always go in the level of its function.  */
424   if (TREE_CODE (decl) != PARM_DECL
425       && ((DECL_EXTERNAL (decl) && TREE_PUBLIC (decl))
426           || global_bindings_p ()))
427     DECL_CONTEXT (decl) = 0;
428   else
429     {
430       DECL_CONTEXT (decl) = current_function_decl;
431
432       /* Functions imported in another function are not really nested.  */
433       if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
434         DECL_NO_STATIC_CHAIN (decl) = 1;
435     }
436
437   TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
438
439   /* Set the location of DECL and emit a declaration for it.  */
440   if (Present (gnat_node))
441     Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
442   add_decl_expr (decl, gnat_node);
443
444   /* Put the declaration on the list.  The list of declarations is in reverse
445      order.  The list will be reversed later.  Put global variables in the
446      globals list and builtin functions in a dedicated list to speed up
447      further lookups.  Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
448      the list, as they will cause trouble with the debugger and aren't needed
449      anyway.  */
450   if (TREE_CODE (decl) != TYPE_DECL
451       || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
452     {
453       if (global_bindings_p ())
454         {
455           VEC_safe_push (tree, gc, global_decls, decl);
456
457           if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl))
458             VEC_safe_push (tree, gc, builtin_decls, decl);
459         }
460       else
461         {
462           TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
463           BLOCK_VARS (current_binding_level->block) = decl;
464         }
465     }
466
467   /* For the declaration of a type, set its name if it either is not already
468      set, was set to an IDENTIFIER_NODE, indicating an internal name,
469      or if the previous type name was not derived from a source name.
470      We'd rather have the type named with a real name and all the pointer
471      types to the same object have the same POINTER_TYPE node.  Code in the
472      equivalent function of c-decl.c makes a copy of the type node here, but
473      that may cause us trouble with incomplete types.  We make an exception
474      for fat pointer types because the compiler automatically builds them
475      for unconstrained array types and the debugger uses them to represent
476      both these and pointers to these.  */
477   if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
478     {
479       tree t = TREE_TYPE (decl);
480
481       if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE)
482         ;
483       else if (TYPE_FAT_POINTER_P (t))
484         {
485           tree tt = build_variant_type_copy (t);
486           TYPE_NAME (tt) = decl;
487           TREE_USED (tt) = TREE_USED (t);
488           TREE_TYPE (decl) = tt;
489           DECL_ORIGINAL_TYPE (decl) = t;
490           t = NULL_TREE;
491         }
492       else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
493         ;
494       else
495         t = NULL_TREE;
496
497       /* Propagate the name to all the variants.  This is needed for
498          the type qualifiers machinery to work properly.  */
499       if (t)
500         for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
501           TYPE_NAME (t) = decl;
502     }
503 }
504 \f
505 /* Do little here.  Set up the standard declarations later after the
506    front end has been run.  */
507
508 void
509 gnat_init_decl_processing (void)
510 {
511   /* Make the binding_level structure for global names.  */
512   current_function_decl = 0;
513   current_binding_level = 0;
514   free_binding_level = 0;
515   gnat_pushlevel ();
516
517   build_common_tree_nodes (true, true);
518
519   /* In Ada, we use a signed type for SIZETYPE.  Use the signed type
520      corresponding to the size of Pmode.  In most cases when ptr_mode and
521      Pmode differ, C will use the width of ptr_mode as sizetype.  But we get
522      far better code using the width of Pmode.  Make this here since we need
523      this before we can expand the GNAT types.  */
524   size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0);
525   set_sizetype (size_type_node);
526
527   /* In Ada, we use an unsigned 8-bit type for the default boolean type.  */
528   boolean_type_node = make_node (BOOLEAN_TYPE);
529   TYPE_PRECISION (boolean_type_node) = 1;
530   fixup_unsigned_type (boolean_type_node);
531   TYPE_RM_SIZE_NUM (boolean_type_node) = bitsize_int (1);
532
533   build_common_tree_nodes_2 (0);
534
535   ptr_void_type_node = build_pointer_type (void_type_node);
536 }
537
538 /* Create the predefined scalar types such as `integer_type_node' needed
539    in the gcc back-end and initialize the global binding level.  */
540
541 void
542 init_gigi_decls (tree long_long_float_type, tree exception_type)
543 {
544   tree endlink, decl;
545   tree int64_type = gnat_type_for_size (64, 0);
546   unsigned int i;
547
548   /* Set the types that GCC and Gigi use from the front end.  We would like
549      to do this for char_type_node, but it needs to correspond to the C
550      char type.  */
551   if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
552     {
553       /* In this case, the builtin floating point types are VAX float,
554          so make up a type for use.  */
555       longest_float_type_node = make_node (REAL_TYPE);
556       TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
557       layout_type (longest_float_type_node);
558       create_type_decl (get_identifier ("longest float type"),
559                         longest_float_type_node, NULL, false, true, Empty);
560     }
561   else
562     longest_float_type_node = TREE_TYPE (long_long_float_type);
563
564   except_type_node = TREE_TYPE (exception_type);
565
566   unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
567   create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
568                     NULL, false, true, Empty);
569
570   void_type_decl_node = create_type_decl (get_identifier ("void"),
571                                           void_type_node, NULL, false, true,
572                                           Empty);
573
574   void_ftype = build_function_type (void_type_node, NULL_TREE);
575   ptr_void_ftype = build_pointer_type (void_ftype);
576
577   /* Build the special descriptor type and its null node if needed.  */
578   if (TARGET_VTABLE_USES_DESCRIPTORS)
579     {
580       tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
581       tree field_list = NULL_TREE, null_list = NULL_TREE;
582       int j;
583
584       fdesc_type_node = make_node (RECORD_TYPE);
585
586       for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
587         {
588           tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
589                                           fdesc_type_node, 0, 0, 0, 1);
590           TREE_CHAIN (field) = field_list;
591           field_list = field;
592           null_list = tree_cons (field, null_node, null_list);
593         }
594
595       finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
596       null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
597     }
598
599   /* Now declare runtime functions. */
600   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
601
602   /* malloc is a function declaration tree for a function to allocate
603      memory.  */
604   malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
605                                      NULL_TREE,
606                                      build_function_type (ptr_void_type_node,
607                                                           tree_cons (NULL_TREE,
608                                                                      sizetype,
609                                                                      endlink)),
610                                      NULL_TREE, false, true, true, NULL,
611                                      Empty);
612   DECL_IS_MALLOC (malloc_decl) = 1;
613
614   /* malloc32 is a function declaration tree for a function to allocate
615      32bit memory on a 64bit system. Needed only on 64bit VMS.  */
616   malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
617                                      NULL_TREE,
618                                      build_function_type (ptr_void_type_node,
619                                                           tree_cons (NULL_TREE,
620                                                                      sizetype,
621                                                                      endlink)),
622                                      NULL_TREE, false, true, true, NULL,
623                                      Empty);
624   DECL_IS_MALLOC (malloc32_decl) = 1;
625
626   /* free is a function declaration tree for a function to free memory.  */
627   free_decl
628     = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
629                            build_function_type (void_type_node,
630                                                 tree_cons (NULL_TREE,
631                                                            ptr_void_type_node,
632                                                            endlink)),
633                            NULL_TREE, false, true, true, NULL, Empty);
634
635   /* This is used for 64-bit multiplication with overflow checking.  */
636   mulv64_decl
637     = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
638                            build_function_type_list (int64_type, int64_type,
639                                                      int64_type, NULL_TREE),
640                            NULL_TREE, false, true, true, NULL, Empty);
641
642   /* Make the types and functions used for exception processing.    */
643   jmpbuf_type
644     = build_array_type (gnat_type_for_mode (Pmode, 0),
645                         build_index_type (build_int_cst (NULL_TREE, 5)));
646   create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
647                     true, true, Empty);
648   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
649
650   /* Functions to get and set the jumpbuf pointer for the current thread.  */
651   get_jmpbuf_decl
652     = create_subprog_decl
653     (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
654      NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
655      NULL_TREE, false, true, true, NULL, Empty);
656   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
657   DECL_PURE_P (get_jmpbuf_decl) = 1;
658
659   set_jmpbuf_decl
660     = create_subprog_decl
661     (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
662      NULL_TREE,
663      build_function_type (void_type_node,
664                           tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
665      NULL_TREE, false, true, true, NULL, Empty);
666
667   /* Function to get the current exception.  */
668   get_excptr_decl
669     = create_subprog_decl
670     (get_identifier ("system__soft_links__get_gnat_exception"),
671      NULL_TREE,
672      build_function_type (build_pointer_type (except_type_node), NULL_TREE),
673      NULL_TREE, false, true, true, NULL, Empty);
674   /* Avoid creating superfluous edges to __builtin_setjmp receivers.  */
675   DECL_PURE_P (get_excptr_decl) = 1;
676
677   /* Functions that raise exceptions. */
678   raise_nodefer_decl
679     = create_subprog_decl
680       (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
681        build_function_type (void_type_node,
682                             tree_cons (NULL_TREE,
683                                        build_pointer_type (except_type_node),
684                                        endlink)),
685        NULL_TREE, false, true, true, NULL, Empty);
686
687   /* Dummy objects to materialize "others" and "all others" in the exception
688      tables.  These are exported by a-exexpr.adb, so see this unit for the
689      types to use.  */
690
691   others_decl
692     = create_var_decl (get_identifier ("OTHERS"),
693                        get_identifier ("__gnat_others_value"),
694                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
695
696   all_others_decl
697     = create_var_decl (get_identifier ("ALL_OTHERS"),
698                        get_identifier ("__gnat_all_others_value"),
699                        integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
700
701   /* Hooks to call when entering/leaving an exception handler.  */
702   begin_handler_decl
703     = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
704                            build_function_type (void_type_node,
705                                                 tree_cons (NULL_TREE,
706                                                            ptr_void_type_node,
707                                                            endlink)),
708                            NULL_TREE, false, true, true, NULL, Empty);
709
710   end_handler_decl
711     = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
712                            build_function_type (void_type_node,
713                                                 tree_cons (NULL_TREE,
714                                                            ptr_void_type_node,
715                                                            endlink)),
716                            NULL_TREE, false, true, true, NULL, Empty);
717
718   /* If in no exception handlers mode, all raise statements are redirected to
719      __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
720      this procedure will never be called in this mode.  */
721   if (No_Exception_Handlers_Set ())
722     {
723       decl
724         = create_subprog_decl
725           (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
726            build_function_type (void_type_node,
727                                 tree_cons (NULL_TREE,
728                                            build_pointer_type (char_type_node),
729                                            tree_cons (NULL_TREE,
730                                                       integer_type_node,
731                                                       endlink))),
732            NULL_TREE, false, true, true, NULL, Empty);
733
734       for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
735         gnat_raise_decls[i] = decl;
736     }
737   else
738     /* Otherwise, make one decl for each exception reason.  */
739     for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
740       {
741         char name[17];
742
743         sprintf (name, "__gnat_rcheck_%.2d", i);
744         gnat_raise_decls[i]
745           = create_subprog_decl
746             (get_identifier (name), NULL_TREE,
747              build_function_type (void_type_node,
748                                   tree_cons (NULL_TREE,
749                                              build_pointer_type
750                                              (char_type_node),
751                                              tree_cons (NULL_TREE,
752                                                         integer_type_node,
753                                                         endlink))),
754              NULL_TREE, false, true, true, NULL, Empty);
755       }
756
757   /* Indicate that these never return.  */
758   TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
759   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
760   TREE_TYPE (raise_nodefer_decl)
761     = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
762                             TYPE_QUAL_VOLATILE);
763
764   for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
765     {
766       TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
767       TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
768       TREE_TYPE (gnat_raise_decls[i])
769         = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
770                                 TYPE_QUAL_VOLATILE);
771     }
772
773   /* setjmp returns an integer and has one operand, which is a pointer to
774      a jmpbuf.  */
775   setjmp_decl
776     = create_subprog_decl
777       (get_identifier ("__builtin_setjmp"), NULL_TREE,
778        build_function_type (integer_type_node,
779                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, endlink)),
780        NULL_TREE, false, true, true, NULL, Empty);
781
782   DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
783   DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
784
785   /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
786      address.  */
787   update_setjmp_buf_decl
788     = create_subprog_decl
789       (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
790        build_function_type (void_type_node,
791                             tree_cons (NULL_TREE,  jmpbuf_ptr_type, endlink)),
792        NULL_TREE, false, true, true, NULL, Empty);
793
794   DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
795   DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
796
797   main_identifier_node = get_identifier ("main");
798
799   /* Install the builtins we might need, either internally or as
800      user available facilities for Intrinsic imports.  */
801   gnat_install_builtins ();
802 }
803 \f
804 /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
805    finish constructing the record or union type.  If REP_LEVEL is zero, this
806    record has no representation clause and so will be entirely laid out here.
807    If REP_LEVEL is one, this record has a representation clause and has been
808    laid out already; only set the sizes and alignment.  If REP_LEVEL is two,
809    this record is derived from a parent record and thus inherits its layout;
810    only make a pass on the fields to finalize them.  If DO_NOT_FINALIZE is
811    true, the record type is expected to be modified afterwards so it will
812    not be sent to the back-end for finalization.  */
813
814 void
815 finish_record_type (tree record_type, tree fieldlist, int rep_level,
816                     bool do_not_finalize)
817 {
818   enum tree_code code = TREE_CODE (record_type);
819   tree name = TYPE_NAME (record_type);
820   tree ada_size = bitsize_zero_node;
821   tree size = bitsize_zero_node;
822   bool had_size = TYPE_SIZE (record_type) != 0;
823   bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
824   bool had_align = TYPE_ALIGN (record_type) != 0;
825   tree field;
826
827   if (name && TREE_CODE (name) == TYPE_DECL)
828     name = DECL_NAME (name);
829
830   TYPE_FIELDS (record_type) = fieldlist;
831   TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type);
832
833   /* We don't need both the typedef name and the record name output in
834      the debugging information, since they are the same.  */
835   DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
836
837   /* Globally initialize the record first.  If this is a rep'ed record,
838      that just means some initializations; otherwise, layout the record.  */
839   if (rep_level > 0)
840     {
841       TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
842       SET_TYPE_MODE (record_type, BLKmode);
843
844       if (!had_size_unit)
845         TYPE_SIZE_UNIT (record_type) = size_zero_node;
846       if (!had_size)
847         TYPE_SIZE (record_type) = bitsize_zero_node;
848
849       /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
850          out just like a UNION_TYPE, since the size will be fixed.  */
851       else if (code == QUAL_UNION_TYPE)
852         code = UNION_TYPE;
853     }
854   else
855     {
856       /* Ensure there isn't a size already set.  There can be in an error
857          case where there is a rep clause but all fields have errors and
858          no longer have a position.  */
859       TYPE_SIZE (record_type) = 0;
860       layout_type (record_type);
861     }
862
863   /* At this point, the position and size of each field is known.  It was
864      either set before entry by a rep clause, or by laying out the type above.
865
866      We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
867      to compute the Ada size; the GCC size and alignment (for rep'ed records
868      that are not padding types); and the mode (for rep'ed records).  We also
869      clear the DECL_BIT_FIELD indication for the cases we know have not been
870      handled yet, and adjust DECL_NONADDRESSABLE_P accordingly.  */
871
872   if (code == QUAL_UNION_TYPE)
873     fieldlist = nreverse (fieldlist);
874
875   for (field = fieldlist; field; field = TREE_CHAIN (field))
876     {
877       tree type = TREE_TYPE (field);
878       tree pos = bit_position (field);
879       tree this_size = DECL_SIZE (field);
880       tree this_ada_size;
881
882       if ((TREE_CODE (type) == RECORD_TYPE
883            || TREE_CODE (type) == UNION_TYPE
884            || TREE_CODE (type) == QUAL_UNION_TYPE)
885           && !TYPE_IS_FAT_POINTER_P (type)
886           && !TYPE_CONTAINS_TEMPLATE_P (type)
887           && TYPE_ADA_SIZE (type))
888         this_ada_size = TYPE_ADA_SIZE (type);
889       else
890         this_ada_size = this_size;
891
892       /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle.  */
893       if (DECL_BIT_FIELD (field)
894           && operand_equal_p (this_size, TYPE_SIZE (type), 0))
895         {
896           unsigned int align = TYPE_ALIGN (type);
897
898           /* In the general case, type alignment is required.  */
899           if (value_factor_p (pos, align))
900             {
901               /* The enclosing record type must be sufficiently aligned.
902                  Otherwise, if no alignment was specified for it and it
903                  has been laid out already, bump its alignment to the
904                  desired one if this is compatible with its size.  */
905               if (TYPE_ALIGN (record_type) >= align)
906                 {
907                   DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
908                   DECL_BIT_FIELD (field) = 0;
909                 }
910               else if (!had_align
911                        && rep_level == 0
912                        && value_factor_p (TYPE_SIZE (record_type), align))
913                 {
914                   TYPE_ALIGN (record_type) = align;
915                   DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
916                   DECL_BIT_FIELD (field) = 0;
917                 }
918             }
919
920           /* In the non-strict alignment case, only byte alignment is.  */
921           if (!STRICT_ALIGNMENT
922               && DECL_BIT_FIELD (field)
923               && value_factor_p (pos, BITS_PER_UNIT))
924             DECL_BIT_FIELD (field) = 0;
925         }
926
927       /* If we still have DECL_BIT_FIELD set at this point, we know the field
928          is technically not addressable.  Except that it can actually be
929          addressed if the field is BLKmode and happens to be properly
930          aligned.  */
931       DECL_NONADDRESSABLE_P (field)
932         |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
933
934       /* A type must be as aligned as its most aligned field that is not
935          a bit-field.  But this is already enforced by layout_type.  */
936       if (rep_level > 0 && !DECL_BIT_FIELD (field))
937         TYPE_ALIGN (record_type)
938           = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
939
940       switch (code)
941         {
942         case UNION_TYPE:
943           ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
944           size = size_binop (MAX_EXPR, size, this_size);
945           break;
946
947         case QUAL_UNION_TYPE:
948           ada_size
949             = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
950                            this_ada_size, ada_size);
951           size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
952                               this_size, size);
953           break;
954
955         case RECORD_TYPE:
956           /* Since we know here that all fields are sorted in order of
957              increasing bit position, the size of the record is one
958              higher than the ending bit of the last field processed
959              unless we have a rep clause, since in that case we might
960              have a field outside a QUAL_UNION_TYPE that has a higher ending
961              position.  So use a MAX in that case.  Also, if this field is a
962              QUAL_UNION_TYPE, we need to take into account the previous size in
963              the case of empty variants.  */
964           ada_size
965             = merge_sizes (ada_size, pos, this_ada_size,
966                            TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
967           size
968             = merge_sizes (size, pos, this_size,
969                            TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
970           break;
971
972         default:
973           gcc_unreachable ();
974         }
975     }
976
977   if (code == QUAL_UNION_TYPE)
978     nreverse (fieldlist);
979
980   if (rep_level < 2)
981     {
982       /* If this is a padding record, we never want to make the size smaller
983          than what was specified in it, if any.  */
984       if (TREE_CODE (record_type) == RECORD_TYPE
985           && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
986         size = TYPE_SIZE (record_type);
987
988       /* Now set any of the values we've just computed that apply.  */
989       if (!TYPE_IS_FAT_POINTER_P (record_type)
990           && !TYPE_CONTAINS_TEMPLATE_P (record_type))
991         SET_TYPE_ADA_SIZE (record_type, ada_size);
992
993       if (rep_level > 0)
994         {
995           tree size_unit = had_size_unit
996                            ? TYPE_SIZE_UNIT (record_type)
997                            : convert (sizetype,
998                                       size_binop (CEIL_DIV_EXPR, size,
999                                                   bitsize_unit_node));
1000           unsigned int align = TYPE_ALIGN (record_type);
1001
1002           TYPE_SIZE (record_type) = variable_size (round_up (size, align));
1003           TYPE_SIZE_UNIT (record_type)
1004             = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
1005
1006           compute_record_mode (record_type);
1007         }
1008     }
1009
1010   if (!do_not_finalize)
1011     rest_of_record_type_compilation (record_type);
1012 }
1013
1014 /* Wrap up compilation of RECORD_TYPE, i.e. most notably output all
1015    the debug information associated with it.  It need not be invoked
1016    directly in most cases since finish_record_type takes care of doing
1017    so, unless explicitly requested not to through DO_NOT_FINALIZE.  */
1018
1019 void
1020 rest_of_record_type_compilation (tree record_type)
1021 {
1022   tree fieldlist = TYPE_FIELDS (record_type);
1023   tree field;
1024   enum tree_code code = TREE_CODE (record_type);
1025   bool var_size = false;
1026
1027   for (field = fieldlist; field; field = TREE_CHAIN (field))
1028     {
1029       /* We need to make an XVE/XVU record if any field has variable size,
1030          whether or not the record does.  For example, if we have a union,
1031          it may be that all fields, rounded up to the alignment, have the
1032          same size, in which case we'll use that size.  But the debug
1033          output routines (except Dwarf2) won't be able to output the fields,
1034          so we need to make the special record.  */
1035       if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
1036           /* If a field has a non-constant qualifier, the record will have
1037              variable size too.  */
1038           || (code == QUAL_UNION_TYPE
1039               && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
1040         {
1041           var_size = true;
1042           break;
1043         }
1044     }
1045
1046   /* If this record is of variable size, rename it so that the
1047      debugger knows it is and make a new, parallel, record
1048      that tells the debugger how the record is laid out.  See
1049      exp_dbug.ads.  But don't do this for records that are padding
1050      since they confuse GDB.  */
1051   if (var_size
1052       && !(TREE_CODE (record_type) == RECORD_TYPE
1053            && TYPE_IS_PADDING_P (record_type)))
1054     {
1055       tree new_record_type
1056         = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
1057                      ? UNION_TYPE : TREE_CODE (record_type));
1058       tree orig_name = TYPE_NAME (record_type);
1059       tree orig_id
1060         = (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name)
1061            : orig_name);
1062       tree new_id
1063         = concat_id_with_name (orig_id,
1064                                TREE_CODE (record_type) == QUAL_UNION_TYPE
1065                                ? "XVU" : "XVE");
1066       tree last_pos = bitsize_zero_node;
1067       tree old_field;
1068       tree prev_old_field = 0;
1069
1070       TYPE_NAME (new_record_type) = new_id;
1071       TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
1072       TYPE_STUB_DECL (new_record_type)
1073         = build_decl (TYPE_DECL, new_id, new_record_type);
1074       DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
1075       DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
1076         = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
1077       TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
1078       TYPE_SIZE_UNIT (new_record_type)
1079         = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
1080
1081       add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type);
1082
1083       /* Now scan all the fields, replacing each field with a new
1084          field corresponding to the new encoding.  */
1085       for (old_field = TYPE_FIELDS (record_type); old_field;
1086            old_field = TREE_CHAIN (old_field))
1087         {
1088           tree field_type = TREE_TYPE (old_field);
1089           tree field_name = DECL_NAME (old_field);
1090           tree new_field;
1091           tree curpos = bit_position (old_field);
1092           bool var = false;
1093           unsigned int align = 0;
1094           tree pos;
1095
1096           /* See how the position was modified from the last position.
1097
1098           There are two basic cases we support: a value was added
1099           to the last position or the last position was rounded to
1100           a boundary and they something was added.  Check for the
1101           first case first.  If not, see if there is any evidence
1102           of rounding.  If so, round the last position and try
1103           again.
1104
1105           If this is a union, the position can be taken as zero. */
1106
1107           /* Some computations depend on the shape of the position expression,
1108              so strip conversions to make sure it's exposed.  */
1109           curpos = remove_conversions (curpos, true);
1110
1111           if (TREE_CODE (new_record_type) == UNION_TYPE)
1112             pos = bitsize_zero_node, align = 0;
1113           else
1114             pos = compute_related_constant (curpos, last_pos);
1115
1116           if (!pos && TREE_CODE (curpos) == MULT_EXPR
1117               && host_integerp (TREE_OPERAND (curpos, 1), 1))
1118             {
1119               tree offset = TREE_OPERAND (curpos, 0);
1120               align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
1121
1122               /* An offset which is a bitwise AND with a negative power of 2
1123                  means an alignment corresponding to this power of 2.  */
1124               offset = remove_conversions (offset, true);
1125               if (TREE_CODE (offset) == BIT_AND_EXPR
1126                   && host_integerp (TREE_OPERAND (offset, 1), 0)
1127                   && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0)
1128                 {
1129                   unsigned int pow
1130                     = - tree_low_cst (TREE_OPERAND (offset, 1), 0);
1131                   if (exact_log2 (pow) > 0)
1132                     align *= pow;
1133                 }
1134
1135               pos = compute_related_constant (curpos,
1136                                               round_up (last_pos, align));
1137             }
1138           else if (!pos && TREE_CODE (curpos) == PLUS_EXPR
1139                    && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
1140                    && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
1141                    && host_integerp (TREE_OPERAND
1142                                      (TREE_OPERAND (curpos, 0), 1),
1143                                      1))
1144             {
1145               align
1146                 = tree_low_cst
1147                 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
1148               pos = compute_related_constant (curpos,
1149                                               round_up (last_pos, align));
1150             }
1151           else if (potential_alignment_gap (prev_old_field, old_field,
1152                                             pos))
1153             {
1154               align = TYPE_ALIGN (field_type);
1155               pos = compute_related_constant (curpos,
1156                                               round_up (last_pos, align));
1157             }
1158
1159           /* If we can't compute a position, set it to zero.
1160
1161           ??? We really should abort here, but it's too much work
1162           to get this correct for all cases.  */
1163
1164           if (!pos)
1165             pos = bitsize_zero_node;
1166
1167           /* See if this type is variable-sized and make a pointer type
1168              and indicate the indirection if so.  Beware that the debug
1169              back-end may adjust the position computed above according
1170              to the alignment of the field type, i.e. the pointer type
1171              in this case, if we don't preventively counter that.  */
1172           if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
1173             {
1174               field_type = build_pointer_type (field_type);
1175               if (align != 0 && TYPE_ALIGN (field_type) > align)
1176                 {
1177                   field_type = copy_node (field_type);
1178                   TYPE_ALIGN (field_type) = align;
1179                 }
1180               var = true;
1181             }
1182
1183           /* Make a new field name, if necessary.  */
1184           if (var || align != 0)
1185             {
1186               char suffix[16];
1187
1188               if (align != 0)
1189                 sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
1190                          align / BITS_PER_UNIT);
1191               else
1192                 strcpy (suffix, "XVL");
1193
1194               field_name = concat_id_with_name (field_name, suffix);
1195             }
1196
1197           new_field = create_field_decl (field_name, field_type,
1198                                          new_record_type, 0,
1199                                          DECL_SIZE (old_field), pos, 0);
1200           TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
1201           TYPE_FIELDS (new_record_type) = new_field;
1202
1203           /* If old_field is a QUAL_UNION_TYPE, take its size as being
1204              zero.  The only time it's not the last field of the record
1205              is when there are other components at fixed positions after
1206              it (meaning there was a rep clause for every field) and we
1207              want to be able to encode them.  */
1208           last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
1209                                  (TREE_CODE (TREE_TYPE (old_field))
1210                                   == QUAL_UNION_TYPE)
1211                                  ? bitsize_zero_node
1212                                  : DECL_SIZE (old_field));
1213           prev_old_field = old_field;
1214         }
1215
1216       TYPE_FIELDS (new_record_type)
1217         = nreverse (TYPE_FIELDS (new_record_type));
1218
1219       rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type));
1220     }
1221
1222   rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type));
1223 }
1224
1225 /* Append PARALLEL_TYPE on the chain of parallel types for decl.  */
1226
1227 void
1228 add_parallel_type (tree decl, tree parallel_type)
1229 {
1230   tree d = decl;
1231
1232   while (DECL_PARALLEL_TYPE (d))
1233     d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d));
1234
1235   SET_DECL_PARALLEL_TYPE (d, parallel_type);
1236 }
1237
1238 /* Return the parallel type associated to a type, if any.  */
1239
1240 tree
1241 get_parallel_type (tree type)
1242 {
1243   if (TYPE_STUB_DECL (type))
1244     return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
1245   else
1246     return NULL_TREE;
1247 }
1248
1249 /* Utility function of above to merge LAST_SIZE, the previous size of a record
1250    with FIRST_BIT and SIZE that describe a field.  SPECIAL is nonzero
1251    if this represents a QUAL_UNION_TYPE in which case we must look for
1252    COND_EXPRs and replace a value of zero with the old size.  If HAS_REP
1253    is nonzero, we must take the MAX of the end position of this field
1254    with LAST_SIZE.  In all other cases, we use FIRST_BIT plus SIZE.
1255
1256    We return an expression for the size.  */
1257
1258 static tree
1259 merge_sizes (tree last_size, tree first_bit, tree size, bool special,
1260              bool has_rep)
1261 {
1262   tree type = TREE_TYPE (last_size);
1263   tree new;
1264
1265   if (!special || TREE_CODE (size) != COND_EXPR)
1266     {
1267       new = size_binop (PLUS_EXPR, first_bit, size);
1268       if (has_rep)
1269         new = size_binop (MAX_EXPR, last_size, new);
1270     }
1271
1272   else
1273     new = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
1274                        integer_zerop (TREE_OPERAND (size, 1))
1275                        ? last_size : merge_sizes (last_size, first_bit,
1276                                                   TREE_OPERAND (size, 1),
1277                                                   1, has_rep),
1278                        integer_zerop (TREE_OPERAND (size, 2))
1279                        ? last_size : merge_sizes (last_size, first_bit,
1280                                                   TREE_OPERAND (size, 2),
1281                                                   1, has_rep));
1282
1283   /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
1284      when fed through substitute_in_expr) into thinking that a constant
1285      size is not constant.  */
1286   while (TREE_CODE (new) == NON_LVALUE_EXPR)
1287     new = TREE_OPERAND (new, 0);
1288
1289   return new;
1290 }
1291
1292 /* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
1293    related by the addition of a constant.  Return that constant if so.  */
1294
1295 static tree
1296 compute_related_constant (tree op0, tree op1)
1297 {
1298   tree op0_var, op1_var;
1299   tree op0_con = split_plus (op0, &op0_var);
1300   tree op1_con = split_plus (op1, &op1_var);
1301   tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
1302
1303   if (operand_equal_p (op0_var, op1_var, 0))
1304     return result;
1305   else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
1306     return result;
1307   else
1308     return 0;
1309 }
1310
1311 /* Utility function of above to split a tree OP which may be a sum, into a
1312    constant part, which is returned, and a variable part, which is stored
1313    in *PVAR.  *PVAR may be bitsize_zero_node.  All operations must be of
1314    bitsizetype.  */
1315
1316 static tree
1317 split_plus (tree in, tree *pvar)
1318 {
1319   /* Strip NOPS in order to ease the tree traversal and maximize the
1320      potential for constant or plus/minus discovery. We need to be careful
1321      to always return and set *pvar to bitsizetype trees, but it's worth
1322      the effort.  */
1323   STRIP_NOPS (in);
1324
1325   *pvar = convert (bitsizetype, in);
1326
1327   if (TREE_CODE (in) == INTEGER_CST)
1328     {
1329       *pvar = bitsize_zero_node;
1330       return convert (bitsizetype, in);
1331     }
1332   else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
1333     {
1334       tree lhs_var, rhs_var;
1335       tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
1336       tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
1337
1338       if (lhs_var == TREE_OPERAND (in, 0)
1339           && rhs_var == TREE_OPERAND (in, 1))
1340         return bitsize_zero_node;
1341
1342       *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
1343       return size_binop (TREE_CODE (in), lhs_con, rhs_con);
1344     }
1345   else
1346     return bitsize_zero_node;
1347 }
1348 \f
1349 /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
1350    subprogram. If it is void_type_node, then we are dealing with a procedure,
1351    otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
1352    PARM_DECL nodes that are the subprogram arguments.  CICO_LIST is the
1353    copy-in/copy-out list to be stored into TYPE_CICO_LIST.
1354    RETURNS_UNCONSTRAINED is true if the function returns an unconstrained
1355    object.  RETURNS_BY_REF is true if the function returns by reference.
1356    RETURNS_BY_TARGET_PTR is true if the function is to be passed (as its
1357    first parameter) the address of the place to copy its result.  */
1358
1359 tree
1360 create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
1361                      bool returns_unconstrained, bool returns_by_ref,
1362                      bool returns_by_target_ptr)
1363 {
1364   /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
1365      the subprogram formal parameters. This list is generated by traversing the
1366      input list of PARM_DECL nodes.  */
1367   tree param_type_list = NULL;
1368   tree param_decl;
1369   tree type;
1370
1371   for (param_decl = param_decl_list; param_decl;
1372        param_decl = TREE_CHAIN (param_decl))
1373     param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
1374                                  param_type_list);
1375
1376   /* The list of the function parameter types has to be terminated by the void
1377      type to signal to the back-end that we are not dealing with a variable
1378      parameter subprogram, but that the subprogram has a fixed number of
1379      parameters.  */
1380   param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
1381
1382   /* The list of argument types has been created in reverse
1383      so nreverse it.   */
1384   param_type_list = nreverse (param_type_list);
1385
1386   type = build_function_type (return_type, param_type_list);
1387
1388   /* TYPE may have been shared since GCC hashes types.  If it has a CICO_LIST
1389      or the new type should, make a copy of TYPE.  Likewise for
1390      RETURNS_UNCONSTRAINED and RETURNS_BY_REF.  */
1391   if (TYPE_CI_CO_LIST (type) || cico_list
1392       || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
1393       || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref
1394       || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr)
1395     type = copy_type (type);
1396
1397   TYPE_CI_CO_LIST (type) = cico_list;
1398   TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
1399   TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
1400   TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr;
1401   return type;
1402 }
1403 \f
1404 /* Return a copy of TYPE but safe to modify in any way.  */
1405
1406 tree
1407 copy_type (tree type)
1408 {
1409   tree new = copy_node (type);
1410
1411   /* copy_node clears this field instead of copying it, because it is
1412      aliased with TREE_CHAIN.  */
1413   TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
1414
1415   TYPE_POINTER_TO (new) = 0;
1416   TYPE_REFERENCE_TO (new) = 0;
1417   TYPE_MAIN_VARIANT (new) = new;
1418   TYPE_NEXT_VARIANT (new) = 0;
1419
1420   return new;
1421 }
1422 \f
1423 /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
1424    TYPE_INDEX_TYPE is INDEX.  GNAT_NODE is used for the position of
1425    the decl.  */
1426
1427 tree
1428 create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
1429 {
1430   /* First build a type for the desired range.  */
1431   tree type = build_index_2_type (min, max);
1432
1433   /* If this type has the TYPE_INDEX_TYPE we want, return it.  Otherwise, if it
1434      doesn't have TYPE_INDEX_TYPE set, set it to INDEX.  If TYPE_INDEX_TYPE
1435      is set, but not to INDEX, make a copy of this type with the requested
1436      index type.  Note that we have no way of sharing these types, but that's
1437      only a small hole.  */
1438   if (TYPE_INDEX_TYPE (type) == index)
1439     return type;
1440   else if (TYPE_INDEX_TYPE (type))
1441     type = copy_type (type);
1442
1443   SET_TYPE_INDEX_TYPE (type, index);
1444   create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
1445   return type;
1446 }
1447 \f
1448 /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
1449    string) and TYPE is a ..._TYPE node giving its data type.
1450    ARTIFICIAL_P is true if this is a declaration that was generated
1451    by the compiler.  DEBUG_INFO_P is true if we need to write debugging
1452    information about this type.  GNAT_NODE is used for the position of
1453    the decl.  */
1454
1455 tree
1456 create_type_decl (tree type_name, tree type, struct attrib *attr_list,
1457                   bool artificial_p, bool debug_info_p, Node_Id gnat_node)
1458 {
1459   tree type_decl = build_decl (TYPE_DECL, type_name, type);
1460   enum tree_code code = TREE_CODE (type);
1461
1462   DECL_ARTIFICIAL (type_decl) = artificial_p;
1463
1464   if (!TYPE_IS_DUMMY_P (type))
1465     gnat_pushdecl (type_decl, gnat_node);
1466
1467   process_attributes (type_decl, attr_list);
1468
1469   /* Pass type declaration information to the debugger unless this is an
1470      UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
1471      and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
1472      type for which debugging information was not requested.  */
1473   if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
1474     DECL_IGNORED_P (type_decl) = 1;
1475   else if (code != ENUMERAL_TYPE
1476            && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type))
1477            && !((code == POINTER_TYPE || code == REFERENCE_TYPE)
1478                 && TYPE_IS_DUMMY_P (TREE_TYPE (type))))
1479     rest_of_type_decl_compilation (type_decl);
1480
1481   return type_decl;
1482 }
1483
1484 /* Return a VAR_DECL or CONST_DECL node.
1485
1486    VAR_NAME gives the name of the variable.  ASM_NAME is its assembler name
1487    (if provided).  TYPE is its data type (a GCC ..._TYPE node).  VAR_INIT is
1488    the GCC tree for an optional initial expression; NULL_TREE if none.
1489
1490    CONST_FLAG is true if this variable is constant, in which case we might
1491    return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
1492
1493    PUBLIC_FLAG is true if this is for a reference to a public entity or for a
1494    definition to be made visible outside of the current compilation unit, for
1495    instance variable definitions in a package specification.
1496
1497    EXTERN_FLAG is nonzero when processing an external variable declaration (as
1498    opposed to a definition: no storage is to be allocated for the variable).
1499
1500    STATIC_FLAG is only relevant when not at top level.  In that case
1501    it indicates whether to always allocate storage to the variable.
1502
1503    GNAT_NODE is used for the position of the decl.  */
1504
1505 tree
1506 create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
1507                    bool const_flag, bool public_flag, bool extern_flag,
1508                    bool static_flag, bool const_decl_allowed_p,
1509                    struct attrib *attr_list, Node_Id gnat_node)
1510 {
1511   bool init_const
1512     = (var_init != 0
1513        && gnat_types_compatible_p (type, TREE_TYPE (var_init))
1514        && (global_bindings_p () || static_flag
1515            ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0
1516            : TREE_CONSTANT (var_init)));
1517
1518   /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
1519      case the initializer may be used in-lieu of the DECL node (as done in
1520      Identifier_to_gnu).  This is useful to prevent the need of elaboration
1521      code when an identifier for which such a decl is made is in turn used as
1522      an initializer.  We used to rely on CONST vs VAR_DECL for this purpose,
1523      but extra constraints apply to this choice (see below) and are not
1524      relevant to the distinction we wish to make. */
1525   bool constant_p = const_flag && init_const;
1526
1527   /* The actual DECL node.  CONST_DECL was initially intended for enumerals
1528      and may be used for scalars in general but not for aggregates.  */
1529   tree var_decl
1530     = build_decl ((constant_p && const_decl_allowed_p
1531                    && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
1532                   var_name, type);
1533
1534   /* If this is external, throw away any initializations (they will be done
1535      elsewhere) unless this is a constant for which we would like to remain
1536      able to get the initializer.  If we are defining a global here, leave a
1537      constant initialization and save any variable elaborations for the
1538      elaboration routine.  If we are just annotating types, throw away the
1539      initialization if it isn't a constant.  */
1540   if ((extern_flag && !constant_p)
1541       || (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
1542     var_init = NULL_TREE;
1543
1544   /* At the global level, an initializer requiring code to be generated
1545      produces elaboration statements.  Check that such statements are allowed,
1546      that is, not violating a No_Elaboration_Code restriction.  */
1547   if (global_bindings_p () && var_init != 0 && ! init_const)
1548     Check_Elaboration_Code_Allowed (gnat_node);
1549
1550   /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
1551      try to fiddle with DECL_COMMON.  However, on platforms that don't
1552      support global BSS sections, uninitialized global variables would
1553      go in DATA instead, thus increasing the size of the executable.  */
1554   if (!flag_no_common
1555       && TREE_CODE (var_decl) == VAR_DECL
1556       && !have_global_bss_p ())
1557     DECL_COMMON (var_decl) = 1;
1558   DECL_INITIAL  (var_decl) = var_init;
1559   TREE_READONLY (var_decl) = const_flag;
1560   DECL_EXTERNAL (var_decl) = extern_flag;
1561   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
1562   TREE_CONSTANT (var_decl) = constant_p;
1563   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1564     = TYPE_VOLATILE (type);
1565
1566   /* If it's public and not external, always allocate storage for it.
1567      At the global binding level we need to allocate static storage for the
1568      variable if and only if it's not external. If we are not at the top level
1569      we allocate automatic storage unless requested not to.  */
1570   TREE_STATIC (var_decl)
1571     = !extern_flag && (public_flag || static_flag || global_bindings_p ());
1572
1573   if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl))
1574     SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1575
1576   process_attributes (var_decl, attr_list);
1577
1578   /* Add this decl to the current binding level.  */
1579   gnat_pushdecl (var_decl, gnat_node);
1580
1581   if (TREE_SIDE_EFFECTS (var_decl))
1582     TREE_ADDRESSABLE (var_decl) = 1;
1583
1584   if (TREE_CODE (var_decl) != CONST_DECL)
1585     {
1586       if (global_bindings_p ())
1587         rest_of_decl_compilation (var_decl, true, 0);
1588     }
1589   else
1590     expand_decl (var_decl);
1591
1592   return var_decl;
1593 }
1594 \f
1595 /* Return true if TYPE, an aggregate type, contains (or is) an array.  */
1596
1597 static bool
1598 aggregate_type_contains_array_p (tree type)
1599 {
1600   switch (TREE_CODE (type))
1601     {
1602     case RECORD_TYPE:
1603     case UNION_TYPE:
1604     case QUAL_UNION_TYPE:
1605       {
1606         tree field;
1607         for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
1608           if (AGGREGATE_TYPE_P (TREE_TYPE (field))
1609               && aggregate_type_contains_array_p (TREE_TYPE (field)))
1610             return true;
1611         return false;
1612       }
1613
1614     case ARRAY_TYPE:
1615       return true;
1616
1617     default:
1618       gcc_unreachable ();
1619     }
1620 }
1621
1622 /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
1623    type, and RECORD_TYPE is the type of the parent.  PACKED is nonzero if
1624    this field is in a record type with a "pragma pack".  If SIZE is nonzero
1625    it is the specified size for this field.  If POS is nonzero, it is the bit
1626    position.  If ADDRESSABLE is nonzero, it means we are allowed to take
1627    the address of this field for aliasing purposes. If it is negative, we
1628    should not make a bitfield, which is used by make_aligning_type.   */
1629
1630 tree
1631 create_field_decl (tree field_name, tree field_type, tree record_type,
1632                    int packed, tree size, tree pos, int addressable)
1633 {
1634   tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
1635
1636   DECL_CONTEXT (field_decl) = record_type;
1637   TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
1638
1639   /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1640      byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
1641      Likewise for an aggregate without specified position that contains an
1642      array, because in this case slices of variable length of this array
1643      must be handled by GCC and variable-sized objects need to be aligned
1644      to at least a byte boundary.  */
1645   if (packed && (TYPE_MODE (field_type) == BLKmode
1646                  || (!pos
1647                      && AGGREGATE_TYPE_P (field_type)
1648                      && aggregate_type_contains_array_p (field_type))))
1649     DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1650
1651   /* If a size is specified, use it.  Otherwise, if the record type is packed
1652      compute a size to use, which may differ from the object's natural size.
1653      We always set a size in this case to trigger the checks for bitfield
1654      creation below, which is typically required when no position has been
1655      specified.  */
1656   if (size)
1657     size = convert (bitsizetype, size);
1658   else if (packed == 1)
1659     {
1660       size = rm_size (field_type);
1661
1662       /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
1663          byte.  */
1664       if (TREE_CODE (size) == INTEGER_CST
1665           && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
1666         size = round_up (size, BITS_PER_UNIT);
1667     }
1668
1669   /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1670      specified for two reasons: first if the size differs from the natural
1671      size.  Second, if the alignment is insufficient.  There are a number of
1672      ways the latter can be true.
1673
1674      We never make a bitfield if the type of the field has a nonconstant size,
1675      because no such entity requiring bitfield operations should reach here.
1676
1677      We do *preventively* make a bitfield when there might be the need for it
1678      but we don't have all the necessary information to decide, as is the case
1679      of a field with no specified position in a packed record.
1680
1681      We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1682      in layout_decl or finish_record_type to clear the bit_field indication if
1683      it is in fact not needed.  */
1684   if (addressable >= 0
1685       && size
1686       && TREE_CODE (size) == INTEGER_CST
1687       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1688       && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
1689           || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
1690           || packed
1691           || (TYPE_ALIGN (record_type) != 0
1692               && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1693     {
1694       DECL_BIT_FIELD (field_decl) = 1;
1695       DECL_SIZE (field_decl) = size;
1696       if (!packed && !pos)
1697         DECL_ALIGN (field_decl)
1698           = (TYPE_ALIGN (record_type) != 0
1699              ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
1700              : TYPE_ALIGN (field_type));
1701     }
1702
1703   DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
1704
1705   /* Bump the alignment if need be, either for bitfield/packing purposes or
1706      to satisfy the type requirements if no such consideration applies.  When
1707      we get the alignment from the type, indicate if this is from an explicit
1708      user request, which prevents stor-layout from lowering it later on.  */
1709   {
1710     unsigned int bit_align
1711       = (DECL_BIT_FIELD (field_decl) ? 1
1712          : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
1713
1714     if (bit_align > DECL_ALIGN (field_decl))
1715       DECL_ALIGN (field_decl) = bit_align;
1716     else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
1717       {
1718         DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1719         DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
1720       }
1721   }
1722
1723   if (pos)
1724     {
1725       /* We need to pass in the alignment the DECL is known to have.
1726          This is the lowest-order bit set in POS, but no more than
1727          the alignment of the record, if one is specified.  Note
1728          that an alignment of 0 is taken as infinite.  */
1729       unsigned int known_align;
1730
1731       if (host_integerp (pos, 1))
1732         known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1733       else
1734         known_align = BITS_PER_UNIT;
1735
1736       if (TYPE_ALIGN (record_type)
1737           && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1738         known_align = TYPE_ALIGN (record_type);
1739
1740       layout_decl (field_decl, known_align);
1741       SET_DECL_OFFSET_ALIGN (field_decl,
1742                              host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1743                              : BITS_PER_UNIT);
1744       pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1745                     &DECL_FIELD_BIT_OFFSET (field_decl),
1746                     DECL_OFFSET_ALIGN (field_decl), pos);
1747
1748       DECL_HAS_REP_P (field_decl) = 1;
1749     }
1750
1751   /* In addition to what our caller says, claim the field is addressable if we
1752      know that its type is not suitable.
1753
1754      The field may also be "technically" nonaddressable, meaning that even if
1755      we attempt to take the field's address we will actually get the address
1756      of a copy.  This is the case for true bitfields, but the DECL_BIT_FIELD
1757      value we have at this point is not accurate enough, so we don't account
1758      for this here and let finish_record_type decide.  */
1759   if (!addressable && !type_for_nonaliased_component_p (field_type))
1760     addressable = 1;
1761
1762   DECL_NONADDRESSABLE_P (field_decl) = !addressable;
1763
1764   return field_decl;
1765 }
1766 \f
1767 /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
1768    PARAM_TYPE is its type.  READONLY is true if the parameter is
1769    readonly (either an In parameter or an address of a pass-by-ref
1770    parameter). */
1771
1772 tree
1773 create_param_decl (tree param_name, tree param_type, bool readonly)
1774 {
1775   tree param_decl = build_decl (PARM_DECL, param_name, param_type);
1776
1777   /* Honor targetm.calls.promote_prototypes(), as not doing so can
1778      lead to various ABI violations.  */
1779   if (targetm.calls.promote_prototypes (param_type)
1780       && (TREE_CODE (param_type) == INTEGER_TYPE
1781           || TREE_CODE (param_type) == ENUMERAL_TYPE
1782           || TREE_CODE (param_type) == BOOLEAN_TYPE)
1783       && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1784     {
1785       /* We have to be careful about biased types here.  Make a subtype
1786          of integer_type_node with the proper biasing.  */
1787       if (TREE_CODE (param_type) == INTEGER_TYPE
1788           && TYPE_BIASED_REPRESENTATION_P (param_type))
1789         {
1790           param_type
1791             = copy_type (build_range_type (integer_type_node,
1792                                            TYPE_MIN_VALUE (param_type),
1793                                            TYPE_MAX_VALUE (param_type)));
1794
1795           TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
1796         }
1797       else
1798         param_type = integer_type_node;
1799     }
1800
1801   DECL_ARG_TYPE (param_decl) = param_type;
1802   TREE_READONLY (param_decl) = readonly;
1803   return param_decl;
1804 }
1805 \f
1806 /* Given a DECL and ATTR_LIST, process the listed attributes.  */
1807
1808 void
1809 process_attributes (tree decl, struct attrib *attr_list)
1810 {
1811   for (; attr_list; attr_list = attr_list->next)
1812     switch (attr_list->type)
1813       {
1814       case ATTR_MACHINE_ATTRIBUTE:
1815         decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
1816                                            NULL_TREE),
1817                          ATTR_FLAG_TYPE_IN_PLACE);
1818         break;
1819
1820       case ATTR_LINK_ALIAS:
1821         if (! DECL_EXTERNAL (decl))
1822           {
1823             TREE_STATIC (decl) = 1;
1824             assemble_alias (decl, attr_list->name);
1825           }
1826         break;
1827
1828       case ATTR_WEAK_EXTERNAL:
1829         if (SUPPORTS_WEAK)
1830           declare_weak (decl);
1831         else
1832           post_error ("?weak declarations not supported on this target",
1833                       attr_list->error_point);
1834         break;
1835
1836       case ATTR_LINK_SECTION:
1837         if (targetm.have_named_sections)
1838           {
1839             DECL_SECTION_NAME (decl)
1840               = build_string (IDENTIFIER_LENGTH (attr_list->name),
1841                               IDENTIFIER_POINTER (attr_list->name));
1842             DECL_COMMON (decl) = 0;
1843           }
1844         else
1845           post_error ("?section attributes are not supported for this target",
1846                       attr_list->error_point);
1847         break;
1848
1849       case ATTR_LINK_CONSTRUCTOR:
1850         DECL_STATIC_CONSTRUCTOR (decl) = 1;
1851         TREE_USED (decl) = 1;
1852         break;
1853
1854       case ATTR_LINK_DESTRUCTOR:
1855         DECL_STATIC_DESTRUCTOR (decl) = 1;
1856         TREE_USED (decl) = 1;
1857         break;
1858       }
1859 }
1860 \f
1861 /* Record a global renaming pointer.  */
1862
1863 void
1864 record_global_renaming_pointer (tree decl)
1865 {
1866   gcc_assert (DECL_RENAMED_OBJECT (decl));
1867   VEC_safe_push (tree, gc, global_renaming_pointers, decl);
1868 }
1869
1870 /* Invalidate the global renaming pointers.   */
1871
1872 void
1873 invalidate_global_renaming_pointers (void)
1874 {
1875   unsigned int i;
1876   tree iter;
1877
1878   for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++)
1879     SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
1880
1881   VEC_free (tree, gc, global_renaming_pointers);
1882 }
1883
1884 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1885    a power of 2. */
1886
1887 bool
1888 value_factor_p (tree value, HOST_WIDE_INT factor)
1889 {
1890   if (host_integerp (value, 1))
1891     return tree_low_cst (value, 1) % factor == 0;
1892
1893   if (TREE_CODE (value) == MULT_EXPR)
1894     return (value_factor_p (TREE_OPERAND (value, 0), factor)
1895             || value_factor_p (TREE_OPERAND (value, 1), factor));
1896
1897   return false;
1898 }
1899
1900 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1901    unless we can prove these 2 fields are laid out in such a way that no gap
1902    exist between the end of PREV_FIELD and the beginning of CURR_FIELD.  OFFSET
1903    is the distance in bits between the end of PREV_FIELD and the starting
1904    position of CURR_FIELD. It is ignored if null. */
1905
1906 static bool
1907 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
1908 {
1909   /* If this is the first field of the record, there cannot be any gap */
1910   if (!prev_field)
1911     return false;
1912
1913   /* If the previous field is a union type, then return False: The only
1914      time when such a field is not the last field of the record is when
1915      there are other components at fixed positions after it (meaning there
1916      was a rep clause for every field), in which case we don't want the
1917      alignment constraint to override them. */
1918   if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1919     return false;
1920
1921   /* If the distance between the end of prev_field and the beginning of
1922      curr_field is constant, then there is a gap if the value of this
1923      constant is not null. */
1924   if (offset && host_integerp (offset, 1))
1925     return !integer_zerop (offset);
1926
1927   /* If the size and position of the previous field are constant,
1928      then check the sum of this size and position. There will be a gap
1929      iff it is not multiple of the current field alignment. */
1930   if (host_integerp (DECL_SIZE (prev_field), 1)
1931       && host_integerp (bit_position (prev_field), 1))
1932     return ((tree_low_cst (bit_position (prev_field), 1)
1933              + tree_low_cst (DECL_SIZE (prev_field), 1))
1934             % DECL_ALIGN (curr_field) != 0);
1935
1936   /* If both the position and size of the previous field are multiples
1937      of the current field alignment, there cannot be any gap. */
1938   if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1939       && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1940     return false;
1941
1942   /* Fallback, return that there may be a potential gap */
1943   return true;
1944 }
1945
1946 /* Returns a LABEL_DECL node for LABEL_NAME.  */
1947
1948 tree
1949 create_label_decl (tree label_name)
1950 {
1951   tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
1952
1953   DECL_CONTEXT (label_decl)     = current_function_decl;
1954   DECL_MODE (label_decl)        = VOIDmode;
1955   DECL_SOURCE_LOCATION (label_decl) = input_location;
1956
1957   return label_decl;
1958 }
1959 \f
1960 /* Returns a FUNCTION_DECL node.  SUBPROG_NAME is the name of the subprogram,
1961    ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1962    node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1963    PARM_DECL nodes chained through the TREE_CHAIN field).
1964
1965    INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1966    appropriate fields in the FUNCTION_DECL.  GNAT_NODE gives the location.  */
1967
1968 tree
1969 create_subprog_decl (tree subprog_name, tree asm_name,
1970                      tree subprog_type, tree param_decl_list, bool inline_flag,
1971                      bool public_flag, bool extern_flag,
1972                      struct attrib *attr_list, Node_Id gnat_node)
1973 {
1974   tree return_type  = TREE_TYPE (subprog_type);
1975   tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
1976
1977   /* If this is a non-inline function nested inside an inlined external
1978      function, we cannot honor both requests without cloning the nested
1979      function in the current unit since it is private to the other unit.
1980      We could inline the nested function as well but it's probably better
1981      to err on the side of too little inlining.  */
1982   if (!inline_flag
1983       && current_function_decl
1984       && DECL_DECLARED_INLINE_P (current_function_decl)
1985       && DECL_EXTERNAL (current_function_decl))
1986     DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1987
1988   DECL_EXTERNAL (subprog_decl)  = extern_flag;
1989   TREE_PUBLIC (subprog_decl)    = public_flag;
1990   TREE_STATIC (subprog_decl)    = 1;
1991   TREE_READONLY (subprog_decl)  = TYPE_READONLY (subprog_type);
1992   TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1993   TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1994   DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag;
1995   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1996   DECL_RESULT (subprog_decl)    = build_decl (RESULT_DECL, 0, return_type);
1997   DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
1998   DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
1999
2000   /* TREE_ADDRESSABLE is set on the result type to request the use of the
2001      target by-reference return mechanism.  This is not supported all the
2002      way down to RTL expansion with GCC 4, which ICEs on temporary creation
2003      attempts with such a type and expects DECL_BY_REFERENCE to be set on
2004      the RESULT_DECL instead - see gnat_genericize for more details.  */
2005   if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl))))
2006     {
2007       tree result_decl = DECL_RESULT (subprog_decl);
2008
2009       TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0;
2010       DECL_BY_REFERENCE (result_decl) = 1;
2011     }
2012
2013   if (asm_name)
2014     {
2015       SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
2016
2017       /* The expand_main_function circuitry expects "main_identifier_node" to
2018          designate the DECL_NAME of the 'main' entry point, in turn expected
2019          to be declared as the "main" function literally by default.  Ada
2020          program entry points are typically declared with a different name
2021          within the binder generated file, exported as 'main' to satisfy the
2022          system expectations.  Redirect main_identifier_node in this case.  */
2023       if (asm_name == main_identifier_node)
2024         main_identifier_node = DECL_NAME (subprog_decl);
2025     }
2026
2027   process_attributes (subprog_decl, attr_list);
2028
2029   /* Add this decl to the current binding level.  */
2030   gnat_pushdecl (subprog_decl, gnat_node);
2031
2032   /* Output the assembler code and/or RTL for the declaration.  */
2033   rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
2034
2035   return subprog_decl;
2036 }
2037 \f
2038 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
2039    body.  This routine needs to be invoked before processing the declarations
2040    appearing in the subprogram.  */
2041
2042 void
2043 begin_subprog_body (tree subprog_decl)
2044 {
2045   tree param_decl;
2046
2047   current_function_decl = subprog_decl;
2048   announce_function (subprog_decl);
2049
2050   /* Enter a new binding level and show that all the parameters belong to
2051      this function.  */
2052   gnat_pushlevel ();
2053   for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
2054        param_decl = TREE_CHAIN (param_decl))
2055     DECL_CONTEXT (param_decl) = subprog_decl;
2056
2057   make_decl_rtl (subprog_decl);
2058
2059   /* We handle pending sizes via the elaboration of types, so we don't need to
2060      save them.  This causes them to be marked as part of the outer function
2061      and then discarded.  */
2062   get_pending_sizes ();
2063 }
2064
2065
2066 /* Helper for the genericization callback.  Return a dereference of VAL
2067    if it is of a reference type.  */
2068
2069 static tree
2070 convert_from_reference (tree val)
2071 {
2072   tree value_type, ref;
2073
2074   if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE)
2075     return val;
2076
2077   value_type =  TREE_TYPE (TREE_TYPE (val));
2078   ref = build1 (INDIRECT_REF, value_type, val);
2079
2080   /* See if what we reference is CONST or VOLATILE, which requires
2081      looking into array types to get to the component type.  */
2082
2083   while (TREE_CODE (value_type) == ARRAY_TYPE)
2084     value_type = TREE_TYPE (value_type);
2085
2086   TREE_READONLY (ref)
2087     = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST);
2088   TREE_THIS_VOLATILE (ref)
2089     = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE);
2090
2091   TREE_SIDE_EFFECTS (ref)
2092     = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val));
2093
2094   return ref;
2095 }
2096
2097 /* Helper for the genericization callback.  Returns true if T denotes
2098    a RESULT_DECL with DECL_BY_REFERENCE set.  */
2099
2100 static inline bool
2101 is_byref_result (tree t)
2102 {
2103   return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t));
2104 }
2105
2106
2107 /* Tree walking callback for gnat_genericize. Currently ...
2108
2109    o Adjust references to the function's DECL_RESULT if it is marked
2110      DECL_BY_REFERENCE and so has had its type turned into a reference
2111      type at the end of the function compilation.  */
2112
2113 static tree
2114 gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data)
2115 {
2116   /* This implementation is modeled after what the C++ front-end is
2117      doing, basis of the downstream passes behavior.  */
2118
2119   tree stmt = *stmt_p;
2120   struct pointer_set_t *p_set = (struct pointer_set_t*) data;
2121
2122   /* If we have a direct mention of the result decl, dereference.  */
2123   if (is_byref_result (stmt))
2124     {
2125       *stmt_p = convert_from_reference (stmt);
2126       *walk_subtrees = 0;
2127       return NULL;
2128     }
2129
2130   /* Otherwise, no need to walk the same tree twice.  */
2131   if (pointer_set_contains (p_set, stmt))
2132     {
2133       *walk_subtrees = 0;
2134       return NULL_TREE;
2135     }
2136
2137   /* If we are taking the address of what now is a reference, just get the
2138      reference value.  */
2139   if (TREE_CODE (stmt) == ADDR_EXPR
2140       && is_byref_result (TREE_OPERAND (stmt, 0)))
2141     {
2142       *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
2143       *walk_subtrees = 0;
2144     }
2145
2146   /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR.  */
2147   else if (TREE_CODE (stmt) == RETURN_EXPR
2148            && TREE_OPERAND (stmt, 0)
2149            && is_byref_result (TREE_OPERAND (stmt, 0)))
2150     *walk_subtrees = 0;
2151
2152   /* Don't look inside trees that cannot embed references of interest.  */
2153   else if (IS_TYPE_OR_DECL_P (stmt))
2154     *walk_subtrees = 0;
2155
2156   pointer_set_insert (p_set, *stmt_p);
2157
2158   return NULL;
2159 }
2160
2161 /* Perform lowering of Ada trees to GENERIC. In particular:
2162
2163    o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl
2164      and adjust all the references to this decl accordingly.  */
2165
2166 static void
2167 gnat_genericize (tree fndecl)
2168 {
2169   /* Prior to GCC 4, an explicit By_Reference result mechanism for a function
2170      was handled by simply setting TREE_ADDRESSABLE on the result type.
2171      Everything required to actually pass by invisible ref using the target
2172      mechanism (e.g. extra parameter) was handled at RTL expansion time.
2173
2174      This doesn't work with GCC 4 any more for several reasons.  First, the
2175      gimplification process might need the creation of temporaries of this
2176      type, and the gimplifier ICEs on such attempts.  Second, the middle-end
2177      now relies on a different attribute for such cases (DECL_BY_REFERENCE on
2178      RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to
2179      be explicitly accounted for by the front-end in the function body.
2180
2181      We achieve the complete transformation in two steps:
2182
2183      1/ create_subprog_decl performs early attribute tweaks: it clears
2184         TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on
2185         the result decl.  The former ensures that the bit isn't set in the GCC
2186         tree saved for the function, so prevents ICEs on temporary creation.
2187         The latter we use here to trigger the rest of the processing.
2188
2189      2/ This function performs the type transformation on the result decl
2190         and adjusts all the references to this decl from the function body
2191         accordingly.
2192
2193      Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end
2194      strategy, which escapes the gimplifier temporary creation issues by
2195      creating it's own temporaries using TARGET_EXPR nodes.  Our way relies
2196      on simple specific support code in aggregate_value_p to look at the
2197      target function result decl explicitly.  */
2198
2199   struct pointer_set_t *p_set;
2200   tree decl_result = DECL_RESULT (fndecl);
2201
2202   if (!DECL_BY_REFERENCE (decl_result))
2203     return;
2204
2205   /* Make the DECL_RESULT explicitly by-reference and adjust all the
2206      occurrences in the function body using the common tree-walking facility.
2207      We want to see every occurrence of the result decl to adjust the
2208      referencing tree, so need to use our own pointer set to control which
2209      trees should be visited again or not.  */
2210
2211   p_set = pointer_set_create ();
2212
2213   TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result));
2214   TREE_ADDRESSABLE (decl_result) = 0;
2215   relayout_decl (decl_result);
2216
2217   walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL);
2218
2219   pointer_set_destroy (p_set);
2220 }
2221
2222 /* Finish the definition of the current subprogram BODY and compile it all the
2223    way to assembler language output.  ELAB_P tells if this is called for an
2224    elaboration routine, to be entirely discarded if empty.  */
2225
2226 void
2227 end_subprog_body (tree body, bool elab_p)
2228 {
2229   tree fndecl = current_function_decl;
2230
2231   /* Mark the BLOCK for this level as being for this function and pop the
2232      level.  Since the vars in it are the parameters, clear them.  */
2233   BLOCK_VARS (current_binding_level->block) = 0;
2234   BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
2235   DECL_INITIAL (fndecl) = current_binding_level->block;
2236   gnat_poplevel ();
2237
2238   /* We handle pending sizes via the elaboration of types, so we don't
2239      need to save them.  */
2240   get_pending_sizes ();
2241
2242   /* Mark the RESULT_DECL as being in this subprogram. */
2243   DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
2244
2245   DECL_SAVED_TREE (fndecl) = body;
2246
2247   current_function_decl = DECL_CONTEXT (fndecl);
2248   set_cfun (NULL);
2249
2250   /* We cannot track the location of errors past this point.  */
2251   error_gnat_node = Empty;
2252
2253   /* If we're only annotating types, don't actually compile this function.  */
2254   if (type_annotate_only)
2255     return;
2256
2257   /* Perform the required pre-gimplification transformations on the tree.  */
2258   gnat_genericize (fndecl);
2259
2260   /* We do different things for nested and non-nested functions.
2261      ??? This should be in cgraph.  */
2262   if (!DECL_CONTEXT (fndecl))
2263     {
2264       gnat_gimplify_function (fndecl);
2265
2266       /* If this is an empty elaboration proc, just discard the node.
2267          Otherwise, compile further.  */
2268       if (elab_p && empty_body_p (gimple_body (fndecl)))
2269         cgraph_remove_node (cgraph_node (fndecl));
2270       else
2271         cgraph_finalize_function (fndecl, false);
2272     }
2273   else
2274     /* Register this function with cgraph just far enough to get it
2275        added to our parent's nested function list.  */
2276     (void) cgraph_node (fndecl);
2277 }
2278
2279 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
2280
2281 static void
2282 gnat_gimplify_function (tree fndecl)
2283 {
2284   struct cgraph_node *cgn;
2285
2286   dump_function (TDI_original, fndecl);
2287   gimplify_function_tree (fndecl);
2288   dump_function (TDI_generic, fndecl);
2289
2290   /* Convert all nested functions to GIMPLE now.  We do things in this order
2291      so that items like VLA sizes are expanded properly in the context of the
2292      correct function.  */
2293   cgn = cgraph_node (fndecl);
2294   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
2295     gnat_gimplify_function (cgn->decl);
2296 }
2297 \f
2298
2299 tree
2300 gnat_builtin_function (tree decl)
2301 {
2302   gnat_pushdecl (decl, Empty);
2303   return decl;
2304 }
2305
2306 /* Return an integer type with the number of bits of precision given by
2307    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
2308    it is a signed type.  */
2309
2310 tree
2311 gnat_type_for_size (unsigned precision, int unsignedp)
2312 {
2313   tree t;
2314   char type_name[20];
2315
2316   if (precision <= 2 * MAX_BITS_PER_WORD
2317       && signed_and_unsigned_types[precision][unsignedp])
2318     return signed_and_unsigned_types[precision][unsignedp];
2319
2320  if (unsignedp)
2321     t = make_unsigned_type (precision);
2322   else
2323     t = make_signed_type (precision);
2324
2325   if (precision <= 2 * MAX_BITS_PER_WORD)
2326     signed_and_unsigned_types[precision][unsignedp] = t;
2327
2328   if (!TYPE_NAME (t))
2329     {
2330       sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
2331       TYPE_NAME (t) = get_identifier (type_name);
2332     }
2333
2334   return t;
2335 }
2336
2337 /* Likewise for floating-point types.  */
2338
2339 static tree
2340 float_type_for_precision (int precision, enum machine_mode mode)
2341 {
2342   tree t;
2343   char type_name[20];
2344
2345   if (float_types[(int) mode])
2346     return float_types[(int) mode];
2347
2348   float_types[(int) mode] = t = make_node (REAL_TYPE);
2349   TYPE_PRECISION (t) = precision;
2350   layout_type (t);
2351
2352   gcc_assert (TYPE_MODE (t) == mode);
2353   if (!TYPE_NAME (t))
2354     {
2355       sprintf (type_name, "FLOAT_%d", precision);
2356       TYPE_NAME (t) = get_identifier (type_name);
2357     }
2358
2359   return t;
2360 }
2361
2362 /* Return a data type that has machine mode MODE.  UNSIGNEDP selects
2363    an unsigned type; otherwise a signed type is returned.  */
2364
2365 tree
2366 gnat_type_for_mode (enum machine_mode mode, int unsignedp)
2367 {
2368   if (mode == BLKmode)
2369     return NULL_TREE;
2370   else if (mode == VOIDmode)
2371     return void_type_node;
2372   else if (COMPLEX_MODE_P (mode))
2373     return NULL_TREE;
2374   else if (SCALAR_FLOAT_MODE_P (mode))
2375     return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
2376   else if (SCALAR_INT_MODE_P (mode))
2377     return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
2378   else
2379     return NULL_TREE;
2380 }
2381
2382 /* Return the unsigned version of a TYPE_NODE, a scalar type.  */
2383
2384 tree
2385 gnat_unsigned_type (tree type_node)
2386 {
2387   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
2388
2389   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2390     {
2391       type = copy_node (type);
2392       TREE_TYPE (type) = type_node;
2393     }
2394   else if (TREE_TYPE (type_node)
2395            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2396            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2397     {
2398       type = copy_node (type);
2399       TREE_TYPE (type) = TREE_TYPE (type_node);
2400     }
2401
2402   return type;
2403 }
2404
2405 /* Return the signed version of a TYPE_NODE, a scalar type.  */
2406
2407 tree
2408 gnat_signed_type (tree type_node)
2409 {
2410   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
2411
2412   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2413     {
2414       type = copy_node (type);
2415       TREE_TYPE (type) = type_node;
2416     }
2417   else if (TREE_TYPE (type_node)
2418            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2419            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2420     {
2421       type = copy_node (type);
2422       TREE_TYPE (type) = TREE_TYPE (type_node);
2423     }
2424
2425   return type;
2426 }
2427
2428 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
2429    transparently converted to each other.  */
2430
2431 int
2432 gnat_types_compatible_p (tree t1, tree t2)
2433 {
2434   enum tree_code code;
2435
2436   /* This is the default criterion.  */
2437   if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
2438     return 1;
2439
2440   /* We only check structural equivalence here.  */
2441   if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
2442     return 0;
2443
2444   /* Array types are also compatible if they are constrained and have
2445      the same component type and the same domain.  */
2446   if (code == ARRAY_TYPE
2447       && TREE_TYPE (t1) == TREE_TYPE (t2)
2448       && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
2449           || (TYPE_DOMAIN (t1)
2450               && TYPE_DOMAIN (t2)      
2451               && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
2452                                      TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
2453               && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
2454                                      TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))))
2455     return 1;
2456
2457   /* Padding record types are also compatible if they pad the same
2458      type and have the same constant size.  */
2459   if (code == RECORD_TYPE
2460       && TYPE_IS_PADDING_P (t1) && TYPE_IS_PADDING_P (t2)
2461       && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
2462       && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
2463     return 1;
2464
2465   return 0;
2466 }
2467 \f
2468 /* EXP is an expression for the size of an object.  If this size contains
2469    discriminant references, replace them with the maximum (if MAX_P) or
2470    minimum (if !MAX_P) possible value of the discriminant.  */
2471
2472 tree
2473 max_size (tree exp, bool max_p)
2474 {
2475   enum tree_code code = TREE_CODE (exp);
2476   tree type = TREE_TYPE (exp);
2477
2478   switch (TREE_CODE_CLASS (code))
2479     {
2480     case tcc_declaration:
2481     case tcc_constant:
2482       return exp;
2483
2484     case tcc_vl_exp:
2485       if (code == CALL_EXPR)
2486         {
2487           tree *argarray;
2488           int i, n = call_expr_nargs (exp);
2489           gcc_assert (n > 0);
2490
2491           argarray = (tree *) alloca (n * sizeof (tree));
2492           for (i = 0; i < n; i++)
2493             argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
2494           return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
2495         }
2496       break;
2497
2498     case tcc_reference:
2499       /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2500          modify.  Otherwise, we treat it like a variable.  */
2501       if (!CONTAINS_PLACEHOLDER_P (exp))
2502         return exp;
2503
2504       type = TREE_TYPE (TREE_OPERAND (exp, 1));
2505       return
2506         max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
2507
2508     case tcc_comparison:
2509       return max_p ? size_one_node : size_zero_node;
2510
2511     case tcc_unary:
2512     case tcc_binary:
2513     case tcc_expression:
2514       switch (TREE_CODE_LENGTH (code))
2515         {
2516         case 1:
2517           if (code == NON_LVALUE_EXPR)
2518             return max_size (TREE_OPERAND (exp, 0), max_p);
2519           else
2520             return
2521               fold_build1 (code, type,
2522                            max_size (TREE_OPERAND (exp, 0),
2523                                      code == NEGATE_EXPR ? !max_p : max_p));
2524
2525         case 2:
2526           if (code == COMPOUND_EXPR)
2527             return max_size (TREE_OPERAND (exp, 1), max_p);
2528
2529           /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which
2530              may provide a tighter bound on max_size.  */
2531           if (code == MINUS_EXPR
2532               && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR)
2533             {
2534               tree lhs = fold_build2 (MINUS_EXPR, type,
2535                                       TREE_OPERAND (TREE_OPERAND (exp, 0), 1),
2536                                       TREE_OPERAND (exp, 1));
2537               tree rhs = fold_build2 (MINUS_EXPR, type,
2538                                       TREE_OPERAND (TREE_OPERAND (exp, 0), 2),
2539                                       TREE_OPERAND (exp, 1));
2540               return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2541                                   max_size (lhs, max_p),
2542                                   max_size (rhs, max_p));
2543             }
2544
2545           {
2546             tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2547             tree rhs = max_size (TREE_OPERAND (exp, 1),
2548                                  code == MINUS_EXPR ? !max_p : max_p);
2549
2550             /* Special-case wanting the maximum value of a MIN_EXPR.
2551                In that case, if one side overflows, return the other.
2552                sizetype is signed, but we know sizes are non-negative.
2553                Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2554                overflowing or the maximum possible value and the RHS
2555                a variable.  */
2556             if (max_p
2557                 && code == MIN_EXPR
2558                 && TREE_CODE (rhs) == INTEGER_CST
2559                 && TREE_OVERFLOW (rhs))
2560               return lhs;
2561             else if (max_p
2562                      && code == MIN_EXPR
2563                      && TREE_CODE (lhs) == INTEGER_CST
2564                      && TREE_OVERFLOW (lhs))
2565               return rhs;
2566             else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2567                      && ((TREE_CODE (lhs) == INTEGER_CST
2568                           && TREE_OVERFLOW (lhs))
2569                          || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
2570                      && !TREE_CONSTANT (rhs))
2571               return lhs;
2572             else
2573               return fold_build2 (code, type, lhs, rhs);
2574           }
2575
2576         case 3:
2577           if (code == SAVE_EXPR)
2578             return exp;
2579           else if (code == COND_EXPR)
2580             return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2581                                 max_size (TREE_OPERAND (exp, 1), max_p),
2582                                 max_size (TREE_OPERAND (exp, 2), max_p));
2583         }
2584
2585       /* Other tree classes cannot happen.  */
2586     default:
2587       break;
2588     }
2589
2590   gcc_unreachable ();
2591 }
2592 \f
2593 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2594    EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2595    Return a constructor for the template.  */
2596
2597 tree
2598 build_template (tree template_type, tree array_type, tree expr)
2599 {
2600   tree template_elts = NULL_TREE;
2601   tree bound_list = NULL_TREE;
2602   tree field;
2603
2604   while (TREE_CODE (array_type) == RECORD_TYPE
2605          && (TYPE_IS_PADDING_P (array_type)
2606              || TYPE_JUSTIFIED_MODULAR_P (array_type)))
2607     array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2608
2609   if (TREE_CODE (array_type) == ARRAY_TYPE
2610       || (TREE_CODE (array_type) == INTEGER_TYPE
2611           && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2612     bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2613
2614   /* First make the list for a CONSTRUCTOR for the template.  Go down the
2615      field list of the template instead of the type chain because this
2616      array might be an Ada array of arrays and we can't tell where the
2617      nested arrays stop being the underlying object.  */
2618
2619   for (field = TYPE_FIELDS (template_type); field;
2620        (bound_list
2621         ? (bound_list = TREE_CHAIN (bound_list))
2622         : (array_type = TREE_TYPE (array_type))),
2623        field = TREE_CHAIN (TREE_CHAIN (field)))
2624     {
2625       tree bounds, min, max;
2626
2627       /* If we have a bound list, get the bounds from there.  Likewise
2628          for an ARRAY_TYPE.  Otherwise, if expr is a PARM_DECL with
2629          DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2630          This will give us a maximum range.  */
2631       if (bound_list)
2632         bounds = TREE_VALUE (bound_list);
2633       else if (TREE_CODE (array_type) == ARRAY_TYPE)
2634         bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2635       else if (expr && TREE_CODE (expr) == PARM_DECL
2636                && DECL_BY_COMPONENT_PTR_P (expr))
2637         bounds = TREE_TYPE (field);
2638       else
2639         gcc_unreachable ();
2640
2641       min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
2642       max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds));
2643
2644       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2645          substitute it from OBJECT.  */
2646       min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
2647       max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
2648
2649       template_elts = tree_cons (TREE_CHAIN (field), max,
2650                                  tree_cons (field, min, template_elts));
2651     }
2652
2653   return gnat_build_constructor (template_type, nreverse (template_elts));
2654 }
2655 \f
2656 /* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
2657    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2658    in the type contains in its DECL_INITIAL the expression to use when
2659    a constructor is made for the type.  GNAT_ENTITY is an entity used
2660    to print out an error message if the mechanism cannot be applied to
2661    an object of that type and also for the name.  */
2662
2663 tree
2664 build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2665 {
2666   tree record_type = make_node (RECORD_TYPE);
2667   tree pointer32_type;
2668   tree field_list = 0;
2669   int class;
2670   int dtype = 0;
2671   tree inner_type;
2672   int ndim;
2673   int i;
2674   tree *idx_arr;
2675   tree tem;
2676
2677   /* If TYPE is an unconstrained array, use the underlying array type.  */
2678   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2679     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2680
2681   /* If this is an array, compute the number of dimensions in the array,
2682      get the index types, and point to the inner type.  */
2683   if (TREE_CODE (type) != ARRAY_TYPE)
2684     ndim = 0;
2685   else
2686     for (ndim = 1, inner_type = type;
2687          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2688          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2689          ndim++, inner_type = TREE_TYPE (inner_type))
2690       ;
2691
2692   idx_arr = (tree *) alloca (ndim * sizeof (tree));
2693
2694   if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
2695       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2696     for (i = ndim - 1, inner_type = type;
2697          i >= 0;
2698          i--, inner_type = TREE_TYPE (inner_type))
2699       idx_arr[i] = TYPE_DOMAIN (inner_type);
2700   else
2701     for (i = 0, inner_type = type;
2702          i < ndim;
2703          i++, inner_type = TREE_TYPE (inner_type))
2704       idx_arr[i] = TYPE_DOMAIN (inner_type);
2705
2706   /* Now get the DTYPE value.  */
2707   switch (TREE_CODE (type))
2708     {
2709     case INTEGER_TYPE:
2710     case ENUMERAL_TYPE:
2711     case BOOLEAN_TYPE:
2712       if (TYPE_VAX_FLOATING_POINT_P (type))
2713         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2714           {
2715           case 6:
2716             dtype = 10;
2717             break;
2718           case 9:
2719             dtype = 11;
2720             break;
2721           case 15:
2722             dtype = 27;
2723             break;
2724           }
2725       else
2726         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2727           {
2728           case 8:
2729             dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2730             break;
2731           case 16:
2732             dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2733             break;
2734           case 32:
2735             dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2736             break;
2737           case 64:
2738             dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2739             break;
2740           case 128:
2741             dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2742             break;
2743           }
2744       break;
2745
2746     case REAL_TYPE:
2747       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2748       break;
2749
2750     case COMPLEX_TYPE:
2751       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2752           && TYPE_VAX_FLOATING_POINT_P (type))
2753         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2754           {
2755           case 6:
2756             dtype = 12;
2757             break;
2758           case 9:
2759             dtype = 13;
2760             break;
2761           case 15:
2762             dtype = 29;
2763           }
2764       else
2765         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2766       break;
2767
2768     case ARRAY_TYPE:
2769       dtype = 14;
2770       break;
2771
2772     default:
2773       break;
2774     }
2775
2776   /* Get the CLASS value.  */
2777   switch (mech)
2778     {
2779     case By_Descriptor_A:
2780     case By_Short_Descriptor_A:
2781       class = 4;
2782       break;
2783     case By_Descriptor_NCA:
2784     case By_Short_Descriptor_NCA:
2785       class = 10;
2786       break;
2787     case By_Descriptor_SB:
2788     case By_Short_Descriptor_SB:
2789       class = 15;
2790       break;
2791     case By_Descriptor:
2792     case By_Short_Descriptor:
2793     case By_Descriptor_S:
2794     case By_Short_Descriptor_S:
2795     default:
2796       class = 1;
2797       break;
2798     }
2799
2800   /* Make the type for a descriptor for VMS.  The first four fields
2801      are the same for all types.  */
2802
2803   field_list
2804     = chainon (field_list,
2805                make_descriptor_field
2806                ("LENGTH", gnat_type_for_size (16, 1), record_type,
2807                 size_in_bytes ((mech == By_Descriptor_A ||
2808                                 mech == By_Short_Descriptor_A)
2809                                ? inner_type : type)));
2810
2811   field_list = chainon (field_list,
2812                         make_descriptor_field ("DTYPE",
2813                                                gnat_type_for_size (8, 1),
2814                                                record_type, size_int (dtype)));
2815   field_list = chainon (field_list,
2816                         make_descriptor_field ("CLASS",
2817                                                gnat_type_for_size (8, 1),
2818                                                record_type, size_int (class)));
2819
2820   /* Of course this will crash at run-time if the address space is not
2821      within the low 32 bits, but there is nothing else we can do.  */
2822   pointer32_type = build_pointer_type_for_mode (type, SImode, false);
2823
2824   field_list
2825     = chainon (field_list,
2826                make_descriptor_field
2827                ("POINTER", pointer32_type, record_type,
2828                 build_unary_op (ADDR_EXPR,
2829                                 pointer32_type,
2830                                 build0 (PLACEHOLDER_EXPR, type))));
2831
2832   switch (mech)
2833     {
2834     case By_Descriptor:
2835     case By_Short_Descriptor:
2836     case By_Descriptor_S:
2837     case By_Short_Descriptor_S:
2838       break;
2839
2840     case By_Descriptor_SB:
2841     case By_Short_Descriptor_SB:
2842       field_list
2843         = chainon (field_list,
2844                    make_descriptor_field
2845                    ("SB_L1", gnat_type_for_size (32, 1), record_type,
2846                     TREE_CODE (type) == ARRAY_TYPE
2847                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2848       field_list
2849         = chainon (field_list,
2850                    make_descriptor_field
2851                    ("SB_U1", gnat_type_for_size (32, 1), record_type,
2852                     TREE_CODE (type) == ARRAY_TYPE
2853                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2854       break;
2855
2856     case By_Descriptor_A:
2857     case By_Short_Descriptor_A:
2858     case By_Descriptor_NCA:
2859     case By_Short_Descriptor_NCA:
2860       field_list = chainon (field_list,
2861                             make_descriptor_field ("SCALE",
2862                                                    gnat_type_for_size (8, 1),
2863                                                    record_type,
2864                                                    size_zero_node));
2865
2866       field_list = chainon (field_list,
2867                             make_descriptor_field ("DIGITS",
2868                                                    gnat_type_for_size (8, 1),
2869                                                    record_type,
2870                                                    size_zero_node));
2871
2872       field_list
2873         = chainon (field_list,
2874                    make_descriptor_field
2875                    ("AFLAGS", gnat_type_for_size (8, 1), record_type,
2876                     size_int ((mech == By_Descriptor_NCA ||
2877                               mech == By_Short_Descriptor_NCA)
2878                               ? 0
2879                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
2880                               : (TREE_CODE (type) == ARRAY_TYPE
2881                                  && TYPE_CONVENTION_FORTRAN_P (type)
2882                                  ? 224 : 192))));
2883
2884       field_list = chainon (field_list,
2885                             make_descriptor_field ("DIMCT",
2886                                                    gnat_type_for_size (8, 1),
2887                                                    record_type,
2888                                                    size_int (ndim)));
2889
2890       field_list = chainon (field_list,
2891                             make_descriptor_field ("ARSIZE",
2892                                                    gnat_type_for_size (32, 1),
2893                                                    record_type,
2894                                                    size_in_bytes (type)));
2895
2896       /* Now build a pointer to the 0,0,0... element.  */
2897       tem = build0 (PLACEHOLDER_EXPR, type);
2898       for (i = 0, inner_type = type; i < ndim;
2899            i++, inner_type = TREE_TYPE (inner_type))
2900         tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2901                       convert (TYPE_DOMAIN (inner_type), size_zero_node),
2902                       NULL_TREE, NULL_TREE);
2903
2904       field_list
2905         = chainon (field_list,
2906                    make_descriptor_field
2907                    ("A0",
2908                     build_pointer_type_for_mode (inner_type, SImode, false),
2909                     record_type,
2910                     build1 (ADDR_EXPR,
2911                             build_pointer_type_for_mode (inner_type, SImode,
2912                                                          false),
2913                             tem)));
2914
2915       /* Next come the addressing coefficients.  */
2916       tem = size_one_node;
2917       for (i = 0; i < ndim; i++)
2918         {
2919           char fname[3];
2920           tree idx_length
2921             = size_binop (MULT_EXPR, tem,
2922                           size_binop (PLUS_EXPR,
2923                                       size_binop (MINUS_EXPR,
2924                                                   TYPE_MAX_VALUE (idx_arr[i]),
2925                                                   TYPE_MIN_VALUE (idx_arr[i])),
2926                                       size_int (1)));
2927
2928           fname[0] = ((mech == By_Descriptor_NCA ||
2929                        mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
2930           fname[1] = '0' + i, fname[2] = 0;
2931           field_list
2932             = chainon (field_list,
2933                        make_descriptor_field (fname,
2934                                               gnat_type_for_size (32, 1),
2935                                               record_type, idx_length));
2936
2937           if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
2938             tem = idx_length;
2939         }
2940
2941       /* Finally here are the bounds.  */
2942       for (i = 0; i < ndim; i++)
2943         {
2944           char fname[3];
2945
2946           fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2947           field_list
2948             = chainon (field_list,
2949                        make_descriptor_field
2950                        (fname, gnat_type_for_size (32, 1), record_type,
2951                         TYPE_MIN_VALUE (idx_arr[i])));
2952
2953           fname[0] = 'U';
2954           field_list
2955             = chainon (field_list,
2956                        make_descriptor_field
2957                        (fname, gnat_type_for_size (32, 1), record_type,
2958                         TYPE_MAX_VALUE (idx_arr[i])));
2959         }
2960       break;
2961
2962     default:
2963       post_error ("unsupported descriptor type for &", gnat_entity);
2964     }
2965
2966   finish_record_type (record_type, field_list, 0, true);
2967   create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
2968                     NULL, true, false, gnat_entity);
2969
2970   return record_type;
2971 }
2972
2973 /* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
2974    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2975    in the type contains in its DECL_INITIAL the expression to use when
2976    a constructor is made for the type.  GNAT_ENTITY is an entity used
2977    to print out an error message if the mechanism cannot be applied to
2978    an object of that type and also for the name.  */
2979
2980 tree
2981 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2982 {
2983   tree record64_type = make_node (RECORD_TYPE);
2984   tree pointer64_type;
2985   tree field_list64 = 0;
2986   int class;
2987   int dtype = 0;
2988   tree inner_type;
2989   int ndim;
2990   int i;
2991   tree *idx_arr;
2992   tree tem;
2993
2994   /* If TYPE is an unconstrained array, use the underlying array type.  */
2995   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2996     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2997
2998   /* If this is an array, compute the number of dimensions in the array,
2999      get the index types, and point to the inner type.  */
3000   if (TREE_CODE (type) != ARRAY_TYPE)
3001     ndim = 0;
3002   else
3003     for (ndim = 1, inner_type = type;
3004          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
3005          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
3006          ndim++, inner_type = TREE_TYPE (inner_type))
3007       ;
3008
3009   idx_arr = (tree *) alloca (ndim * sizeof (tree));
3010
3011   if (mech != By_Descriptor_NCA
3012       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
3013     for (i = ndim - 1, inner_type = type;
3014          i >= 0;
3015          i--, inner_type = TREE_TYPE (inner_type))
3016       idx_arr[i] = TYPE_DOMAIN (inner_type);
3017   else
3018     for (i = 0, inner_type = type;
3019          i < ndim;
3020          i++, inner_type = TREE_TYPE (inner_type))
3021       idx_arr[i] = TYPE_DOMAIN (inner_type);
3022
3023   /* Now get the DTYPE value.  */
3024   switch (TREE_CODE (type))
3025     {
3026     case INTEGER_TYPE:
3027     case ENUMERAL_TYPE:
3028     case BOOLEAN_TYPE:
3029       if (TYPE_VAX_FLOATING_POINT_P (type))
3030         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
3031           {
3032           case 6:
3033             dtype = 10;
3034             break;
3035           case 9:
3036             dtype = 11;
3037             break;
3038           case 15:
3039             dtype = 27;
3040             break;
3041           }
3042       else
3043         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
3044           {
3045           case 8:
3046             dtype = TYPE_UNSIGNED (type) ? 2 : 6;
3047             break;
3048           case 16:
3049             dtype = TYPE_UNSIGNED (type) ? 3 : 7;
3050             break;
3051           case 32:
3052             dtype = TYPE_UNSIGNED (type) ? 4 : 8;
3053             break;
3054           case 64:
3055             dtype = TYPE_UNSIGNED (type) ? 5 : 9;
3056             break;
3057           case 128:
3058             dtype = TYPE_UNSIGNED (type) ? 25 : 26;
3059             break;
3060           }
3061       break;
3062
3063     case REAL_TYPE:
3064       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
3065       break;
3066
3067     case COMPLEX_TYPE:
3068       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
3069           && TYPE_VAX_FLOATING_POINT_P (type))
3070         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
3071           {
3072           case 6:
3073             dtype = 12;
3074             break;
3075           case 9:
3076             dtype = 13;
3077             break;
3078           case 15:
3079             dtype = 29;
3080           }
3081       else
3082         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
3083       break;
3084
3085     case ARRAY_TYPE:
3086       dtype = 14;
3087       break;
3088
3089     default:
3090       break;
3091     }
3092
3093   /* Get the CLASS value.  */
3094   switch (mech)
3095     {
3096     case By_Descriptor_A:
3097       class = 4;
3098       break;
3099     case By_Descriptor_NCA:
3100       class = 10;
3101       break;
3102     case By_Descriptor_SB:
3103       class = 15;
3104       break;
3105     case By_Descriptor:
3106     case By_Descriptor_S:
3107     default:
3108       class = 1;
3109       break;
3110     }
3111
3112   /* Make the type for a 64bit descriptor for VMS.  The first six fields
3113      are the same for all types.  */
3114
3115   field_list64 = chainon (field_list64,
3116                         make_descriptor_field ("MBO",
3117                                                gnat_type_for_size (16, 1),
3118                                                record64_type, size_int (1)));
3119
3120   field_list64 = chainon (field_list64,
3121                         make_descriptor_field ("DTYPE",
3122                                                gnat_type_for_size (8, 1),
3123                                                record64_type, size_int (dtype)));
3124   field_list64 = chainon (field_list64,
3125                         make_descriptor_field ("CLASS",
3126                                                gnat_type_for_size (8, 1),
3127                                                record64_type, size_int (class)));
3128
3129   field_list64 = chainon (field_list64,
3130                         make_descriptor_field ("MBMO",
3131                                                gnat_type_for_size (32, 1),
3132                                                record64_type, ssize_int (-1)));
3133
3134   field_list64
3135     = chainon (field_list64,
3136                make_descriptor_field
3137                ("LENGTH", gnat_type_for_size (64, 1), record64_type,
3138                 size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
3139
3140   pointer64_type = build_pointer_type_for_mode (type, DImode, false);
3141
3142   field_list64
3143     = chainon (field_list64,
3144                make_descriptor_field
3145                ("POINTER", pointer64_type, record64_type,
3146                 build_unary_op (ADDR_EXPR,
3147                                 pointer64_type,
3148                                 build0 (PLACEHOLDER_EXPR, type))));
3149
3150   switch (mech)
3151     {
3152     case By_Descriptor:
3153     case By_Descriptor_S:
3154       break;
3155
3156     case By_Descriptor_SB:
3157       field_list64
3158         = chainon (field_list64,
3159                    make_descriptor_field
3160                    ("SB_L1", gnat_type_for_size (64, 1), record64_type,
3161                     TREE_CODE (type) == ARRAY_TYPE
3162                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
3163       field_list64
3164         = chainon (field_list64,
3165                    make_descriptor_field
3166                    ("SB_U1", gnat_type_for_size (64, 1), record64_type,
3167                     TREE_CODE (type) == ARRAY_TYPE
3168                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
3169       break;
3170
3171     case By_Descriptor_A:
3172     case By_Descriptor_NCA:
3173       field_list64 = chainon (field_list64,
3174                             make_descriptor_field ("SCALE",
3175                                                    gnat_type_for_size (8, 1),
3176                                                    record64_type,
3177                                                    size_zero_node));
3178
3179       field_list64 = chainon (field_list64,
3180                             make_descriptor_field ("DIGITS",
3181                                                    gnat_type_for_size (8, 1),
3182                                                    record64_type,
3183                                                    size_zero_node));
3184
3185       field_list64
3186         = chainon (field_list64,
3187                    make_descriptor_field
3188                    ("AFLAGS", gnat_type_for_size (8, 1), record64_type,
3189                     size_int (mech == By_Descriptor_NCA
3190                               ? 0
3191                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
3192                               : (TREE_CODE (type) == ARRAY_TYPE
3193                                  && TYPE_CONVENTION_FORTRAN_P (type)
3194                                  ? 224 : 192))));
3195
3196       field_list64 = chainon (field_list64,
3197                             make_descriptor_field ("DIMCT",
3198                                                    gnat_type_for_size (8, 1),
3199                                                    record64_type,
3200                                                    size_int (ndim)));
3201
3202       field_list64 = chainon (field_list64,
3203                             make_descriptor_field ("MBZ",
3204                                                    gnat_type_for_size (32, 1),
3205                                                    record64_type,
3206                                                    size_int (0)));
3207       field_list64 = chainon (field_list64,
3208                             make_descriptor_field ("ARSIZE",
3209                                                    gnat_type_for_size (64, 1),
3210                                                    record64_type,
3211                                                    size_in_bytes (type)));
3212
3213       /* Now build a pointer to the 0,0,0... element.  */
3214       tem = build0 (PLACEHOLDER_EXPR, type);
3215       for (i = 0, inner_type = type; i < ndim;
3216            i++, inner_type = TREE_TYPE (inner_type))
3217         tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
3218                       convert (TYPE_DOMAIN (inner_type), size_zero_node),
3219                       NULL_TREE, NULL_TREE);
3220
3221       field_list64
3222         = chainon (field_list64,
3223                    make_descriptor_field
3224                    ("A0",
3225                     build_pointer_type_for_mode (inner_type, DImode, false),
3226                     record64_type,
3227                     build1 (ADDR_EXPR,
3228                             build_pointer_type_for_mode (inner_type, DImode,
3229                                                          false),
3230                             tem)));