OSDN Git Service

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