OSDN Git Service

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