1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * M I S C *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2012, 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 distributed with GNAT; see 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 "opts.h"
30 #include "options.h"
31 #include "tm.h"
32 #include "tree.h"
33 #include "diagnostic.h"
34 #include "target.h"
35 #include "ggc.h"
36 #include "flags.h"
37 #include "debug.h"
38 #include "toplev.h"
39 #include "langhooks.h"
40 #include "langhooks-def.h"
41 #include "plugin.h"
42 #include "real.h"
43 #include "function.h" /* For pass_by_reference. */
44
45 #include "ada.h"
46 #include "adadecode.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 /* This symbol needs to be defined for the front-end. */
61 void *callgraph_info_file = NULL;
62
63 /* Command-line argc and argv. These variables are global since they are
64 imported in back_end.adb. */
65 unsigned int save_argc;
66 const char **save_argv;
67
68 /* GNAT argc and argv. */
69 extern int gnat_argc;
70 extern char **gnat_argv;
71
72 #ifdef __cplusplus
73 extern "C" {
74 #endif
75
76 /* Declare functions we use as part of startup. */
77 extern void __gnat_initialize (void *);
78 extern void __gnat_install_SEH_handler (void *);
79 extern void adainit (void);
80 extern void _ada_gnat1drv (void);
81
82 #ifdef __cplusplus
83 }
84 #endif
85
86 /* The parser for the language. For us, we process the GNAT tree. */
87
88 static void
gnat_parse_file(void)89 gnat_parse_file (void)
90 {
91 int seh[2];
92
93 /* Call the target specific initializations. */
94 __gnat_initialize (NULL);
95
96 /* ??? Call the SEH initialization routine. This is to workaround
97 a bootstrap path problem. The call below should be removed at some
98 point and the SEH pointer passed to __gnat_initialize() above. */
99 __gnat_install_SEH_handler((void *)seh);
100
101 /* Call the front-end elaboration procedures. */
102 adainit ();
103
104 /* Call the front end. */
105 _ada_gnat1drv ();
106 }
107
108 /* Return language mask for option processing. */
109
110 static unsigned int
gnat_option_lang_mask(void)111 gnat_option_lang_mask (void)
112 {
113 return CL_Ada;
114 }
115
116 /* Decode all the language specific options that cannot be decoded by GCC.
117 The option decoding phase of GCC calls this routine on the flags that
118 are marked as Ada-specific. Return true on success or false on failure. */
119
120 static bool
gnat_handle_option(size_t scode,const char * arg ATTRIBUTE_UNUSED,int value,int kind ATTRIBUTE_UNUSED,location_t loc ATTRIBUTE_UNUSED,const struct cl_option_handlers * handlers ATTRIBUTE_UNUSED)121 gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value,
122 int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED,
123 const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
124 {
125 enum opt_code code = (enum opt_code) scode;
126
127 switch (code)
128 {
129 case OPT_Wall:
130 handle_generated_option (&global_options, &global_options_set,
131 OPT_Wunused, NULL, value,
132 gnat_option_lang_mask (), kind, loc,
133 handlers, global_dc);
134 warn_uninitialized = value;
135 warn_maybe_uninitialized = value;
136 break;
137
138 case OPT_gant:
139 warning (0, "%<-gnat%> misspelled as %<-gant%>");
140
141 /* ... fall through ... */
142
143 case OPT_gnat:
144 case OPT_gnatO:
145 case OPT_fRTS_:
146 case OPT_I:
147 case OPT_nostdinc:
148 case OPT_nostdlib:
149 /* These are handled by the front-end. */
150 break;
151
152 default:
153 gcc_unreachable ();
154 }
155
156 Ada_handle_option_auto (&global_options, &global_options_set,
157 scode, arg, value,
158 gnat_option_lang_mask (), kind,
159 loc, handlers, global_dc);
160 return true;
161 }
162
163 /* Initialize options structure OPTS. */
164
165 static void
gnat_init_options_struct(struct gcc_options * opts)166 gnat_init_options_struct (struct gcc_options *opts)
167 {
168 /* Uninitialized really means uninitialized in Ada. */
169 opts->x_flag_zero_initialized_in_bss = 0;
170
171 /* We can delete dead instructions that may throw exceptions in Ada. */
172 opts->x_flag_delete_dead_exceptions = 1;
173 }
174
175 /* Initialize for option processing. */
176
177 static void
gnat_init_options(unsigned int decoded_options_count,struct cl_decoded_option * decoded_options)178 gnat_init_options (unsigned int decoded_options_count,
179 struct cl_decoded_option *decoded_options)
180 {
181 /* Reconstruct an argv array for use of back_end.adb.
182
183 ??? back_end.adb should not rely on this; instead, it should work with
184 decoded options without such reparsing, to ensure consistency in how
185 options are decoded. */
186 unsigned int i;
187
188 save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
189 save_argc = 0;
190 for (i = 0; i < decoded_options_count; i++)
191 {
192 size_t num_elements = decoded_options[i].canonical_option_num_elements;
193
194 if (decoded_options[i].errors
195 || decoded_options[i].opt_index == OPT_SPECIAL_unknown
196 || num_elements == 0)
197 continue;
198
199 /* Deal with -I- specially since it must be a single switch. */
200 if (decoded_options[i].opt_index == OPT_I
201 && num_elements == 2
202 && decoded_options[i].canonical_option[1][0] == '-'
203 && decoded_options[i].canonical_option[1][1] == '\0')
204 save_argv[save_argc++] = "-I-";
205 else
206 {
207 gcc_assert (num_elements >= 1 && num_elements <= 2);
208 save_argv[save_argc++] = decoded_options[i].canonical_option[0];
209 if (num_elements >= 2)
210 save_argv[save_argc++] = decoded_options[i].canonical_option[1];
211 }
212 }
213 save_argv[save_argc] = NULL;
214
215 gnat_argv = (char **) xmalloc (sizeof (save_argv[0]));
216 gnat_argv[0] = xstrdup (save_argv[0]); /* name of the command */
217 gnat_argc = 1;
218 }
219
220 /* Ada code requires variables for these settings rather than elements
221 of the global_options structure. */
222 #undef optimize
223 #undef optimize_size
224 #undef flag_compare_debug
225 #undef flag_stack_check
226 int optimize;
227 int optimize_size;
228 int flag_compare_debug;
229 enum stack_check_type flag_stack_check = NO_STACK_CHECK;
230
231 /* Settings adjustments after switches processing by the back-end.
232 Note that the front-end switches processing (Scan_Compiler_Arguments)
233 has not been done yet at this point! */
234
235 static bool
gnat_post_options(const char ** pfilename ATTRIBUTE_UNUSED)236 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
237 {
238 /* Excess precision other than "fast" requires front-end support. */
239 if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
240 && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
241 sorry ("-fexcess-precision=standard for Ada");
242 flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
243
244 /* ??? The warning machinery is outsmarted by Ada. */
245 warn_unused_parameter = 0;
246
247 /* No psABI change warnings for Ada. */
248 warn_psabi = 0;
249
250 /* No caret by default for Ada. */
251 if (!global_options_set.x_flag_diagnostics_show_caret)
252 global_dc->show_caret = false;
253
254 optimize = global_options.x_optimize;
255 optimize_size = global_options.x_optimize_size;
256 flag_compare_debug = global_options.x_flag_compare_debug;
257 flag_stack_check = global_options.x_flag_stack_check;
258
259 return false;
260 }
261
262 /* Here is the function to handle the compiler error processing in GCC. */
263
264 static void
internal_error_function(diagnostic_context * context,const char * msgid,va_list * ap)265 internal_error_function (diagnostic_context *context,
266 const char *msgid, va_list *ap)
267 {
268 text_info tinfo;
269 char *buffer, *p, *loc;
270 String_Template temp, temp_loc;
271 Fat_Pointer fp, fp_loc;
272 expanded_location s;
273
274 /* Warn if plugins present. */
275 warn_if_plugins ();
276
277 /* Reset the pretty-printer. */
278 pp_clear_output_area (context->printer);
279
280 /* Format the message into the pretty-printer. */
281 tinfo.format_spec = msgid;
282 tinfo.args_ptr = ap;
283 tinfo.err_no = errno;
284 pp_format_verbatim (context->printer, &tinfo);
285
286 /* Extract a (writable) pointer to the formatted text. */
287 buffer = xstrdup (pp_formatted_text (context->printer));
288
289 /* Go up to the first newline. */
290 for (p = buffer; *p; p++)
291 if (*p == '\n')
292 {
293 *p = '\0';
294 break;
295 }
296
297 temp.Low_Bound = 1;
298 temp.High_Bound = p - buffer;
299 fp.Bounds = &temp;
300 fp.Array = buffer;
301
302 s = expand_location (input_location);
303 if (context->show_column && s.column != 0)
304 asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
305 else
306 asprintf (&loc, "%s:%d", s.file, s.line);
307 temp_loc.Low_Bound = 1;
308 temp_loc.High_Bound = strlen (loc);
309 fp_loc.Bounds = &temp_loc;
310 fp_loc.Array = loc;
311
312 Current_Error_Node = error_gnat_node;
313 Compiler_Abort (fp, -1, fp_loc);
314 }
315
316 /* Perform all the initialization steps that are language-specific. */
317
318 static bool
gnat_init(void)319 gnat_init (void)
320 {
321 /* Do little here, most of the standard declarations are set up after the
322 front-end has been run. Use the same `char' as C, this doesn't really
323 matter since we'll use the explicit `unsigned char' for Character. */
324 build_common_tree_nodes (flag_signed_char, false);
325
326 /* In Ada, we use an unsigned 8-bit type for the default boolean type. */
327 boolean_type_node = make_unsigned_type (8);
328 TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
329 SET_TYPE_RM_MAX_VALUE (boolean_type_node,
330 build_int_cst (boolean_type_node, 1));
331 SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
332 boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
333 boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
334
335 sbitsize_one_node = sbitsize_int (1);
336 sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
337
338 ptr_void_type_node = build_pointer_type (void_type_node);
339
340 /* Show that REFERENCE_TYPEs are internal and should be Pmode. */
341 internal_reference_types ();
342
343 /* Register our internal error function. */
344 global_dc->internal_error = &internal_error_function;
345
346 return true;
347 }
348
349 /* If we are using the GCC mechanism to process exception handling, we
350 have to register the personality routine for Ada and to initialize
351 various language dependent hooks. */
352
353 void
gnat_init_gcc_eh(void)354 gnat_init_gcc_eh (void)
355 {
356 /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
357 though. This could for instance lead to the emission of tables with
358 references to symbols (such as the Ada eh personality routine) within
359 libraries we won't link against. */
360 if (No_Exception_Handlers_Set ())
361 return;
362
363 /* Tell GCC we are handling cleanup actions through exception propagation.
364 This opens possibilities that we don't take advantage of yet, but is
365 nonetheless necessary to ensure that fixup code gets assigned to the
366 right exception regions. */
367 using_eh_for_cleanups ();
368
369 /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
370 the generation of the necessary exception tables. The second one is
371 useful for two reasons: 1/ we map some asynchronous signals like SEGV to
372 exceptions, so we need to ensure that the insns which can lead to such
373 signals are correctly attached to the exception region they pertain to,
374 2/ Some calls to pure subprograms are handled as libcall blocks and then
375 marked as "cannot trap" if the flag is not set (see emit_libcall_block).
376 We should not let this be since it is possible for such calls to actually
377 raise in Ada. */
378 flag_exceptions = 1;
379 flag_non_call_exceptions = 1;
380
381 init_eh ();
382 }
383
384 /* Print language-specific items in declaration NODE. */
385
386 static void
gnat_print_decl(FILE * file,tree node,int indent)387 gnat_print_decl (FILE *file, tree node, int indent)
388 {
389 switch (TREE_CODE (node))
390 {
391 case CONST_DECL:
392 print_node (file, "corresponding var",
393 DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
394 break;
395
396 case FIELD_DECL:
397 print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
398 indent + 4);
399 break;
400
401 case VAR_DECL:
402 if (DECL_LOOP_PARM_P (node))
403 print_node (file, "induction var", DECL_INDUCTION_VAR (node),
404 indent + 4);
405 else
406 print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
407 indent + 4);
408 break;
409
410 default:
411 break;
412 }
413 }
414
415 /* Print language-specific items in type NODE. */
416
417 static void
gnat_print_type(FILE * file,tree node,int indent)418 gnat_print_type (FILE *file, tree node, int indent)
419 {
420 switch (TREE_CODE (node))
421 {
422 case FUNCTION_TYPE:
423 print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
424 break;
425
426 case INTEGER_TYPE:
427 if (TYPE_MODULAR_P (node))
428 print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
429 else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
430 print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
431 indent + 4);
432 else if (TYPE_VAX_FLOATING_POINT_P (node))
433 ;
434 else
435 print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
436
437 /* ... fall through ... */
438
439 case ENUMERAL_TYPE:
440 case BOOLEAN_TYPE:
441 print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
442
443 /* ... fall through ... */
444
445 case REAL_TYPE:
446 print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
447 print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
448 break;
449
450 case ARRAY_TYPE:
451 print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
452 break;
453
454 case VECTOR_TYPE:
455 print_node (file,"representative array",
456 TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
457 break;
458
459 case RECORD_TYPE:
460 if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
461 print_node (file, "unconstrained array",
462 TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
463 else
464 print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
465 break;
466
467 case UNION_TYPE:
468 case QUAL_UNION_TYPE:
469 print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
470 break;
471
472 default:
473 break;
474 }
475 }
476
477 /* Return the name to be printed for DECL. */
478
479 static const char *
gnat_printable_name(tree decl,int verbosity)480 gnat_printable_name (tree decl, int verbosity)
481 {
482 const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
483 char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
484
485 __gnat_decode (coded_name, ada_name, 0);
486
487 if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
488 {
489 Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
490 return ggc_strdup (Name_Buffer);
491 }
492
493 return ada_name;
494 }
495
496 /* Return the name to be used in DWARF debug info for DECL. */
497
498 static const char *
gnat_dwarf_name(tree decl,int verbosity ATTRIBUTE_UNUSED)499 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
500 {
501 gcc_assert (DECL_P (decl));
502 return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
503 }
504
505 /* Return the descriptive type associated with TYPE, if any. */
506
507 static tree
gnat_descriptive_type(const_tree type)508 gnat_descriptive_type (const_tree type)
509 {
510 if (TYPE_STUB_DECL (type))
511 return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
512 else
513 return NULL_TREE;
514 }
515
516 /* Return true if types T1 and T2 are identical for type hashing purposes.
517 Called only after doing all language independent checks. At present,
518 this function is only called when both types are FUNCTION_TYPE. */
519
520 static bool
gnat_type_hash_eq(const_tree t1,const_tree t2)521 gnat_type_hash_eq (const_tree t1, const_tree t2)
522 {
523 gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
524 return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
525 TYPE_RETURN_UNCONSTRAINED_P (t2),
526 TYPE_RETURN_BY_DIRECT_REF_P (t2),
527 TREE_ADDRESSABLE (t2));
528 }
529
530 /* Do nothing (return the tree node passed). */
531
532 static tree
gnat_return_tree(tree t)533 gnat_return_tree (tree t)
534 {
535 return t;
536 }
537
538 /* Get the alias set corresponding to a type or expression. */
539
540 static alias_set_type
gnat_get_alias_set(tree type)541 gnat_get_alias_set (tree type)
542 {
543 /* If this is a padding type, use the type of the first field. */
544 if (TYPE_IS_PADDING_P (type))
545 return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
546
547 /* If the type is an unconstrained array, use the type of the
548 self-referential array we make. */
549 else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
550 return
551 get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
552
553 /* If the type can alias any other types, return the alias set 0. */
554 else if (TYPE_P (type)
555 && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
556 return 0;
557
558 return -1;
559 }
560
561 /* GNU_TYPE is a type. Return its maximum size in bytes, if known,
562 as a constant when possible. */
563
564 static tree
gnat_type_max_size(const_tree gnu_type)565 gnat_type_max_size (const_tree gnu_type)
566 {
567 /* First see what we can get from TYPE_SIZE_UNIT, which might not
568 be constant even for simple expressions if it has already been
569 elaborated and possibly replaced by a VAR_DECL. */
570 tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
571
572 /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
573 which should stay untouched. */
574 if (!host_integerp (max_unitsize, 1)
575 && RECORD_OR_UNION_TYPE_P (gnu_type)
576 && !TYPE_FAT_POINTER_P (gnu_type)
577 && TYPE_ADA_SIZE (gnu_type))
578 {
579 tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
580
581 /* If we have succeeded in finding a constant, round it up to the
582 type's alignment and return the result in units. */
583 if (host_integerp (max_adasize, 1))
584 max_unitsize
585 = size_binop (CEIL_DIV_EXPR,
586 round_up (max_adasize, TYPE_ALIGN (gnu_type)),
587 bitsize_unit_node);
588 }
589
590 return max_unitsize;
591 }
592
593 /* GNU_TYPE is a subtype of an integral type. Set LOWVAL to the low bound
594 and HIGHVAL to the high bound, respectively. */
595
596 static void
gnat_get_subrange_bounds(const_tree gnu_type,tree * lowval,tree * highval)597 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
598 {
599 *lowval = TYPE_MIN_VALUE (gnu_type);
600 *highval = TYPE_MAX_VALUE (gnu_type);
601 }
602
603 /* GNU_TYPE is the type of a subprogram parameter. Determine if it should be
604 passed by reference by default. */
605
606 bool
default_pass_by_ref(tree gnu_type)607 default_pass_by_ref (tree gnu_type)
608 {
609 /* We pass aggregates by reference if they are sufficiently large for
610 their alignment. The ratio is somewhat arbitrary. We also pass by
611 reference if the target machine would either pass or return by
612 reference. Strictly speaking, we need only check the return if this
613 is an In Out parameter, but it's probably best to err on the side of
614 passing more things by reference. */
615
616 if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
617 return true;
618
619 if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
620 return true;
621
622 if (AGGREGATE_TYPE_P (gnu_type)
623 && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
624 || 0 < compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
625 TYPE_ALIGN (gnu_type))))
626 return true;
627
628 return false;
629 }
630
631 /* GNU_TYPE is the type of a subprogram parameter. Determine if it must be
632 passed by reference. */
633
634 bool
must_pass_by_ref(tree gnu_type)635 must_pass_by_ref (tree gnu_type)
636 {
637 /* We pass only unconstrained objects, those required by the language
638 to be passed by reference, and objects of variable size. The latter
639 is more efficient, avoids problems with variable size temporaries,
640 and does not produce compatibility problems with C, since C does
641 not have such objects. */
642 return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
643 || TYPE_IS_BY_REFERENCE_P (gnu_type)
644 || (TYPE_SIZE_UNIT (gnu_type)
645 && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST));
646 }
647
648 /* This function is called by the front-end to enumerate all the supported
649 modes for the machine, as well as some predefined C types. F is a function
650 which is called back with the parameters as listed below, first a string,
651 then seven ints. The name is any arbitrary null-terminated string and has
652 no particular significance, except for the case of predefined C types, where
653 it should be the name of the C type. For integer types, only signed types
654 should be listed, unsigned versions are assumed. The order of types should
655 be in order of preference, with the smallest/cheapest types first.
656
657 In particular, C predefined types should be listed before other types,
658 binary floating point types before decimal ones, and narrower/cheaper
659 type versions before more expensive ones. In type selection the first
660 matching variant will be used.
661
662 NAME pointer to first char of type name
663 DIGS number of decimal digits for floating-point modes, else 0
664 COMPLEX_P nonzero is this represents a complex mode
665 COUNT count of number of items, nonzero for vector mode
666 FLOAT_REP Float_Rep_Kind for FP, otherwise undefined
667 PRECISION number of bits used to store data
668 SIZE number of bits occupied by the mode
669 ALIGN number of bits to which mode is aligned. */
670
671 void
enumerate_modes(void (* f)(const char *,int,int,int,int,int,int,int))672 enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
673 {
674 const tree c_types[]
675 = { float_type_node, double_type_node, long_double_type_node };
676 const char *const c_names[]
677 = { "float", "double", "long double" };
678 int iloop;
679
680 for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
681 {
682 enum machine_mode i = (enum machine_mode) iloop;
683 enum machine_mode inner_mode = i;
684 bool float_p = false;
685 bool complex_p = false;
686 bool vector_p = false;
687 bool skip_p = false;
688 int digs = 0;
689 unsigned int nameloop;
690 Float_Rep_Kind float_rep = IEEE_Binary; /* Until proven otherwise */
691
692 switch (GET_MODE_CLASS (i))
693 {
694 case MODE_INT:
695 break;
696 case MODE_FLOAT:
697 float_p = true;
698 break;
699 case MODE_COMPLEX_INT:
700 complex_p = true;
701 inner_mode = GET_MODE_INNER (i);
702 break;
703 case MODE_COMPLEX_FLOAT:
704 float_p = true;
705 complex_p = true;
706 inner_mode = GET_MODE_INNER (i);
707 break;
708 case MODE_VECTOR_INT:
709 vector_p = true;
710 inner_mode = GET_MODE_INNER (i);
711 break;
712 case MODE_VECTOR_FLOAT:
713 float_p = true;
714 vector_p = true;
715 inner_mode = GET_MODE_INNER (i);
716 break;
717 default:
718 skip_p = true;
719 }
720
721 if (float_p)
722 {
723 const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
724
725 /* ??? Cope with the ghost XFmode of the ARM port. */
726 if (!fmt)
727 continue;
728
729 if (fmt->b == 2)
730 digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
731
732 else if (fmt->b == 10)
733 digs = fmt->p;
734
735 else
736 gcc_unreachable();
737
738 if (fmt == &vax_f_format
739 || fmt == &vax_d_format
740 || fmt == &vax_g_format)
741 float_rep = VAX_Native;
742 }
743
744 /* First register any C types for this mode that the front end
745 may need to know about, unless the mode should be skipped. */
746 if (!skip_p && !vector_p)
747 for (nameloop = 0; nameloop < ARRAY_SIZE (c_types); nameloop++)
748 {
749 tree type = c_types[nameloop];
750 const char *name = c_names[nameloop];
751
752 if (TYPE_MODE (type) == i)
753 {
754 f (name, digs, complex_p, 0, float_rep, TYPE_PRECISION (type),
755 TREE_INT_CST_LOW (TYPE_SIZE (type)), TYPE_ALIGN (type));
756 skip_p = true;
757 }
758 }
759
760 /* If no predefined C types were found, register the mode itself. */
761 if (!skip_p)
762 f (GET_MODE_NAME (i), digs, complex_p,
763 vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
764 GET_MODE_PRECISION (i), GET_MODE_BITSIZE (i),
765 GET_MODE_ALIGNMENT (i));
766 }
767 }
768
769 /* Return the size of the FP mode with precision PREC. */
770
771 int
fp_prec_to_size(int prec)772 fp_prec_to_size (int prec)
773 {
774 enum machine_mode mode;
775
776 for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
777 mode = GET_MODE_WIDER_MODE (mode))
778 if (GET_MODE_PRECISION (mode) == prec)
779 return GET_MODE_BITSIZE (mode);
780
781 gcc_unreachable ();
782 }
783
784 /* Return the precision of the FP mode with size SIZE. */
785
786 int
fp_size_to_prec(int size)787 fp_size_to_prec (int size)
788 {
789 enum machine_mode mode;
790
791 for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
792 mode = GET_MODE_WIDER_MODE (mode))
793 if (GET_MODE_BITSIZE (mode) == size)
794 return GET_MODE_PRECISION (mode);
795
796 gcc_unreachable ();
797 }
798
799 static GTY(()) tree gnat_eh_personality_decl;
800
801 /* Return the GNAT personality function decl. */
802
803 static tree
gnat_eh_personality(void)804 gnat_eh_personality (void)
805 {
806 if (!gnat_eh_personality_decl)
807 gnat_eh_personality_decl = build_personality_function ("gnat");
808 return gnat_eh_personality_decl;
809 }
810
811 /* Initialize language-specific bits of tree_contains_struct. */
812
813 static void
gnat_init_ts(void)814 gnat_init_ts (void)
815 {
816 MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
817
818 MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
819 MARK_TS_TYPED (NULL_EXPR);
820 MARK_TS_TYPED (PLUS_NOMOD_EXPR);
821 MARK_TS_TYPED (MINUS_NOMOD_EXPR);
822 MARK_TS_TYPED (ATTR_ADDR_EXPR);
823 MARK_TS_TYPED (STMT_STMT);
824 MARK_TS_TYPED (LOOP_STMT);
825 MARK_TS_TYPED (EXIT_STMT);
826 }
827
828 /* Definitions for our language-specific hooks. */
829
830 #undef LANG_HOOKS_NAME
831 #define LANG_HOOKS_NAME "GNU Ada"
832 #undef LANG_HOOKS_IDENTIFIER_SIZE
833 #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
834 #undef LANG_HOOKS_INIT
835 #define LANG_HOOKS_INIT gnat_init
836 #undef LANG_HOOKS_OPTION_LANG_MASK
837 #define LANG_HOOKS_OPTION_LANG_MASK gnat_option_lang_mask
838 #undef LANG_HOOKS_INIT_OPTIONS_STRUCT
839 #define LANG_HOOKS_INIT_OPTIONS_STRUCT gnat_init_options_struct
840 #undef LANG_HOOKS_INIT_OPTIONS
841 #define LANG_HOOKS_INIT_OPTIONS gnat_init_options
842 #undef LANG_HOOKS_HANDLE_OPTION
843 #define LANG_HOOKS_HANDLE_OPTION gnat_handle_option
844 #undef LANG_HOOKS_POST_OPTIONS
845 #define LANG_HOOKS_POST_OPTIONS gnat_post_options
846 #undef LANG_HOOKS_PARSE_FILE
847 #define LANG_HOOKS_PARSE_FILE gnat_parse_file
848 #undef LANG_HOOKS_TYPE_HASH_EQ
849 #define LANG_HOOKS_TYPE_HASH_EQ gnat_type_hash_eq
850 #undef LANG_HOOKS_GETDECLS
851 #define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
852 #undef LANG_HOOKS_PUSHDECL
853 #define LANG_HOOKS_PUSHDECL gnat_return_tree
854 #undef LANG_HOOKS_WRITE_GLOBALS
855 #define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations
856 #undef LANG_HOOKS_GET_ALIAS_SET
857 #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
858 #undef LANG_HOOKS_PRINT_DECL
859 #define LANG_HOOKS_PRINT_DECL gnat_print_decl
860 #undef LANG_HOOKS_PRINT_TYPE
861 #define LANG_HOOKS_PRINT_TYPE gnat_print_type
862 #undef LANG_HOOKS_TYPE_MAX_SIZE
863 #define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size
864 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
865 #define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name
866 #undef LANG_HOOKS_DWARF_NAME
867 #define LANG_HOOKS_DWARF_NAME gnat_dwarf_name
868 #undef LANG_HOOKS_GIMPLIFY_EXPR
869 #define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr
870 #undef LANG_HOOKS_TYPE_FOR_MODE
871 #define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode
872 #undef LANG_HOOKS_TYPE_FOR_SIZE
873 #define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size
874 #undef LANG_HOOKS_TYPES_COMPATIBLE_P
875 #define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
876 #undef LANG_HOOKS_GET_SUBRANGE_BOUNDS
877 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS gnat_get_subrange_bounds
878 #undef LANG_HOOKS_DESCRIPTIVE_TYPE
879 #define LANG_HOOKS_DESCRIPTIVE_TYPE gnat_descriptive_type
880 #undef LANG_HOOKS_ATTRIBUTE_TABLE
881 #define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table
882 #undef LANG_HOOKS_BUILTIN_FUNCTION
883 #define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function
884 #undef LANG_HOOKS_EH_PERSONALITY
885 #define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality
886 #undef LANG_HOOKS_DEEP_UNSHARING
887 #define LANG_HOOKS_DEEP_UNSHARING true
888 #undef LANG_HOOKS_INIT_TS
889 #define LANG_HOOKS_INIT_TS gnat_init_ts
890
891 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
892
893 #include "gt-ada-misc.h"
894