OSDN Git Service

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