OSDN Git Service

38795a0cea60bd13e64f61ddeab7dfd85cc07d7d
[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
1391   /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
1392      try to fiddle with DECL_COMMON.  However, on platforms that don't
1393      support global BSS sections, uninitialized global variables would
1394      go in DATA instead, thus increasing the size of the executable.  */
1395   if (!flag_no_common
1396       && TREE_CODE (var_decl) == VAR_DECL
1397       && !have_global_bss_p ())
1398     DECL_COMMON (var_decl) = 1;
1399   DECL_INITIAL  (var_decl) = var_init;
1400   TREE_READONLY (var_decl) = const_flag;
1401   DECL_EXTERNAL (var_decl) = extern_flag;
1402   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
1403   TREE_CONSTANT (var_decl) = constant_p;
1404   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
1405     = TYPE_VOLATILE (type);
1406
1407   /* If it's public and not external, always allocate storage for it.
1408      At the global binding level we need to allocate static storage for the
1409      variable if and only if it's not external. If we are not at the top level
1410      we allocate automatic storage unless requested not to.  */
1411   TREE_STATIC (var_decl)
1412     = !extern_flag && (public_flag || static_flag || global_bindings_p ());
1413
1414   /* For an external constant whose initializer is not absolute, do not emit
1415      debug info.  In DWARF this would mean a global relocation in a read-only
1416      section which runs afoul of the PE-COFF runtime relocation mechanism.  */
1417   if (extern_flag
1418       && constant_p
1419       && initializer_constant_valid_p (var_init, TREE_TYPE (var_init))
1420            != null_pointer_node)
1421     DECL_IGNORED_P (var_decl) = 1;
1422
1423   if (TREE_CODE (var_decl) == VAR_DECL)
1424     {
1425       if (asm_name)
1426         SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
1427       process_attributes (var_decl, attr_list);
1428     }
1429
1430   /* Add this decl to the current binding level.  */
1431   gnat_pushdecl (var_decl, gnat_node);
1432
1433   if (TREE_SIDE_EFFECTS (var_decl))
1434     TREE_ADDRESSABLE (var_decl) = 1;
1435
1436   if (TREE_CODE (var_decl) != CONST_DECL)
1437     {
1438       if (global_bindings_p ())
1439         rest_of_decl_compilation (var_decl, true, 0);
1440     }
1441   else
1442     expand_decl (var_decl);
1443
1444   return var_decl;
1445 }
1446 \f
1447 /* Return true if TYPE, an aggregate type, contains (or is) an array.  */
1448
1449 static bool
1450 aggregate_type_contains_array_p (tree type)
1451 {
1452   switch (TREE_CODE (type))
1453     {
1454     case RECORD_TYPE:
1455     case UNION_TYPE:
1456     case QUAL_UNION_TYPE:
1457       {
1458         tree field;
1459         for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
1460           if (AGGREGATE_TYPE_P (TREE_TYPE (field))
1461               && aggregate_type_contains_array_p (TREE_TYPE (field)))
1462             return true;
1463         return false;
1464       }
1465
1466     case ARRAY_TYPE:
1467       return true;
1468
1469     default:
1470       gcc_unreachable ();
1471     }
1472 }
1473
1474 /* Return a FIELD_DECL node.  FIELD_NAME is the field's name, FIELD_TYPE is
1475    its type and RECORD_TYPE is the type of the enclosing record.  PACKED is
1476    1 if the enclosing record is packed, -1 if it has Component_Alignment of
1477    Storage_Unit.  If SIZE is nonzero, it is the specified size of the field.
1478    If POS is nonzero, it is the bit position.  If ADDRESSABLE is nonzero, it
1479    means we are allowed to take the address of the field; if it is negative,
1480    we should not make a bitfield, which is used by make_aligning_type.  */
1481
1482 tree
1483 create_field_decl (tree field_name, tree field_type, tree record_type,
1484                    int packed, tree size, tree pos, int addressable)
1485 {
1486   tree field_decl = build_decl (input_location,
1487                                 FIELD_DECL, field_name, field_type);
1488
1489   DECL_CONTEXT (field_decl) = record_type;
1490   TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
1491
1492   /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
1493      byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
1494      Likewise for an aggregate without specified position that contains an
1495      array, because in this case slices of variable length of this array
1496      must be handled by GCC and variable-sized objects need to be aligned
1497      to at least a byte boundary.  */
1498   if (packed && (TYPE_MODE (field_type) == BLKmode
1499                  || (!pos
1500                      && AGGREGATE_TYPE_P (field_type)
1501                      && aggregate_type_contains_array_p (field_type))))
1502     DECL_ALIGN (field_decl) = BITS_PER_UNIT;
1503
1504   /* If a size is specified, use it.  Otherwise, if the record type is packed
1505      compute a size to use, which may differ from the object's natural size.
1506      We always set a size in this case to trigger the checks for bitfield
1507      creation below, which is typically required when no position has been
1508      specified.  */
1509   if (size)
1510     size = convert (bitsizetype, size);
1511   else if (packed == 1)
1512     {
1513       size = rm_size (field_type);
1514       if (TYPE_MODE (field_type) == BLKmode)
1515         size = round_up (size, BITS_PER_UNIT);
1516     }
1517
1518   /* If we may, according to ADDRESSABLE, make a bitfield if a size is
1519      specified for two reasons: first if the size differs from the natural
1520      size.  Second, if the alignment is insufficient.  There are a number of
1521      ways the latter can be true.
1522
1523      We never make a bitfield if the type of the field has a nonconstant size,
1524      because no such entity requiring bitfield operations should reach here.
1525
1526      We do *preventively* make a bitfield when there might be the need for it
1527      but we don't have all the necessary information to decide, as is the case
1528      of a field with no specified position in a packed record.
1529
1530      We also don't look at STRICT_ALIGNMENT here, and rely on later processing
1531      in layout_decl or finish_record_type to clear the bit_field indication if
1532      it is in fact not needed.  */
1533   if (addressable >= 0
1534       && size
1535       && TREE_CODE (size) == INTEGER_CST
1536       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
1537       && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
1538           || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
1539           || packed
1540           || (TYPE_ALIGN (record_type) != 0
1541               && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
1542     {
1543       DECL_BIT_FIELD (field_decl) = 1;
1544       DECL_SIZE (field_decl) = size;
1545       if (!packed && !pos)
1546         {
1547           if (TYPE_ALIGN (record_type) != 0
1548               && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))
1549             DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type);
1550           else
1551             DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1552         }
1553     }
1554
1555   DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
1556
1557   /* Bump the alignment if need be, either for bitfield/packing purposes or
1558      to satisfy the type requirements if no such consideration applies.  When
1559      we get the alignment from the type, indicate if this is from an explicit
1560      user request, which prevents stor-layout from lowering it later on.  */
1561   {
1562     unsigned int bit_align
1563       = (DECL_BIT_FIELD (field_decl) ? 1
1564          : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
1565
1566     if (bit_align > DECL_ALIGN (field_decl))
1567       DECL_ALIGN (field_decl) = bit_align;
1568     else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
1569       {
1570         DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
1571         DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
1572       }
1573   }
1574
1575   if (pos)
1576     {
1577       /* We need to pass in the alignment the DECL is known to have.
1578          This is the lowest-order bit set in POS, but no more than
1579          the alignment of the record, if one is specified.  Note
1580          that an alignment of 0 is taken as infinite.  */
1581       unsigned int known_align;
1582
1583       if (host_integerp (pos, 1))
1584         known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
1585       else
1586         known_align = BITS_PER_UNIT;
1587
1588       if (TYPE_ALIGN (record_type)
1589           && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
1590         known_align = TYPE_ALIGN (record_type);
1591
1592       layout_decl (field_decl, known_align);
1593       SET_DECL_OFFSET_ALIGN (field_decl,
1594                              host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
1595                              : BITS_PER_UNIT);
1596       pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
1597                     &DECL_FIELD_BIT_OFFSET (field_decl),
1598                     DECL_OFFSET_ALIGN (field_decl), pos);
1599     }
1600
1601   /* In addition to what our caller says, claim the field is addressable if we
1602      know that its type is not suitable.
1603
1604      The field may also be "technically" nonaddressable, meaning that even if
1605      we attempt to take the field's address we will actually get the address
1606      of a copy.  This is the case for true bitfields, but the DECL_BIT_FIELD
1607      value we have at this point is not accurate enough, so we don't account
1608      for this here and let finish_record_type decide.  */
1609   if (!addressable && !type_for_nonaliased_component_p (field_type))
1610     addressable = 1;
1611
1612   DECL_NONADDRESSABLE_P (field_decl) = !addressable;
1613
1614   return field_decl;
1615 }
1616 \f
1617 /* Return a PARM_DECL node.  PARAM_NAME is the name of the parameter and
1618    PARAM_TYPE is its type.  READONLY is true if the parameter is readonly
1619    (either an In parameter or an address of a pass-by-ref parameter).  */
1620
1621 tree
1622 create_param_decl (tree param_name, tree param_type, bool readonly)
1623 {
1624   tree param_decl = build_decl (input_location,
1625                                 PARM_DECL, param_name, param_type);
1626
1627   /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
1628      can lead to various ABI violations.  */
1629   if (targetm.calls.promote_prototypes (NULL_TREE)
1630       && INTEGRAL_TYPE_P (param_type)
1631       && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
1632     {
1633       /* We have to be careful about biased types here.  Make a subtype
1634          of integer_type_node with the proper biasing.  */
1635       if (TREE_CODE (param_type) == INTEGER_TYPE
1636           && TYPE_BIASED_REPRESENTATION_P (param_type))
1637         {
1638           tree subtype
1639             = make_unsigned_type (TYPE_PRECISION (integer_type_node));
1640           TREE_TYPE (subtype) = integer_type_node;
1641           TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
1642           SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type));
1643           SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type));
1644           param_type = subtype;
1645         }
1646       else
1647         param_type = integer_type_node;
1648     }
1649
1650   DECL_ARG_TYPE (param_decl) = param_type;
1651   TREE_READONLY (param_decl) = readonly;
1652   return param_decl;
1653 }
1654 \f
1655 /* Given a DECL and ATTR_LIST, process the listed attributes.  */
1656
1657 void
1658 process_attributes (tree decl, struct attrib *attr_list)
1659 {
1660   for (; attr_list; attr_list = attr_list->next)
1661     switch (attr_list->type)
1662       {
1663       case ATTR_MACHINE_ATTRIBUTE:
1664         decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
1665                                            NULL_TREE),
1666                          ATTR_FLAG_TYPE_IN_PLACE);
1667         break;
1668
1669       case ATTR_LINK_ALIAS:
1670         if (! DECL_EXTERNAL (decl))
1671           {
1672             TREE_STATIC (decl) = 1;
1673             assemble_alias (decl, attr_list->name);
1674           }
1675         break;
1676
1677       case ATTR_WEAK_EXTERNAL:
1678         if (SUPPORTS_WEAK)
1679           declare_weak (decl);
1680         else
1681           post_error ("?weak declarations not supported on this target",
1682                       attr_list->error_point);
1683         break;
1684
1685       case ATTR_LINK_SECTION:
1686         if (targetm.have_named_sections)
1687           {
1688             DECL_SECTION_NAME (decl)
1689               = build_string (IDENTIFIER_LENGTH (attr_list->name),
1690                               IDENTIFIER_POINTER (attr_list->name));
1691             DECL_COMMON (decl) = 0;
1692           }
1693         else
1694           post_error ("?section attributes are not supported for this target",
1695                       attr_list->error_point);
1696         break;
1697
1698       case ATTR_LINK_CONSTRUCTOR:
1699         DECL_STATIC_CONSTRUCTOR (decl) = 1;
1700         TREE_USED (decl) = 1;
1701         break;
1702
1703       case ATTR_LINK_DESTRUCTOR:
1704         DECL_STATIC_DESTRUCTOR (decl) = 1;
1705         TREE_USED (decl) = 1;
1706         break;
1707
1708       case ATTR_THREAD_LOCAL_STORAGE:
1709         DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1710         DECL_COMMON (decl) = 0;
1711         break;
1712       }
1713 }
1714 \f
1715 /* Record DECL as a global renaming pointer.  */
1716
1717 void
1718 record_global_renaming_pointer (tree decl)
1719 {
1720   gcc_assert (DECL_RENAMED_OBJECT (decl));
1721   VEC_safe_push (tree, gc, global_renaming_pointers, decl);
1722 }
1723
1724 /* Invalidate the global renaming pointers.   */
1725
1726 void
1727 invalidate_global_renaming_pointers (void)
1728 {
1729   unsigned int i;
1730   tree iter;
1731
1732   for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++)
1733     SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
1734
1735   VEC_free (tree, gc, global_renaming_pointers);
1736 }
1737
1738 /* Return true if VALUE is a known to be a multiple of FACTOR, which must be
1739    a power of 2. */
1740
1741 bool
1742 value_factor_p (tree value, HOST_WIDE_INT factor)
1743 {
1744   if (host_integerp (value, 1))
1745     return tree_low_cst (value, 1) % factor == 0;
1746
1747   if (TREE_CODE (value) == MULT_EXPR)
1748     return (value_factor_p (TREE_OPERAND (value, 0), factor)
1749             || value_factor_p (TREE_OPERAND (value, 1), factor));
1750
1751   return false;
1752 }
1753
1754 /* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
1755    unless we can prove these 2 fields are laid out in such a way that no gap
1756    exist between the end of PREV_FIELD and the beginning of CURR_FIELD.  OFFSET
1757    is the distance in bits between the end of PREV_FIELD and the starting
1758    position of CURR_FIELD. It is ignored if null. */
1759
1760 static bool
1761 potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
1762 {
1763   /* If this is the first field of the record, there cannot be any gap */
1764   if (!prev_field)
1765     return false;
1766
1767   /* If the previous field is a union type, then return False: The only
1768      time when such a field is not the last field of the record is when
1769      there are other components at fixed positions after it (meaning there
1770      was a rep clause for every field), in which case we don't want the
1771      alignment constraint to override them. */
1772   if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
1773     return false;
1774
1775   /* If the distance between the end of prev_field and the beginning of
1776      curr_field is constant, then there is a gap if the value of this
1777      constant is not null. */
1778   if (offset && host_integerp (offset, 1))
1779     return !integer_zerop (offset);
1780
1781   /* If the size and position of the previous field are constant,
1782      then check the sum of this size and position. There will be a gap
1783      iff it is not multiple of the current field alignment. */
1784   if (host_integerp (DECL_SIZE (prev_field), 1)
1785       && host_integerp (bit_position (prev_field), 1))
1786     return ((tree_low_cst (bit_position (prev_field), 1)
1787              + tree_low_cst (DECL_SIZE (prev_field), 1))
1788             % DECL_ALIGN (curr_field) != 0);
1789
1790   /* If both the position and size of the previous field are multiples
1791      of the current field alignment, there cannot be any gap. */
1792   if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
1793       && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
1794     return false;
1795
1796   /* Fallback, return that there may be a potential gap */
1797   return true;
1798 }
1799
1800 /* Returns a LABEL_DECL node for LABEL_NAME.  */
1801
1802 tree
1803 create_label_decl (tree label_name)
1804 {
1805   tree label_decl = build_decl (input_location,
1806                                 LABEL_DECL, label_name, void_type_node);
1807
1808   DECL_CONTEXT (label_decl)     = current_function_decl;
1809   DECL_MODE (label_decl)        = VOIDmode;
1810   DECL_SOURCE_LOCATION (label_decl) = input_location;
1811
1812   return label_decl;
1813 }
1814 \f
1815 /* Returns a FUNCTION_DECL node.  SUBPROG_NAME is the name of the subprogram,
1816    ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
1817    node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
1818    PARM_DECL nodes chained through the TREE_CHAIN field).
1819
1820    INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
1821    appropriate fields in the FUNCTION_DECL.  GNAT_NODE gives the location.  */
1822
1823 tree
1824 create_subprog_decl (tree subprog_name, tree asm_name,
1825                      tree subprog_type, tree param_decl_list, bool inline_flag,
1826                      bool public_flag, bool extern_flag,
1827                      struct attrib *attr_list, Node_Id gnat_node)
1828 {
1829   tree return_type  = TREE_TYPE (subprog_type);
1830   tree subprog_decl = build_decl (input_location,
1831                                   FUNCTION_DECL, subprog_name, subprog_type);
1832
1833   /* If this is a non-inline function nested inside an inlined external
1834      function, we cannot honor both requests without cloning the nested
1835      function in the current unit since it is private to the other unit.
1836      We could inline the nested function as well but it's probably better
1837      to err on the side of too little inlining.  */
1838   if (!inline_flag
1839       && current_function_decl
1840       && DECL_DECLARED_INLINE_P (current_function_decl)
1841       && DECL_EXTERNAL (current_function_decl))
1842     DECL_DECLARED_INLINE_P (current_function_decl) = 0;
1843
1844   DECL_EXTERNAL (subprog_decl)  = extern_flag;
1845   TREE_PUBLIC (subprog_decl)    = public_flag;
1846   TREE_STATIC (subprog_decl)    = 1;
1847   TREE_READONLY (subprog_decl)  = TYPE_READONLY (subprog_type);
1848   TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
1849   TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
1850   DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag;
1851   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
1852   DECL_RESULT (subprog_decl)    = build_decl (input_location,
1853                                               RESULT_DECL, 0, return_type);
1854   DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
1855   DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
1856
1857   /* TREE_ADDRESSABLE is set on the result type to request the use of the
1858      target by-reference return mechanism.  This is not supported all the
1859      way down to RTL expansion with GCC 4, which ICEs on temporary creation
1860      attempts with such a type and expects DECL_BY_REFERENCE to be set on
1861      the RESULT_DECL instead - see gnat_genericize for more details.  */
1862   if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl))))
1863     {
1864       tree result_decl = DECL_RESULT (subprog_decl);
1865
1866       TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0;
1867       DECL_BY_REFERENCE (result_decl) = 1;
1868     }
1869
1870   if (asm_name)
1871     {
1872       SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
1873
1874       /* The expand_main_function circuitry expects "main_identifier_node" to
1875          designate the DECL_NAME of the 'main' entry point, in turn expected
1876          to be declared as the "main" function literally by default.  Ada
1877          program entry points are typically declared with a different name
1878          within the binder generated file, exported as 'main' to satisfy the
1879          system expectations.  Force main_identifier_node in this case.  */
1880       if (asm_name == main_identifier_node)
1881         DECL_NAME (subprog_decl) = main_identifier_node;
1882     }
1883
1884   process_attributes (subprog_decl, attr_list);
1885
1886   /* Add this decl to the current binding level.  */
1887   gnat_pushdecl (subprog_decl, gnat_node);
1888
1889   /* Output the assembler code and/or RTL for the declaration.  */
1890   rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
1891
1892   return subprog_decl;
1893 }
1894 \f
1895 /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
1896    body.  This routine needs to be invoked before processing the declarations
1897    appearing in the subprogram.  */
1898
1899 void
1900 begin_subprog_body (tree subprog_decl)
1901 {
1902   tree param_decl;
1903
1904   current_function_decl = subprog_decl;
1905   announce_function (subprog_decl);
1906
1907   /* Enter a new binding level and show that all the parameters belong to
1908      this function.  */
1909   gnat_pushlevel ();
1910   for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
1911        param_decl = TREE_CHAIN (param_decl))
1912     DECL_CONTEXT (param_decl) = subprog_decl;
1913
1914   make_decl_rtl (subprog_decl);
1915
1916   /* We handle pending sizes via the elaboration of types, so we don't need to
1917      save them.  This causes them to be marked as part of the outer function
1918      and then discarded.  */
1919   get_pending_sizes ();
1920 }
1921
1922
1923 /* Helper for the genericization callback.  Return a dereference of VAL
1924    if it is of a reference type.  */
1925
1926 static tree
1927 convert_from_reference (tree val)
1928 {
1929   tree value_type, ref;
1930
1931   if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE)
1932     return val;
1933
1934   value_type =  TREE_TYPE (TREE_TYPE (val));
1935   ref = build1 (INDIRECT_REF, value_type, val);
1936
1937   /* See if what we reference is CONST or VOLATILE, which requires
1938      looking into array types to get to the component type.  */
1939
1940   while (TREE_CODE (value_type) == ARRAY_TYPE)
1941     value_type = TREE_TYPE (value_type);
1942
1943   TREE_READONLY (ref)
1944     = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST);
1945   TREE_THIS_VOLATILE (ref)
1946     = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE);
1947
1948   TREE_SIDE_EFFECTS (ref)
1949     = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val));
1950
1951   return ref;
1952 }
1953
1954 /* Helper for the genericization callback.  Returns true if T denotes
1955    a RESULT_DECL with DECL_BY_REFERENCE set.  */
1956
1957 static inline bool
1958 is_byref_result (tree t)
1959 {
1960   return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t));
1961 }
1962
1963
1964 /* Tree walking callback for gnat_genericize. Currently ...
1965
1966    o Adjust references to the function's DECL_RESULT if it is marked
1967      DECL_BY_REFERENCE and so has had its type turned into a reference
1968      type at the end of the function compilation.  */
1969
1970 static tree
1971 gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data)
1972 {
1973   /* This implementation is modeled after what the C++ front-end is
1974      doing, basis of the downstream passes behavior.  */
1975
1976   tree stmt = *stmt_p;
1977   struct pointer_set_t *p_set = (struct pointer_set_t*) data;
1978
1979   /* If we have a direct mention of the result decl, dereference.  */
1980   if (is_byref_result (stmt))
1981     {
1982       *stmt_p = convert_from_reference (stmt);
1983       *walk_subtrees = 0;
1984       return NULL;
1985     }
1986
1987   /* Otherwise, no need to walk the same tree twice.  */
1988   if (pointer_set_contains (p_set, stmt))
1989     {
1990       *walk_subtrees = 0;
1991       return NULL_TREE;
1992     }
1993
1994   /* If we are taking the address of what now is a reference, just get the
1995      reference value.  */
1996   if (TREE_CODE (stmt) == ADDR_EXPR
1997       && is_byref_result (TREE_OPERAND (stmt, 0)))
1998     {
1999       *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
2000       *walk_subtrees = 0;
2001     }
2002
2003   /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR.  */
2004   else if (TREE_CODE (stmt) == RETURN_EXPR
2005            && TREE_OPERAND (stmt, 0)
2006            && is_byref_result (TREE_OPERAND (stmt, 0)))
2007     *walk_subtrees = 0;
2008
2009   /* Don't look inside trees that cannot embed references of interest.  */
2010   else if (IS_TYPE_OR_DECL_P (stmt))
2011     *walk_subtrees = 0;
2012
2013   pointer_set_insert (p_set, *stmt_p);
2014
2015   return NULL;
2016 }
2017
2018 /* Perform lowering of Ada trees to GENERIC. In particular:
2019
2020    o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl
2021      and adjust all the references to this decl accordingly.  */
2022
2023 static void
2024 gnat_genericize (tree fndecl)
2025 {
2026   /* Prior to GCC 4, an explicit By_Reference result mechanism for a function
2027      was handled by simply setting TREE_ADDRESSABLE on the result type.
2028      Everything required to actually pass by invisible ref using the target
2029      mechanism (e.g. extra parameter) was handled at RTL expansion time.
2030
2031      This doesn't work with GCC 4 any more for several reasons.  First, the
2032      gimplification process might need the creation of temporaries of this
2033      type, and the gimplifier ICEs on such attempts.  Second, the middle-end
2034      now relies on a different attribute for such cases (DECL_BY_REFERENCE on
2035      RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to
2036      be explicitly accounted for by the front-end in the function body.
2037
2038      We achieve the complete transformation in two steps:
2039
2040      1/ create_subprog_decl performs early attribute tweaks: it clears
2041         TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on
2042         the result decl.  The former ensures that the bit isn't set in the GCC
2043         tree saved for the function, so prevents ICEs on temporary creation.
2044         The latter we use here to trigger the rest of the processing.
2045
2046      2/ This function performs the type transformation on the result decl
2047         and adjusts all the references to this decl from the function body
2048         accordingly.
2049
2050      Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end
2051      strategy, which escapes the gimplifier temporary creation issues by
2052      creating it's own temporaries using TARGET_EXPR nodes.  Our way relies
2053      on simple specific support code in aggregate_value_p to look at the
2054      target function result decl explicitly.  */
2055
2056   struct pointer_set_t *p_set;
2057   tree decl_result = DECL_RESULT (fndecl);
2058
2059   if (!DECL_BY_REFERENCE (decl_result))
2060     return;
2061
2062   /* Make the DECL_RESULT explicitly by-reference and adjust all the
2063      occurrences in the function body using the common tree-walking facility.
2064      We want to see every occurrence of the result decl to adjust the
2065      referencing tree, so need to use our own pointer set to control which
2066      trees should be visited again or not.  */
2067
2068   p_set = pointer_set_create ();
2069
2070   TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result));
2071   TREE_ADDRESSABLE (decl_result) = 0;
2072   relayout_decl (decl_result);
2073
2074   walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL);
2075
2076   pointer_set_destroy (p_set);
2077 }
2078
2079 /* Finish the definition of the current subprogram BODY and finalize it.  */
2080
2081 void
2082 end_subprog_body (tree body)
2083 {
2084   tree fndecl = current_function_decl;
2085
2086   /* Mark the BLOCK for this level as being for this function and pop the
2087      level.  Since the vars in it are the parameters, clear them.  */
2088   BLOCK_VARS (current_binding_level->block) = 0;
2089   BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
2090   DECL_INITIAL (fndecl) = current_binding_level->block;
2091   gnat_poplevel ();
2092
2093   /* We handle pending sizes via the elaboration of types, so we don't
2094      need to save them.  */
2095   get_pending_sizes ();
2096
2097   /* Mark the RESULT_DECL as being in this subprogram. */
2098   DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
2099
2100   DECL_SAVED_TREE (fndecl) = body;
2101
2102   current_function_decl = DECL_CONTEXT (fndecl);
2103   set_cfun (NULL);
2104
2105   /* We cannot track the location of errors past this point.  */
2106   error_gnat_node = Empty;
2107
2108   /* If we're only annotating types, don't actually compile this function.  */
2109   if (type_annotate_only)
2110     return;
2111
2112   /* Perform the required pre-gimplification transformations on the tree.  */
2113   gnat_genericize (fndecl);
2114
2115   /* Dump functions before gimplification.  */
2116   dump_function (TDI_original, fndecl);
2117
2118   /* ??? This special handling of nested functions is probably obsolete.  */
2119   if (!DECL_CONTEXT (fndecl))
2120     cgraph_finalize_function (fndecl, false);
2121   else
2122     /* Register this function with cgraph just far enough to get it
2123        added to our parent's nested function list.  */
2124     (void) cgraph_node (fndecl);
2125 }
2126
2127 tree
2128 gnat_builtin_function (tree decl)
2129 {
2130   gnat_pushdecl (decl, Empty);
2131   return decl;
2132 }
2133
2134 /* Return an integer type with the number of bits of precision given by
2135    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
2136    it is a signed type.  */
2137
2138 tree
2139 gnat_type_for_size (unsigned precision, int unsignedp)
2140 {
2141   tree t;
2142   char type_name[20];
2143
2144   if (precision <= 2 * MAX_BITS_PER_WORD
2145       && signed_and_unsigned_types[precision][unsignedp])
2146     return signed_and_unsigned_types[precision][unsignedp];
2147
2148  if (unsignedp)
2149     t = make_unsigned_type (precision);
2150   else
2151     t = make_signed_type (precision);
2152
2153   if (precision <= 2 * MAX_BITS_PER_WORD)
2154     signed_and_unsigned_types[precision][unsignedp] = t;
2155
2156   if (!TYPE_NAME (t))
2157     {
2158       sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
2159       TYPE_NAME (t) = get_identifier (type_name);
2160     }
2161
2162   return t;
2163 }
2164
2165 /* Likewise for floating-point types.  */
2166
2167 static tree
2168 float_type_for_precision (int precision, enum machine_mode mode)
2169 {
2170   tree t;
2171   char type_name[20];
2172
2173   if (float_types[(int) mode])
2174     return float_types[(int) mode];
2175
2176   float_types[(int) mode] = t = make_node (REAL_TYPE);
2177   TYPE_PRECISION (t) = precision;
2178   layout_type (t);
2179
2180   gcc_assert (TYPE_MODE (t) == mode);
2181   if (!TYPE_NAME (t))
2182     {
2183       sprintf (type_name, "FLOAT_%d", precision);
2184       TYPE_NAME (t) = get_identifier (type_name);
2185     }
2186
2187   return t;
2188 }
2189
2190 /* Return a data type that has machine mode MODE.  UNSIGNEDP selects
2191    an unsigned type; otherwise a signed type is returned.  */
2192
2193 tree
2194 gnat_type_for_mode (enum machine_mode mode, int unsignedp)
2195 {
2196   if (mode == BLKmode)
2197     return NULL_TREE;
2198
2199   if (mode == VOIDmode)
2200     return void_type_node;
2201
2202   if (COMPLEX_MODE_P (mode))
2203     return NULL_TREE;
2204
2205   if (SCALAR_FLOAT_MODE_P (mode))
2206     return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
2207
2208   if (SCALAR_INT_MODE_P (mode))
2209     return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
2210
2211   if (VECTOR_MODE_P (mode))
2212     {
2213       enum machine_mode inner_mode = GET_MODE_INNER (mode);
2214       tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
2215       if (inner_type)
2216         return build_vector_type_for_mode (inner_type, mode);
2217     }
2218
2219   return NULL_TREE;
2220 }
2221
2222 /* Return the unsigned version of a TYPE_NODE, a scalar type.  */
2223
2224 tree
2225 gnat_unsigned_type (tree type_node)
2226 {
2227   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
2228
2229   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2230     {
2231       type = copy_node (type);
2232       TREE_TYPE (type) = type_node;
2233     }
2234   else if (TREE_TYPE (type_node)
2235            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2236            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2237     {
2238       type = copy_node (type);
2239       TREE_TYPE (type) = TREE_TYPE (type_node);
2240     }
2241
2242   return type;
2243 }
2244
2245 /* Return the signed version of a TYPE_NODE, a scalar type.  */
2246
2247 tree
2248 gnat_signed_type (tree type_node)
2249 {
2250   tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
2251
2252   if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
2253     {
2254       type = copy_node (type);
2255       TREE_TYPE (type) = type_node;
2256     }
2257   else if (TREE_TYPE (type_node)
2258            && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
2259            && TYPE_MODULAR_P (TREE_TYPE (type_node)))
2260     {
2261       type = copy_node (type);
2262       TREE_TYPE (type) = TREE_TYPE (type_node);
2263     }
2264
2265   return type;
2266 }
2267
2268 /* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
2269    transparently converted to each other.  */
2270
2271 int
2272 gnat_types_compatible_p (tree t1, tree t2)
2273 {
2274   enum tree_code code;
2275
2276   /* This is the default criterion.  */
2277   if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
2278     return 1;
2279
2280   /* We only check structural equivalence here.  */
2281   if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
2282     return 0;
2283
2284   /* Vector types are also compatible if they have the same number of subparts
2285      and the same form of (scalar) element type.  */
2286   if (code == VECTOR_TYPE
2287       && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
2288       && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
2289       && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
2290     return 1;
2291
2292   /* Array types are also compatible if they are constrained and have
2293      the same component type and the same domain.  */
2294   if (code == ARRAY_TYPE
2295       && TREE_TYPE (t1) == TREE_TYPE (t2)
2296       && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
2297           || (TYPE_DOMAIN (t1)
2298               && TYPE_DOMAIN (t2)
2299               && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
2300                                      TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
2301               && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
2302                                      TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))))
2303     return 1;
2304
2305   /* Padding record types are also compatible if they pad the same
2306      type and have the same constant size.  */
2307   if (code == RECORD_TYPE
2308       && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2)
2309       && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
2310       && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
2311     return 1;
2312
2313   return 0;
2314 }
2315 \f
2316 /* EXP is an expression for the size of an object.  If this size contains
2317    discriminant references, replace them with the maximum (if MAX_P) or
2318    minimum (if !MAX_P) possible value of the discriminant.  */
2319
2320 tree
2321 max_size (tree exp, bool max_p)
2322 {
2323   enum tree_code code = TREE_CODE (exp);
2324   tree type = TREE_TYPE (exp);
2325
2326   switch (TREE_CODE_CLASS (code))
2327     {
2328     case tcc_declaration:
2329     case tcc_constant:
2330       return exp;
2331
2332     case tcc_vl_exp:
2333       if (code == CALL_EXPR)
2334         {
2335           tree t, *argarray;
2336           int n, i;
2337
2338           t = maybe_inline_call_in_expr (exp);
2339           if (t)
2340             return max_size (t, max_p);
2341
2342           n = call_expr_nargs (exp);
2343           gcc_assert (n > 0);
2344           argarray = (tree *) alloca (n * sizeof (tree));
2345           for (i = 0; i < n; i++)
2346             argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
2347           return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
2348         }
2349       break;
2350
2351     case tcc_reference:
2352       /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
2353          modify.  Otherwise, we treat it like a variable.  */
2354       if (!CONTAINS_PLACEHOLDER_P (exp))
2355         return exp;
2356
2357       type = TREE_TYPE (TREE_OPERAND (exp, 1));
2358       return
2359         max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
2360
2361     case tcc_comparison:
2362       return max_p ? size_one_node : size_zero_node;
2363
2364     case tcc_unary:
2365     case tcc_binary:
2366     case tcc_expression:
2367       switch (TREE_CODE_LENGTH (code))
2368         {
2369         case 1:
2370           if (code == NON_LVALUE_EXPR)
2371             return max_size (TREE_OPERAND (exp, 0), max_p);
2372           else
2373             return
2374               fold_build1 (code, type,
2375                            max_size (TREE_OPERAND (exp, 0),
2376                                      code == NEGATE_EXPR ? !max_p : max_p));
2377
2378         case 2:
2379           if (code == COMPOUND_EXPR)
2380             return max_size (TREE_OPERAND (exp, 1), max_p);
2381
2382           /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which
2383              may provide a tighter bound on max_size.  */
2384           if (code == MINUS_EXPR
2385               && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR)
2386             {
2387               tree lhs = fold_build2 (MINUS_EXPR, type,
2388                                       TREE_OPERAND (TREE_OPERAND (exp, 0), 1),
2389                                       TREE_OPERAND (exp, 1));
2390               tree rhs = fold_build2 (MINUS_EXPR, type,
2391                                       TREE_OPERAND (TREE_OPERAND (exp, 0), 2),
2392                                       TREE_OPERAND (exp, 1));
2393               return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2394                                   max_size (lhs, max_p),
2395                                   max_size (rhs, max_p));
2396             }
2397
2398           {
2399             tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
2400             tree rhs = max_size (TREE_OPERAND (exp, 1),
2401                                  code == MINUS_EXPR ? !max_p : max_p);
2402
2403             /* Special-case wanting the maximum value of a MIN_EXPR.
2404                In that case, if one side overflows, return the other.
2405                sizetype is signed, but we know sizes are non-negative.
2406                Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
2407                overflowing or the maximum possible value and the RHS
2408                a variable.  */
2409             if (max_p
2410                 && code == MIN_EXPR
2411                 && TREE_CODE (rhs) == INTEGER_CST
2412                 && TREE_OVERFLOW (rhs))
2413               return lhs;
2414             else if (max_p
2415                      && code == MIN_EXPR
2416                      && TREE_CODE (lhs) == INTEGER_CST
2417                      && TREE_OVERFLOW (lhs))
2418               return rhs;
2419             else if ((code == MINUS_EXPR || code == PLUS_EXPR)
2420                      && ((TREE_CODE (lhs) == INTEGER_CST
2421                           && TREE_OVERFLOW (lhs))
2422                          || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
2423                      && !TREE_CONSTANT (rhs))
2424               return lhs;
2425             else
2426               return fold_build2 (code, type, lhs, rhs);
2427           }
2428
2429         case 3:
2430           if (code == SAVE_EXPR)
2431             return exp;
2432           else if (code == COND_EXPR)
2433             return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
2434                                 max_size (TREE_OPERAND (exp, 1), max_p),
2435                                 max_size (TREE_OPERAND (exp, 2), max_p));
2436         }
2437
2438       /* Other tree classes cannot happen.  */
2439     default:
2440       break;
2441     }
2442
2443   gcc_unreachable ();
2444 }
2445 \f
2446 /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
2447    EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
2448    Return a constructor for the template.  */
2449
2450 tree
2451 build_template (tree template_type, tree array_type, tree expr)
2452 {
2453   tree template_elts = NULL_TREE;
2454   tree bound_list = NULL_TREE;
2455   tree field;
2456
2457   while (TREE_CODE (array_type) == RECORD_TYPE
2458          && (TYPE_PADDING_P (array_type)
2459              || TYPE_JUSTIFIED_MODULAR_P (array_type)))
2460     array_type = TREE_TYPE (TYPE_FIELDS (array_type));
2461
2462   if (TREE_CODE (array_type) == ARRAY_TYPE
2463       || (TREE_CODE (array_type) == INTEGER_TYPE
2464           && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
2465     bound_list = TYPE_ACTUAL_BOUNDS (array_type);
2466
2467   /* First make the list for a CONSTRUCTOR for the template.  Go down the
2468      field list of the template instead of the type chain because this
2469      array might be an Ada array of arrays and we can't tell where the
2470      nested arrays stop being the underlying object.  */
2471
2472   for (field = TYPE_FIELDS (template_type); field;
2473        (bound_list
2474         ? (bound_list = TREE_CHAIN (bound_list))
2475         : (array_type = TREE_TYPE (array_type))),
2476        field = TREE_CHAIN (TREE_CHAIN (field)))
2477     {
2478       tree bounds, min, max;
2479
2480       /* If we have a bound list, get the bounds from there.  Likewise
2481          for an ARRAY_TYPE.  Otherwise, if expr is a PARM_DECL with
2482          DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
2483          This will give us a maximum range.  */
2484       if (bound_list)
2485         bounds = TREE_VALUE (bound_list);
2486       else if (TREE_CODE (array_type) == ARRAY_TYPE)
2487         bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
2488       else if (expr && TREE_CODE (expr) == PARM_DECL
2489                && DECL_BY_COMPONENT_PTR_P (expr))
2490         bounds = TREE_TYPE (field);
2491       else
2492         gcc_unreachable ();
2493
2494       min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
2495       max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds));
2496
2497       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
2498          substitute it from OBJECT.  */
2499       min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
2500       max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
2501
2502       template_elts = tree_cons (TREE_CHAIN (field), max,
2503                                  tree_cons (field, min, template_elts));
2504     }
2505
2506   return gnat_build_constructor (template_type, nreverse (template_elts));
2507 }
2508 \f
2509 /* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
2510    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2511    in the type contains in its DECL_INITIAL the expression to use when
2512    a constructor is made for the type.  GNAT_ENTITY is an entity used
2513    to print out an error message if the mechanism cannot be applied to
2514    an object of that type and also for the name.  */
2515
2516 tree
2517 build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2518 {
2519   tree record_type = make_node (RECORD_TYPE);
2520   tree pointer32_type;
2521   tree field_list = 0;
2522   int klass;
2523   int dtype = 0;
2524   tree inner_type;
2525   int ndim;
2526   int i;
2527   tree *idx_arr;
2528   tree tem;
2529
2530   /* If TYPE is an unconstrained array, use the underlying array type.  */
2531   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2532     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2533
2534   /* If this is an array, compute the number of dimensions in the array,
2535      get the index types, and point to the inner type.  */
2536   if (TREE_CODE (type) != ARRAY_TYPE)
2537     ndim = 0;
2538   else
2539     for (ndim = 1, inner_type = type;
2540          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2541          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2542          ndim++, inner_type = TREE_TYPE (inner_type))
2543       ;
2544
2545   idx_arr = (tree *) alloca (ndim * sizeof (tree));
2546
2547   if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
2548       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2549     for (i = ndim - 1, inner_type = type;
2550          i >= 0;
2551          i--, inner_type = TREE_TYPE (inner_type))
2552       idx_arr[i] = TYPE_DOMAIN (inner_type);
2553   else
2554     for (i = 0, inner_type = type;
2555          i < ndim;
2556          i++, inner_type = TREE_TYPE (inner_type))
2557       idx_arr[i] = TYPE_DOMAIN (inner_type);
2558
2559   /* Now get the DTYPE value.  */
2560   switch (TREE_CODE (type))
2561     {
2562     case INTEGER_TYPE:
2563     case ENUMERAL_TYPE:
2564     case BOOLEAN_TYPE:
2565       if (TYPE_VAX_FLOATING_POINT_P (type))
2566         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2567           {
2568           case 6:
2569             dtype = 10;
2570             break;
2571           case 9:
2572             dtype = 11;
2573             break;
2574           case 15:
2575             dtype = 27;
2576             break;
2577           }
2578       else
2579         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2580           {
2581           case 8:
2582             dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2583             break;
2584           case 16:
2585             dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2586             break;
2587           case 32:
2588             dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2589             break;
2590           case 64:
2591             dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2592             break;
2593           case 128:
2594             dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2595             break;
2596           }
2597       break;
2598
2599     case REAL_TYPE:
2600       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2601       break;
2602
2603     case COMPLEX_TYPE:
2604       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2605           && TYPE_VAX_FLOATING_POINT_P (type))
2606         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2607           {
2608           case 6:
2609             dtype = 12;
2610             break;
2611           case 9:
2612             dtype = 13;
2613             break;
2614           case 15:
2615             dtype = 29;
2616           }
2617       else
2618         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2619       break;
2620
2621     case ARRAY_TYPE:
2622       dtype = 14;
2623       break;
2624
2625     default:
2626       break;
2627     }
2628
2629   /* Get the CLASS value.  */
2630   switch (mech)
2631     {
2632     case By_Descriptor_A:
2633     case By_Short_Descriptor_A:
2634       klass = 4;
2635       break;
2636     case By_Descriptor_NCA:
2637     case By_Short_Descriptor_NCA:
2638       klass = 10;
2639       break;
2640     case By_Descriptor_SB:
2641     case By_Short_Descriptor_SB:
2642       klass = 15;
2643       break;
2644     case By_Descriptor:
2645     case By_Short_Descriptor:
2646     case By_Descriptor_S:
2647     case By_Short_Descriptor_S:
2648     default:
2649       klass = 1;
2650       break;
2651     }
2652
2653   /* Make the type for a descriptor for VMS.  The first four fields
2654      are the same for all types.  */
2655
2656   field_list
2657     = chainon (field_list,
2658                make_descriptor_field
2659                ("LENGTH", gnat_type_for_size (16, 1), record_type,
2660                 size_in_bytes ((mech == By_Descriptor_A ||
2661                                 mech == By_Short_Descriptor_A)
2662                                ? inner_type : type)));
2663
2664   field_list = chainon (field_list,
2665                         make_descriptor_field ("DTYPE",
2666                                                gnat_type_for_size (8, 1),
2667                                                record_type, size_int (dtype)));
2668   field_list = chainon (field_list,
2669                         make_descriptor_field ("CLASS",
2670                                                gnat_type_for_size (8, 1),
2671                                                record_type, size_int (klass)));
2672
2673   /* Of course this will crash at run-time if the address space is not
2674      within the low 32 bits, but there is nothing else we can do.  */
2675   pointer32_type = build_pointer_type_for_mode (type, SImode, false);
2676
2677   field_list
2678     = chainon (field_list,
2679                make_descriptor_field
2680                ("POINTER", pointer32_type, record_type,
2681                 build_unary_op (ADDR_EXPR,
2682                                 pointer32_type,
2683                                 build0 (PLACEHOLDER_EXPR, type))));
2684
2685   switch (mech)
2686     {
2687     case By_Descriptor:
2688     case By_Short_Descriptor:
2689     case By_Descriptor_S:
2690     case By_Short_Descriptor_S:
2691       break;
2692
2693     case By_Descriptor_SB:
2694     case By_Short_Descriptor_SB:
2695       field_list
2696         = chainon (field_list,
2697                    make_descriptor_field
2698                    ("SB_L1", gnat_type_for_size (32, 1), record_type,
2699                     TREE_CODE (type) == ARRAY_TYPE
2700                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2701       field_list
2702         = chainon (field_list,
2703                    make_descriptor_field
2704                    ("SB_U1", gnat_type_for_size (32, 1), record_type,
2705                     TREE_CODE (type) == ARRAY_TYPE
2706                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
2707       break;
2708
2709     case By_Descriptor_A:
2710     case By_Short_Descriptor_A:
2711     case By_Descriptor_NCA:
2712     case By_Short_Descriptor_NCA:
2713       field_list = chainon (field_list,
2714                             make_descriptor_field ("SCALE",
2715                                                    gnat_type_for_size (8, 1),
2716                                                    record_type,
2717                                                    size_zero_node));
2718
2719       field_list = chainon (field_list,
2720                             make_descriptor_field ("DIGITS",
2721                                                    gnat_type_for_size (8, 1),
2722                                                    record_type,
2723                                                    size_zero_node));
2724
2725       field_list
2726         = chainon (field_list,
2727                    make_descriptor_field
2728                    ("AFLAGS", gnat_type_for_size (8, 1), record_type,
2729                     size_int ((mech == By_Descriptor_NCA ||
2730                               mech == By_Short_Descriptor_NCA)
2731                               ? 0
2732                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
2733                               : (TREE_CODE (type) == ARRAY_TYPE
2734                                  && TYPE_CONVENTION_FORTRAN_P (type)
2735                                  ? 224 : 192))));
2736
2737       field_list = chainon (field_list,
2738                             make_descriptor_field ("DIMCT",
2739                                                    gnat_type_for_size (8, 1),
2740                                                    record_type,
2741                                                    size_int (ndim)));
2742
2743       field_list = chainon (field_list,
2744                             make_descriptor_field ("ARSIZE",
2745                                                    gnat_type_for_size (32, 1),
2746                                                    record_type,
2747                                                    size_in_bytes (type)));
2748
2749       /* Now build a pointer to the 0,0,0... element.  */
2750       tem = build0 (PLACEHOLDER_EXPR, type);
2751       for (i = 0, inner_type = type; i < ndim;
2752            i++, inner_type = TREE_TYPE (inner_type))
2753         tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
2754                       convert (TYPE_DOMAIN (inner_type), size_zero_node),
2755                       NULL_TREE, NULL_TREE);
2756
2757       field_list
2758         = chainon (field_list,
2759                    make_descriptor_field
2760                    ("A0",
2761                     build_pointer_type_for_mode (inner_type, SImode, false),
2762                     record_type,
2763                     build1 (ADDR_EXPR,
2764                             build_pointer_type_for_mode (inner_type, SImode,
2765                                                          false),
2766                             tem)));
2767
2768       /* Next come the addressing coefficients.  */
2769       tem = size_one_node;
2770       for (i = 0; i < ndim; i++)
2771         {
2772           char fname[3];
2773           tree idx_length
2774             = size_binop (MULT_EXPR, tem,
2775                           size_binop (PLUS_EXPR,
2776                                       size_binop (MINUS_EXPR,
2777                                                   TYPE_MAX_VALUE (idx_arr[i]),
2778                                                   TYPE_MIN_VALUE (idx_arr[i])),
2779                                       size_int (1)));
2780
2781           fname[0] = ((mech == By_Descriptor_NCA ||
2782                        mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
2783           fname[1] = '0' + i, fname[2] = 0;
2784           field_list
2785             = chainon (field_list,
2786                        make_descriptor_field (fname,
2787                                               gnat_type_for_size (32, 1),
2788                                               record_type, idx_length));
2789
2790           if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
2791             tem = idx_length;
2792         }
2793
2794       /* Finally here are the bounds.  */
2795       for (i = 0; i < ndim; i++)
2796         {
2797           char fname[3];
2798
2799           fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
2800           field_list
2801             = chainon (field_list,
2802                        make_descriptor_field
2803                        (fname, gnat_type_for_size (32, 1), record_type,
2804                         TYPE_MIN_VALUE (idx_arr[i])));
2805
2806           fname[0] = 'U';
2807           field_list
2808             = chainon (field_list,
2809                        make_descriptor_field
2810                        (fname, gnat_type_for_size (32, 1), record_type,
2811                         TYPE_MAX_VALUE (idx_arr[i])));
2812         }
2813       break;
2814
2815     default:
2816       post_error ("unsupported descriptor type for &", gnat_entity);
2817     }
2818
2819   TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
2820   finish_record_type (record_type, field_list, 0, false);
2821   return record_type;
2822 }
2823
2824 /* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
2825    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
2826    in the type contains in its DECL_INITIAL the expression to use when
2827    a constructor is made for the type.  GNAT_ENTITY is an entity used
2828    to print out an error message if the mechanism cannot be applied to
2829    an object of that type and also for the name.  */
2830
2831 tree
2832 build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
2833 {
2834   tree record64_type = make_node (RECORD_TYPE);
2835   tree pointer64_type;
2836   tree field_list64 = 0;
2837   int klass;
2838   int dtype = 0;
2839   tree inner_type;
2840   int ndim;
2841   int i;
2842   tree *idx_arr;
2843   tree tem;
2844
2845   /* If TYPE is an unconstrained array, use the underlying array type.  */
2846   if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
2847     type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
2848
2849   /* If this is an array, compute the number of dimensions in the array,
2850      get the index types, and point to the inner type.  */
2851   if (TREE_CODE (type) != ARRAY_TYPE)
2852     ndim = 0;
2853   else
2854     for (ndim = 1, inner_type = type;
2855          TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
2856          && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
2857          ndim++, inner_type = TREE_TYPE (inner_type))
2858       ;
2859
2860   idx_arr = (tree *) alloca (ndim * sizeof (tree));
2861
2862   if (mech != By_Descriptor_NCA
2863       && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
2864     for (i = ndim - 1, inner_type = type;
2865          i >= 0;
2866          i--, inner_type = TREE_TYPE (inner_type))
2867       idx_arr[i] = TYPE_DOMAIN (inner_type);
2868   else
2869     for (i = 0, inner_type = type;
2870          i < ndim;
2871          i++, inner_type = TREE_TYPE (inner_type))
2872       idx_arr[i] = TYPE_DOMAIN (inner_type);
2873
2874   /* Now get the DTYPE value.  */
2875   switch (TREE_CODE (type))
2876     {
2877     case INTEGER_TYPE:
2878     case ENUMERAL_TYPE:
2879     case BOOLEAN_TYPE:
2880       if (TYPE_VAX_FLOATING_POINT_P (type))
2881         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2882           {
2883           case 6:
2884             dtype = 10;
2885             break;
2886           case 9:
2887             dtype = 11;
2888             break;
2889           case 15:
2890             dtype = 27;
2891             break;
2892           }
2893       else
2894         switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
2895           {
2896           case 8:
2897             dtype = TYPE_UNSIGNED (type) ? 2 : 6;
2898             break;
2899           case 16:
2900             dtype = TYPE_UNSIGNED (type) ? 3 : 7;
2901             break;
2902           case 32:
2903             dtype = TYPE_UNSIGNED (type) ? 4 : 8;
2904             break;
2905           case 64:
2906             dtype = TYPE_UNSIGNED (type) ? 5 : 9;
2907             break;
2908           case 128:
2909             dtype = TYPE_UNSIGNED (type) ? 25 : 26;
2910             break;
2911           }
2912       break;
2913
2914     case REAL_TYPE:
2915       dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
2916       break;
2917
2918     case COMPLEX_TYPE:
2919       if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
2920           && TYPE_VAX_FLOATING_POINT_P (type))
2921         switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
2922           {
2923           case 6:
2924             dtype = 12;
2925             break;
2926           case 9:
2927             dtype = 13;
2928             break;
2929           case 15:
2930             dtype = 29;
2931           }
2932       else
2933         dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
2934       break;
2935
2936     case ARRAY_TYPE:
2937       dtype = 14;
2938       break;
2939
2940     default:
2941       break;
2942     }
2943
2944   /* Get the CLASS value.  */
2945   switch (mech)
2946     {
2947     case By_Descriptor_A:
2948       klass = 4;
2949       break;
2950     case By_Descriptor_NCA:
2951       klass = 10;
2952       break;
2953     case By_Descriptor_SB:
2954       klass = 15;
2955       break;
2956     case By_Descriptor:
2957     case By_Descriptor_S:
2958     default:
2959       klass = 1;
2960       break;
2961     }
2962
2963   /* Make the type for a 64bit descriptor for VMS.  The first six fields
2964      are the same for all types.  */
2965
2966   field_list64 = chainon (field_list64,
2967                         make_descriptor_field ("MBO",
2968                                                gnat_type_for_size (16, 1),
2969                                                record64_type, size_int (1)));
2970
2971   field_list64 = chainon (field_list64,
2972                         make_descriptor_field ("DTYPE",
2973                                                gnat_type_for_size (8, 1),
2974                                                record64_type, size_int (dtype)));
2975   field_list64 = chainon (field_list64,
2976                         make_descriptor_field ("CLASS",
2977                                                gnat_type_for_size (8, 1),
2978                                                record64_type, size_int (klass)));
2979
2980   field_list64 = chainon (field_list64,
2981                         make_descriptor_field ("MBMO",
2982                                                gnat_type_for_size (32, 1),
2983                                                record64_type, ssize_int (-1)));
2984
2985   field_list64
2986     = chainon (field_list64,
2987                make_descriptor_field
2988                ("LENGTH", gnat_type_for_size (64, 1), record64_type,
2989                 size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
2990
2991   pointer64_type = build_pointer_type_for_mode (type, DImode, false);
2992
2993   field_list64
2994     = chainon (field_list64,
2995                make_descriptor_field
2996                ("POINTER", pointer64_type, record64_type,
2997                 build_unary_op (ADDR_EXPR,
2998                                 pointer64_type,
2999                                 build0 (PLACEHOLDER_EXPR, type))));
3000
3001   switch (mech)
3002     {
3003     case By_Descriptor:
3004     case By_Descriptor_S:
3005       break;
3006
3007     case By_Descriptor_SB:
3008       field_list64
3009         = chainon (field_list64,
3010                    make_descriptor_field
3011                    ("SB_L1", gnat_type_for_size (64, 1), record64_type,
3012                     TREE_CODE (type) == ARRAY_TYPE
3013                     ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
3014       field_list64
3015         = chainon (field_list64,
3016                    make_descriptor_field
3017                    ("SB_U1", gnat_type_for_size (64, 1), record64_type,
3018                     TREE_CODE (type) == ARRAY_TYPE
3019                     ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
3020       break;
3021
3022     case By_Descriptor_A:
3023     case By_Descriptor_NCA:
3024       field_list64 = chainon (field_list64,
3025                             make_descriptor_field ("SCALE",
3026                                                    gnat_type_for_size (8, 1),
3027                                                    record64_type,
3028                                                    size_zero_node));
3029
3030       field_list64 = chainon (field_list64,
3031                             make_descriptor_field ("DIGITS",
3032                                                    gnat_type_for_size (8, 1),
3033                                                    record64_type,
3034                                                    size_zero_node));
3035
3036       field_list64
3037         = chainon (field_list64,
3038                    make_descriptor_field
3039                    ("AFLAGS", gnat_type_for_size (8, 1), record64_type,
3040                     size_int (mech == By_Descriptor_NCA
3041                               ? 0
3042                               /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS.  */
3043                               : (TREE_CODE (type) == ARRAY_TYPE
3044                                  && TYPE_CONVENTION_FORTRAN_P (type)
3045                                  ? 224 : 192))));
3046
3047       field_list64 = chainon (field_list64,
3048                             make_descriptor_field ("DIMCT",
3049                                                    gnat_type_for_size (8, 1),
3050                                                    record64_type,
3051                                                    size_int (ndim)));
3052
3053       field_list64 = chainon (field_list64,
3054                             make_descriptor_field ("MBZ",
3055                                                    gnat_type_for_size (32, 1),
3056                                                    record64_type,
3057                                                    size_int (0)));
3058       field_list64 = chainon (field_list64,
3059                             make_descriptor_field ("ARSIZE",
3060                                                    gnat_type_for_size (64, 1),
3061                                                    record64_type,
3062                                                    size_in_bytes (type)));
3063
3064       /* Now build a pointer to the 0,0,0... element.  */
3065       tem = build0 (PLACEHOLDER_EXPR, type);
3066       for (i = 0, inner_type = type; i < ndim;
3067            i++, inner_type = TREE_TYPE (inner_type))
3068         tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
3069                       convert (TYPE_DOMAIN (inner_type), size_zero_node),
3070                       NULL_TREE, NULL_TREE);
3071
3072       field_list64
3073         = chainon (field_list64,
3074                    make_descriptor_field
3075                    ("A0",
3076                     build_pointer_type_for_mode (inner_type, DImode, false),
3077                     record64_type,
3078                     build1 (ADDR_EXPR,
3079                             build_pointer_type_for_mode (inner_type, DImode,
3080                                                          false),
3081                             tem)));
3082
3083       /* Next come the addressing coefficients.  */
3084       tem = size_one_node;
3085       for (i = 0; i < ndim; i++)
3086         {
3087           char fname[3];
3088           tree idx_length
3089             = size_binop (MULT_EXPR, tem,
3090                           size_binop (PLUS_EXPR,
3091                                       size_binop (MINUS_EXPR,
3092                                                   TYPE_MAX_VALUE (idx_arr[i]),
3093                                                   TYPE_MIN_VALUE (idx_arr[i])),
3094                                       size_int (1)));
3095
3096           fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
3097           fname[1] = '0' + i, fname[2] = 0;
3098           field_list64
3099             = chainon (field_list64,
3100                        make_descriptor_field (fname,
3101                                               gnat_type_for_size (64, 1),
3102                                               record64_type, idx_length));
3103
3104           if (mech == By_Descriptor_NCA)
3105             tem = idx_length;
3106         }
3107
3108       /* Finally here are the bounds.  */
3109       for (i = 0; i < ndim; i++)
3110         {
3111           char fname[3];
3112
3113           fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
3114           field_list64
3115             = chainon (field_list64,
3116                        make_descriptor_field
3117                        (fname, gnat_type_for_size (64, 1), record64_type,
3118                         TYPE_MIN_VALUE (idx_arr[i])));
3119
3120           fname[0] = 'U';
3121           field_list64
3122             = chainon (field_list64,
3123                        make_descriptor_field
3124                        (fname, gnat_type_for_size (64, 1), record64_type,
3125                         TYPE_MAX_VALUE (idx_arr[i])));
3126         }
3127       break;
3128
3129     default:
3130       post_error ("unsupported descriptor type for &", gnat_entity);
3131     }
3132
3133   TYPE_NAME (record64_type) = create_concat_name (gnat_entity, "DESC64");
3134   finish_record_type (record64_type, field_list64, 0, false);
3135   return record64_type;
3136 }
3137
3138 /* Utility routine for above code to make a field.  */
3139
3140 static tree
3141 make_descriptor_field (const char *name, tree type,
3142                        tree rec_type, tree initial)
3143 {
3144   tree field
3145     = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
3146
3147   DECL_INITIAL (field) = initial;
3148   return field;
3149 }
3150
3151 /* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
3152    regular pointer or fat pointer type.  GNAT_SUBPROG is the subprogram to
3153    which the VMS descriptor is passed.  */
3154
3155 static tree
3156 convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
3157 {
3158   tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
3159   tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
3160   /* The CLASS field is the 3rd field in the descriptor.  */
3161   tree klass = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
3162   /* The POINTER field is the 6th field in the descriptor.  */
3163   tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
3164
3165   /* Retrieve the value of the POINTER field.  */
3166   tree gnu_expr64
3167     = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE);
3168
3169   if (POINTER_TYPE_P (gnu_type))
3170     return convert (gnu_type, gnu_expr64);
3171
3172   else if (TYPE_IS_FAT_POINTER_P (gnu_type))
3173     {
3174       tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3175       tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
3176       tree template_type = TREE_TYPE (p_bounds_type);
3177       tree min_field = TYPE_FIELDS (template_type);
3178       tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
3179       tree template_tree, template_addr, aflags, dimct, t, u;
3180       /* See the head comment of build_vms_descriptor.  */
3181       int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
3182       tree lfield, ufield;
3183
3184       /* Convert POINTER to the type of the P_ARRAY field.  */
3185       gnu_expr64 = convert (p_array_type, gnu_expr64);
3186
3187       switch (iklass)
3188         {
3189         case 1:  /* Class S  */
3190         case 15: /* Class SB */
3191           /* Build {1, LENGTH} template; LENGTH64 is the 5th field.  */
3192           t = TREE_CHAIN (TREE_CHAIN (klass));
3193           t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3194           t = tree_cons (min_field,
3195                          convert (TREE_TYPE (min_field), integer_one_node),
3196                          tree_cons (max_field,
3197                                     convert (TREE_TYPE (max_field), t),
3198                                     NULL_TREE));
3199           template_tree = gnat_build_constructor (template_type, t);
3200           template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
3201
3202           /* For class S, we are done.  */
3203           if (iklass == 1)
3204             break;
3205
3206           /* Test that we really have a SB descriptor, like DEC Ada.  */
3207           t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
3208           u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
3209           u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
3210           /* If so, there is already a template in the descriptor and
3211              it is located right after the POINTER field.  The fields are
3212              64bits so they must be repacked. */
3213           t = TREE_CHAIN (pointer64);
3214           lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3215           lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
3216
3217           t = TREE_CHAIN (t);
3218           ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3219           ufield = convert
3220            (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield);
3221
3222           /* Build the template in the form of a constructor. */
3223           t = tree_cons (TYPE_FIELDS (template_type), lfield,
3224                          tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)),
3225                                     ufield, NULL_TREE));
3226           template_tree = gnat_build_constructor (template_type, t);
3227
3228           /* Otherwise use the {1, LENGTH} template we build above.  */
3229           template_addr = build3 (COND_EXPR, p_bounds_type, u,
3230                                   build_unary_op (ADDR_EXPR, p_bounds_type,
3231                                                  template_tree),
3232                                   template_addr);
3233           break;
3234
3235         case 4:  /* Class A */
3236           /* The AFLAGS field is the 3rd field after the pointer in the
3237              descriptor.  */
3238           t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64)));
3239           aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3240           /* The DIMCT field is the next field in the descriptor after
3241              aflags.  */
3242           t = TREE_CHAIN (t);
3243           dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
3244           /* Raise CONSTRAINT_ERROR if either more than 1 dimension
3245              or FL_COEFF or FL_BOUNDS not set.  */
3246           u = build_int_cst (TREE_TYPE (aflags), 192);
3247           u = build_binary_op (TRUTH_OR_EXPR, integer_type_node,
3248                                build_binary_op (NE_EXPR, integer_type_node,
3249                                                 dimct,