OSDN Git Service

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