1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * M I S C *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2018, 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 "target.h"
30 #include "tree.h"
31 #include "diagnostic.h"
32 #include "opts.h"
33 #include "alias.h"
34 #include "fold-const.h"
35 #include "stor-layout.h"
36 #include "print-tree.h"
37 #include "toplev.h"
38 #include "langhooks.h"
39 #include "langhooks-def.h"
40 #include "plugin.h"
41 #include "calls.h" /* For pass_by_reference. */
42 #include "dwarf2out.h"
43
44 #include "ada.h"
45 #include "adadecode.h"
46 #include "types.h"
47 #include "atree.h"
48 #include "namet.h"
49 #include "nlists.h"
50 #include "uintp.h"
51 #include "fe.h"
52 #include "sinfo.h"
53 #include "einfo.h"
54 #include "ada-tree.h"
55 #include "gigi.h"
56
57 /* This symbol needs to be defined for the front-end. */
58 void *callgraph_info_file = NULL;
59
60 /* Command-line argc and argv. These variables are global since they are
61 imported in back_end.adb. */
62 unsigned int save_argc;
63 const char **save_argv;
64
65 /* GNAT argc and argv generated by the binder for all Ada programs. */
66 extern int gnat_argc;
67 extern const char **gnat_argv;
68
69 /* Ada code requires variables for these settings rather than elements
70 of the global_options structure because they are imported. */
71 #undef gnat_encodings
72 enum dwarf_gnat_encodings gnat_encodings = DWARF_GNAT_ENCODINGS_DEFAULT;
73
74 #undef optimize
75 int optimize;
76
77 #undef optimize_size
78 int optimize_size;
79
80 #undef flag_compare_debug
81 int flag_compare_debug;
82
83 #undef flag_short_enums
84 int flag_short_enums;
85
86 #undef flag_stack_check
87 enum stack_check_type flag_stack_check = NO_STACK_CHECK;
88
89 #ifdef __cplusplus
90 extern "C" {
91 #endif
92
93 /* Declare functions we use as part of startup. */
94 extern void __gnat_initialize (void *);
95 extern void __gnat_install_SEH_handler (void *);
96 extern void adainit (void);
97 extern void _ada_gnat1drv (void);
98
99 #ifdef __cplusplus
100 }
101 #endif
102
103 /* The parser for the language. For us, we process the GNAT tree. */
104
105 static void
gnat_parse_file(void)106 gnat_parse_file (void)
107 {
108 int seh[2];
109
110 /* Call the target specific initializations. */
111 __gnat_initialize (NULL);
112
113 /* ??? Call the SEH initialization routine. This is to workaround
114 a bootstrap path problem. The call below should be removed at some
115 point and the SEH pointer passed to __gnat_initialize above. */
116 __gnat_install_SEH_handler ((void *)seh);
117
118 /* Call the front-end elaboration procedures. */
119 adainit ();
120
121 /* Call the front end. */
122 _ada_gnat1drv ();
123
124 /* Write the global declarations. */
125 gnat_write_global_declarations ();
126 }
127
128 /* Return language mask for option processing. */
129
130 static unsigned int
gnat_option_lang_mask(void)131 gnat_option_lang_mask (void)
132 {
133 return CL_Ada;
134 }
135
136 /* Decode all the language specific options that cannot be decoded by GCC.
137 The option decoding phase of GCC calls this routine on the flags that
138 are marked as Ada-specific. Return true on success or false on failure. */
139
140 static bool
gnat_handle_option(size_t scode,const char * arg,int value,int kind,location_t loc,const struct cl_option_handlers * handlers)141 gnat_handle_option (size_t scode, const char *arg, int value, int kind,
142 location_t loc, const struct cl_option_handlers *handlers)
143 {
144 enum opt_code code = (enum opt_code) scode;
145
146 switch (code)
147 {
148 case OPT_Wall:
149 handle_generated_option (&global_options, &global_options_set,
150 OPT_Wunused, NULL, value,
151 gnat_option_lang_mask (), kind, loc,
152 handlers, true, global_dc);
153 warn_uninitialized = value;
154 warn_maybe_uninitialized = value;
155 break;
156
157 case OPT_gant:
158 warning (0, "%<-gnat%> misspelled as %<-gant%>");
159
160 /* ... fall through ... */
161
162 case OPT_gnat:
163 case OPT_gnatO:
164 case OPT_fRTS_:
165 case OPT_I:
166 case OPT_nostdinc:
167 case OPT_nostdlib:
168 /* These are handled by the front-end. */
169 break;
170
171 case OPT_fshort_enums:
172 case OPT_fsigned_char:
173 /* These are handled by the middle-end. */
174 break;
175
176 case OPT_fbuiltin_printf:
177 /* This is ignored in Ada but needs to be accepted so it can be
178 defaulted. */
179 break;
180
181 default:
182 gcc_unreachable ();
183 }
184
185 Ada_handle_option_auto (&global_options, &global_options_set,
186 scode, arg, value,
187 gnat_option_lang_mask (), kind, loc,
188 handlers, global_dc);
189 return true;
190 }
191
192 /* Initialize options structure OPTS. */
193
194 static void
gnat_init_options_struct(struct gcc_options * opts)195 gnat_init_options_struct (struct gcc_options *opts)
196 {
197 /* Uninitialized really means uninitialized in Ada. */
198 opts->x_flag_zero_initialized_in_bss = 0;
199
200 /* We don't care about errno in Ada and it causes __builtin_sqrt to
201 call the libm function rather than do it inline. */
202 opts->x_flag_errno_math = 0;
203 opts->frontend_set_flag_errno_math = true;
204 }
205
206 /* Initialize for option processing. */
207
208 static void
gnat_init_options(unsigned int decoded_options_count,struct cl_decoded_option * decoded_options)209 gnat_init_options (unsigned int decoded_options_count,
210 struct cl_decoded_option *decoded_options)
211 {
212 /* Reconstruct an argv array for use of back_end.adb.
213
214 ??? back_end.adb should not rely on this; instead, it should work with
215 decoded options without such reparsing, to ensure consistency in how
216 options are decoded. */
217 save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
218 save_argc = 0;
219 for (unsigned int i = 0; i < decoded_options_count; i++)
220 {
221 size_t num_elements = decoded_options[i].canonical_option_num_elements;
222
223 if (decoded_options[i].errors
224 || decoded_options[i].opt_index == OPT_SPECIAL_unknown
225 || num_elements == 0)
226 continue;
227
228 /* Deal with -I- specially since it must be a single switch. */
229 if (decoded_options[i].opt_index == OPT_I
230 && num_elements == 2
231 && decoded_options[i].canonical_option[1][0] == '-'
232 && decoded_options[i].canonical_option[1][1] == '\0')
233 save_argv[save_argc++] = "-I-";
234 else
235 {
236 gcc_assert (num_elements >= 1 && num_elements <= 2);
237 save_argv[save_argc++] = decoded_options[i].canonical_option[0];
238 if (num_elements >= 2)
239 save_argv[save_argc++] = decoded_options[i].canonical_option[1];
240 }
241 }
242 save_argv[save_argc] = NULL;
243
244 /* Pass just the name of the command through the regular channel. */
245 gnat_argv = (const char **) xmalloc (sizeof (char *));
246 gnat_argv[0] = xstrdup (save_argv[0]);
247 gnat_argc = 1;
248 }
249
250 /* Settings adjustments after switches processing by the back-end.
251 Note that the front-end switches processing (Scan_Compiler_Arguments)
252 has not been done yet at this point! */
253
254 static bool
gnat_post_options(const char ** pfilename ATTRIBUTE_UNUSED)255 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
256 {
257 /* Excess precision other than "fast" requires front-end support. */
258 if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD)
259 sorry ("-fexcess-precision=standard for Ada");
260 flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
261
262 /* No psABI change warnings for Ada. */
263 warn_psabi = 0;
264
265 /* No return type warnings for Ada. */
266 warn_return_type = 0;
267
268 /* No string overflow warnings for Ada. */
269 warn_stringop_overflow = 0;
270
271 /* No caret by default for Ada. */
272 if (!global_options_set.x_flag_diagnostics_show_caret)
273 global_dc->show_caret = false;
274
275 /* Warn only if STABS is not the default: we don't want to emit a warning if
276 the user did not use a -gstabs option. */
277 if (PREFERRED_DEBUGGING_TYPE != DBX_DEBUG && write_symbols == DBX_DEBUG)
278 warning (0, "STABS debugging information for Ada is obsolete and not "
279 "supported anymore");
280
281 /* Copy global settings to local versions. */
282 gnat_encodings = global_options.x_gnat_encodings;
283 optimize = global_options.x_optimize;
284 optimize_size = global_options.x_optimize_size;
285 flag_compare_debug = global_options.x_flag_compare_debug;
286 flag_stack_check = global_options.x_flag_stack_check;
287 flag_short_enums = global_options.x_flag_short_enums;
288
289 /* Unfortunately the post_options hook is called before the value of
290 flag_short_enums is autodetected, if need be. Mimic the process
291 for our private flag_short_enums. */
292 if (flag_short_enums == 2)
293 flag_short_enums = targetm.default_short_enums ();
294
295 return false;
296 }
297
298 /* Here is the function to handle the compiler error processing in GCC. */
299
300 static void
internal_error_function(diagnostic_context * context,const char * msgid,va_list * ap)301 internal_error_function (diagnostic_context *context, const char *msgid,
302 va_list *ap)
303 {
304 text_info tinfo;
305 char *buffer, *p, *loc;
306 String_Template temp, temp_loc;
307 String_Pointer sp, sp_loc;
308 expanded_location xloc;
309
310 /* Warn if plugins present. */
311 warn_if_plugins ();
312
313 /* Reset the pretty-printer. */
314 pp_clear_output_area (context->printer);
315
316 /* Format the message into the pretty-printer. */
317 tinfo.format_spec = msgid;
318 tinfo.args_ptr = ap;
319 tinfo.err_no = errno;
320 pp_format_verbatim (context->printer, &tinfo);
321
322 /* Extract a (writable) pointer to the formatted text. */
323 buffer = xstrdup (pp_formatted_text (context->printer));
324
325 /* Go up to the first newline. */
326 for (p = buffer; *p; p++)
327 if (*p == '\n')
328 {
329 *p = '\0';
330 break;
331 }
332
333 temp.Low_Bound = 1;
334 temp.High_Bound = p - buffer;
335 sp.Bounds = &temp;
336 sp.Array = buffer;
337
338 xloc = expand_location (input_location);
339 if (context->show_column && xloc.column != 0)
340 loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column);
341 else
342 loc = xasprintf ("%s:%d", xloc.file, xloc.line);
343 temp_loc.Low_Bound = 1;
344 temp_loc.High_Bound = strlen (loc);
345 sp_loc.Bounds = &temp_loc;
346 sp_loc.Array = loc;
347
348 Current_Error_Node = error_gnat_node;
349 Compiler_Abort (sp, sp_loc, true);
350 }
351
352 /* Perform all the initialization steps that are language-specific. */
353
354 static bool
gnat_init(void)355 gnat_init (void)
356 {
357 /* Do little here, most of the standard declarations are set up after the
358 front-end has been run. Use the same `char' as C for Interfaces.C. */
359 build_common_tree_nodes (flag_signed_char);
360
361 /* In Ada, we use an unsigned 8-bit type for the default boolean type. */
362 boolean_type_node = make_unsigned_type (8);
363 TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
364 SET_TYPE_RM_MAX_VALUE (boolean_type_node,
365 build_int_cst (boolean_type_node, 1));
366 SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
367 boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
368 boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
369
370 sbitsize_one_node = sbitsize_int (1);
371 sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
372
373 /* Register our internal error function. */
374 global_dc->internal_error = &internal_error_function;
375
376 return true;
377 }
378
379 /* Initialize the GCC support for exception handling. */
380
381 void
gnat_init_gcc_eh(void)382 gnat_init_gcc_eh (void)
383 {
384 /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
385 though. This could for instance lead to the emission of tables with
386 references to symbols (such as the Ada eh personality routine) within
387 libraries we won't link against. */
388 if (No_Exception_Handlers_Set ())
389 return;
390
391 /* Tell GCC we are handling cleanup actions through exception propagation.
392 This opens possibilities that we don't take advantage of yet, but is
393 nonetheless necessary to ensure that fixup code gets assigned to the
394 right exception regions. */
395 using_eh_for_cleanups ();
396
397 /* Turn on -fexceptions, -fnon-call-exceptions and -fdelete-dead-exceptions.
398 The first one activates the support for exceptions in the compiler.
399 The second one is useful for two reasons: 1/ we map some asynchronous
400 signals like SEGV to exceptions, so we need to ensure that the insns
401 which can lead to such signals are correctly attached to the exception
402 region they pertain to, 2/ some calls to pure subprograms are handled as
403 libcall blocks and then marked as "cannot trap" if the flag is not set
404 (see emit_libcall_block). We should not let this be since it is possible
405 for such calls to actually raise in Ada.
406 The third one is an optimization that makes it possible to delete dead
407 instructions that may throw exceptions, most notably loads and stores,
408 as permitted in Ada.
409 Turn off -faggressive-loop-optimizations because it may optimize away
410 out-of-bound array accesses that we want to be able to catch.
411 If checks are disabled, we use the same settings as the C++ compiler,
412 except for the runtime on platforms where S'Machine_Overflow is true
413 because the runtime depends on FP (hardware) checks being properly
414 handled despite being compiled in -gnatp mode. */
415 flag_exceptions = 1;
416 flag_delete_dead_exceptions = 1;
417 if (Suppress_Checks)
418 {
419 if (!global_options_set.x_flag_non_call_exceptions)
420 flag_non_call_exceptions = Machine_Overflows_On_Target && GNAT_Mode;
421 }
422 else
423 {
424 flag_non_call_exceptions = 1;
425 flag_aggressive_loop_optimizations = 0;
426 warn_aggressive_loop_optimizations = 0;
427 }
428
429 init_eh ();
430 }
431
432 /* Initialize the GCC support for floating-point operations. */
433
434 void
gnat_init_gcc_fp(void)435 gnat_init_gcc_fp (void)
436 {
437 /* Disable FP optimizations that ignore the signedness of zero if
438 S'Signed_Zeros is true, but don't override the user if not. */
439 if (Signed_Zeros_On_Target)
440 flag_signed_zeros = 1;
441 else if (!global_options_set.x_flag_signed_zeros)
442 flag_signed_zeros = 0;
443
444 /* Assume that FP operations can trap if S'Machine_Overflow is true,
445 but don't override the user if not. */
446 if (Machine_Overflows_On_Target)
447 flag_trapping_math = 1;
448 else if (!global_options_set.x_flag_trapping_math)
449 flag_trapping_math = 0;
450 }
451
452 /* Print language-specific items in declaration NODE. */
453
454 static void
gnat_print_decl(FILE * file,tree node,int indent)455 gnat_print_decl (FILE *file, tree node, int indent)
456 {
457 switch (TREE_CODE (node))
458 {
459 case CONST_DECL:
460 print_node (file, "corresponding var",
461 DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
462 break;
463
464 case FIELD_DECL:
465 print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
466 indent + 4);
467 break;
468
469 case VAR_DECL:
470 if (DECL_LOOP_PARM_P (node))
471 print_node (file, "induction var", DECL_INDUCTION_VAR (node),
472 indent + 4);
473 else
474 print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
475 indent + 4);
476 break;
477
478 default:
479 break;
480 }
481 }
482
483 /* Print language-specific items in type NODE. */
484
485 static void
gnat_print_type(FILE * file,tree node,int indent)486 gnat_print_type (FILE *file, tree node, int indent)
487 {
488 switch (TREE_CODE (node))
489 {
490 case FUNCTION_TYPE:
491 print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
492 break;
493
494 case INTEGER_TYPE:
495 if (TYPE_MODULAR_P (node))
496 print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
497 else if (TYPE_FIXED_POINT_P (node))
498 print_node (file, "scale factor", TYPE_SCALE_FACTOR (node),
499 indent + 4);
500 else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
501 print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
502 indent + 4);
503 else
504 print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
505
506 /* ... fall through ... */
507
508 case ENUMERAL_TYPE:
509 case BOOLEAN_TYPE:
510 print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
511
512 /* ... fall through ... */
513
514 case REAL_TYPE:
515 print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
516 print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
517 break;
518
519 case ARRAY_TYPE:
520 print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
521 break;
522
523 case VECTOR_TYPE:
524 print_node (file,"representative array",
525 TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
526 break;
527
528 case RECORD_TYPE:
529 if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
530 print_node (file, "unconstrained array",
531 TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
532 else
533 print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
534 break;
535
536 case UNION_TYPE:
537 case QUAL_UNION_TYPE:
538 print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
539 break;
540
541 default:
542 break;
543 }
544
545 if (TYPE_CAN_HAVE_DEBUG_TYPE_P (node) && TYPE_DEBUG_TYPE (node))
546 print_node_brief (file, "debug type", TYPE_DEBUG_TYPE (node), indent + 4);
547
548 if (TYPE_IMPL_PACKED_ARRAY_P (node) && TYPE_ORIGINAL_PACKED_ARRAY (node))
549 print_node_brief (file, "original packed array",
550 TYPE_ORIGINAL_PACKED_ARRAY (node), indent + 4);
551 }
552
553 /* Return the name to be printed for DECL. */
554
555 static const char *
gnat_printable_name(tree decl,int verbosity)556 gnat_printable_name (tree decl, int verbosity)
557 {
558 const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
559 char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
560
561 __gnat_decode (coded_name, ada_name, 0);
562
563 if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
564 {
565 Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
566 return ggc_strdup (Name_Buffer);
567 }
568
569 return ada_name;
570 }
571
572 /* Return the name to be used in DWARF debug info for DECL. */
573
574 static const char *
gnat_dwarf_name(tree decl,int verbosity ATTRIBUTE_UNUSED)575 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
576 {
577 gcc_assert (DECL_P (decl));
578 return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
579 }
580
581 /* Return the descriptive type associated with TYPE, if any. */
582
583 static tree
gnat_descriptive_type(const_tree type)584 gnat_descriptive_type (const_tree type)
585 {
586 if (TYPE_STUB_DECL (type))
587 return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
588 else
589 return NULL_TREE;
590 }
591
592 /* Return the underlying base type of an enumeration type. */
593
594 static tree
gnat_enum_underlying_base_type(const_tree)595 gnat_enum_underlying_base_type (const_tree)
596 {
597 /* Enumeration types are base types in Ada. */
598 return void_type_node;
599 }
600
601 /* Return the type to be used for debugging information instead of TYPE or
602 NULL_TREE if TYPE is fine. */
603
604 static tree
gnat_get_debug_type(const_tree type)605 gnat_get_debug_type (const_tree type)
606 {
607 if (TYPE_CAN_HAVE_DEBUG_TYPE_P (type) && TYPE_DEBUG_TYPE (type))
608 {
609 type = TYPE_DEBUG_TYPE (type);
610
611 /* ??? The get_debug_type language hook is processed after the array
612 descriptor language hook, so if there is an array behind this type,
613 the latter is supposed to handle it. Still, we can get here with
614 a type we are not supposed to handle (e.g. when the DWARF back-end
615 processes the type of a variable), so keep this guard. */
616 if (type && TYPE_CAN_HAVE_DEBUG_TYPE_P (type))
617 return const_cast<tree> (type);
618 }
619
620 return NULL_TREE;
621 }
622
623 /* Provide information in INFO for debugging output about the TYPE fixed-point
624 type. Return whether TYPE is handled. */
625
626 static bool
gnat_get_fixed_point_type_info(const_tree type,struct fixed_point_type_info * info)627 gnat_get_fixed_point_type_info (const_tree type,
628 struct fixed_point_type_info *info)
629 {
630 tree scale_factor;
631
632 /* GDB cannot handle fixed-point types yet, so rely on GNAT encodings
633 instead for it. */
634 if (!TYPE_IS_FIXED_POINT_P (type)
635 || gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
636 return false;
637
638 scale_factor = TYPE_SCALE_FACTOR (type);
639
640 /* We expect here only a finite set of pattern. See fixed-point types
641 handling in gnat_to_gnu_entity. */
642
643 /* Put invalid values when compiler internals cannot represent the scale
644 factor. */
645 if (scale_factor == integer_zero_node)
646 {
647 info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
648 info->scale_factor.arbitrary.numerator = 0;
649 info->scale_factor.arbitrary.denominator = 0;
650 return true;
651 }
652
653 if (TREE_CODE (scale_factor) == RDIV_EXPR)
654 {
655 const tree num = TREE_OPERAND (scale_factor, 0);
656 const tree den = TREE_OPERAND (scale_factor, 1);
657
658 /* See if we have a binary or decimal scale. */
659 if (TREE_CODE (den) == POWER_EXPR)
660 {
661 const tree base = TREE_OPERAND (den, 0);
662 const tree exponent = TREE_OPERAND (den, 1);
663
664 /* We expect the scale factor to be 1 / 2 ** N or 1 / 10 ** N. */
665 gcc_assert (num == integer_one_node
666 && TREE_CODE (base) == INTEGER_CST
667 && TREE_CODE (exponent) == INTEGER_CST);
668
669 switch (tree_to_shwi (base))
670 {
671 case 2:
672 info->scale_factor_kind = fixed_point_scale_factor_binary;
673 info->scale_factor.binary = -tree_to_shwi (exponent);
674 return true;
675
676 case 10:
677 info->scale_factor_kind = fixed_point_scale_factor_decimal;
678 info->scale_factor.decimal = -tree_to_shwi (exponent);
679 return true;
680
681 default:
682 gcc_unreachable ();
683 }
684 }
685
686 /* If we reach this point, we are handling an arbitrary scale factor. We
687 expect N / D with constant operands. */
688 gcc_assert (TREE_CODE (num) == INTEGER_CST
689 && TREE_CODE (den) == INTEGER_CST);
690
691 info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
692 info->scale_factor.arbitrary.numerator = tree_to_uhwi (num);
693 info->scale_factor.arbitrary.denominator = tree_to_shwi (den);
694 return true;
695 }
696
697 gcc_unreachable ();
698 }
699
700 /* Return true if types T1 and T2 are identical for type hashing purposes.
701 Called only after doing all language independent checks. At present,
702 this function is only called when both types are FUNCTION_TYPE. */
703
704 static bool
gnat_type_hash_eq(const_tree t1,const_tree t2)705 gnat_type_hash_eq (const_tree t1, const_tree t2)
706 {
707 gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
708 return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
709 TYPE_RETURN_UNCONSTRAINED_P (t2),
710 TYPE_RETURN_BY_DIRECT_REF_P (t2),
711 TREE_ADDRESSABLE (t2));
712 }
713
714 /* Do nothing (return the tree node passed). */
715
716 static tree
gnat_return_tree(tree t)717 gnat_return_tree (tree t)
718 {
719 return t;
720 }
721
722 /* Get the alias set corresponding to a type or expression. */
723
724 static alias_set_type
gnat_get_alias_set(tree type)725 gnat_get_alias_set (tree type)
726 {
727 /* If this is a padding type, use the type of the first field. */
728 if (TYPE_IS_PADDING_P (type))
729 return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
730
731 /* If the type is an unconstrained array, use the type of the
732 self-referential array we make. */
733 else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
734 return
735 get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
736
737 /* If the type can alias any other types, return the alias set 0. */
738 else if (TYPE_P (type)
739 && !TYPE_IS_DUMMY_P (type)
740 && TYPE_UNIVERSAL_ALIASING_P (type))
741 return 0;
742
743 return -1;
744 }
745
746 /* GNU_TYPE is a type. Return its maximum size in bytes, if known,
747 as a constant when possible. */
748
749 static tree
gnat_type_max_size(const_tree gnu_type)750 gnat_type_max_size (const_tree gnu_type)
751 {
752 /* First see what we can get from TYPE_SIZE_UNIT, which might not
753 be constant even for simple expressions if it has already been
754 elaborated and possibly replaced by a VAR_DECL. */
755 tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
756
757 /* If we don't have a constant, try to look at attributes which should have
758 stayed untouched. */
759 if (!tree_fits_uhwi_p (max_unitsize))
760 {
761 /* For record types, see what we can get from TYPE_ADA_SIZE. */
762 if (RECORD_OR_UNION_TYPE_P (gnu_type)
763 && !TYPE_FAT_POINTER_P (gnu_type)
764 && TYPE_ADA_SIZE (gnu_type))
765 {
766 tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
767
768 /* If we have succeeded in finding a constant, round it up to the
769 type's alignment and return the result in units. */
770 if (tree_fits_uhwi_p (max_adasize))
771 max_unitsize
772 = size_binop (CEIL_DIV_EXPR,
773 round_up (max_adasize, TYPE_ALIGN (gnu_type)),
774 bitsize_unit_node);
775 }
776
777 /* For array types, see what we can get from TYPE_INDEX_TYPE. */
778 else if (TREE_CODE (gnu_type) == ARRAY_TYPE
779 && TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))
780 && tree_fits_uhwi_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_type))))
781 {
782 tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
783 tree hb = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
784 if (TREE_CODE (lb) != INTEGER_CST
785 && TYPE_RM_SIZE (TREE_TYPE (lb))
786 && compare_tree_int (TYPE_RM_SIZE (TREE_TYPE (lb)), 16) <= 0)
787 lb = TYPE_MIN_VALUE (TREE_TYPE (lb));
788 if (TREE_CODE (hb) != INTEGER_CST
789 && TYPE_RM_SIZE (TREE_TYPE (hb))
790 && compare_tree_int (TYPE_RM_SIZE (TREE_TYPE (hb)), 16) <= 0)
791 hb = TYPE_MAX_VALUE (TREE_TYPE (hb));
792 if (TREE_CODE (lb) == INTEGER_CST && TREE_CODE (hb) == INTEGER_CST)
793 {
794 tree ctype = get_base_type (TREE_TYPE (lb));
795 lb = fold_convert (ctype, lb);
796 hb = fold_convert (ctype, hb);
797 if (tree_int_cst_le (lb, hb))
798 {
799 tree length
800 = fold_build2 (PLUS_EXPR, ctype,
801 fold_build2 (MINUS_EXPR, ctype, hb, lb),
802 build_int_cst (ctype, 1));
803 max_unitsize
804 = fold_build2 (MULT_EXPR, sizetype,
805 fold_convert (sizetype, length),
806 TYPE_SIZE_UNIT (TREE_TYPE (gnu_type)));
807 }
808 }
809 }
810 }
811
812 return max_unitsize;
813 }
814
815 static tree get_array_bit_stride (tree);
816
817 /* Provide information in INFO for debug output about the TYPE array type.
818 Return whether TYPE is handled. */
819
820 static bool
gnat_get_array_descr_info(const_tree const_type,struct array_descr_info * info)821 gnat_get_array_descr_info (const_tree const_type,
822 struct array_descr_info *info)
823 {
824 bool convention_fortran_p;
825 bool is_array = false;
826 bool is_fat_ptr = false;
827 bool is_packed_array = false;
828 tree type = const_cast<tree> (const_type);
829 const_tree first_dimen = NULL_TREE;
830 const_tree last_dimen = NULL_TREE;
831 const_tree dimen;
832 int i;
833
834 /* Temporaries created in the first pass and used in the second one for thin
835 pointers. The first one is an expression that yields the template record
836 from the base address (i.e. the PLACEHOLDER_EXPR). The second one is just
837 a cursor through this record's fields. */
838 tree thinptr_template_expr = NULL_TREE;
839 tree thinptr_bound_field = NULL_TREE;
840
841 /* ??? See gnat_get_debug_type. */
842 type = maybe_debug_type (type);
843
844 /* If we have an implementation type for a packed array, get the orignial
845 array type. */
846 if (TYPE_IMPL_PACKED_ARRAY_P (type) && TYPE_ORIGINAL_PACKED_ARRAY (type))
847 {
848 type = TYPE_ORIGINAL_PACKED_ARRAY (type);
849 is_packed_array = true;
850 }
851
852 /* First pass: gather all information about this array except everything
853 related to dimensions. */
854
855 /* Only handle ARRAY_TYPE nodes that come from GNAT. */
856 if (TREE_CODE (type) == ARRAY_TYPE
857 && TYPE_DOMAIN (type)
858 && TYPE_INDEX_TYPE (TYPE_DOMAIN (type)))
859 {
860 is_array = true;
861 first_dimen = type;
862 info->data_location = NULL_TREE;
863 }
864
865 else if (TYPE_IS_FAT_POINTER_P (type)
866 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
867 {
868 const tree ua_type = TYPE_UNCONSTRAINED_ARRAY (type);
869
870 /* This will be our base object address. */
871 const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
872
873 /* We assume below that maybe_unconstrained_array returns an INDIRECT_REF
874 node. */
875 const tree ua_val
876 = maybe_unconstrained_array (build_unary_op (INDIRECT_REF,
877 ua_type,
878 placeholder_expr));
879
880 is_fat_ptr = true;
881 first_dimen = TREE_TYPE (ua_val);
882
883 /* Get the *address* of the array, not the array itself. */
884 info->data_location = TREE_OPERAND (ua_val, 0);
885 }
886
887 /* Unlike fat pointers (which appear for unconstrained arrays passed in
888 argument), thin pointers are used only for array access types, so we want
889 them to appear in the debug info as pointers to an array type. That's why
890 we match only the RECORD_TYPE here instead of the POINTER_TYPE with the
891 TYPE_IS_THIN_POINTER_P predicate. */
892 else if (TREE_CODE (type) == RECORD_TYPE
893 && TYPE_CONTAINS_TEMPLATE_P (type)
894 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
895 {
896 /* This will be our base object address. Note that we assume that
897 pointers to these will actually point to the array field (thin
898 pointers are shifted). */
899 const tree placeholder_expr = build0 (PLACEHOLDER_EXPR, type);
900 const tree placeholder_addr
901 = build_unary_op (ADDR_EXPR, NULL_TREE, placeholder_expr);
902
903 const tree bounds_field = TYPE_FIELDS (type);
904 const tree bounds_type = TREE_TYPE (bounds_field);
905 const tree array_field = DECL_CHAIN (bounds_field);
906 const tree array_type = TREE_TYPE (array_field);
907
908 /* Shift the thin pointer address to get the address of the template. */
909 const tree shift_amount
910 = fold_build1 (NEGATE_EXPR, sizetype, byte_position (array_field));
911 tree template_addr
912 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (placeholder_addr),
913 placeholder_addr, shift_amount);
914 template_addr
915 = fold_convert (TYPE_POINTER_TO (bounds_type), template_addr);
916
917 first_dimen = array_type;
918
919 /* The thin pointer is already the pointer to the array data, so there's
920 no need for a specific "data location" expression. */
921 info->data_location = NULL_TREE;
922
923 thinptr_template_expr = build_unary_op (INDIRECT_REF,
924 bounds_type,
925 template_addr);
926 thinptr_bound_field = TYPE_FIELDS (bounds_type);
927 }
928 else
929 return false;
930
931 /* Second pass: compute the remaining information: dimensions and
932 corresponding bounds. */
933
934 if (TYPE_PACKED (first_dimen))
935 is_packed_array = true;
936 /* If this array has fortran convention, it's arranged in column-major
937 order, so our view here has reversed dimensions. */
938 convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (first_dimen);
939 /* ??? For row major ordering, we probably want to emit nothing and
940 instead specify it as the default in Dw_TAG_compile_unit. */
941 info->ordering = (convention_fortran_p
942 ? array_descr_ordering_column_major
943 : array_descr_ordering_row_major);
944
945 /* Count how many dimensions this array has. */
946 for (i = 0, dimen = first_dimen; ; ++i, dimen = TREE_TYPE (dimen))
947 {
948 if (i > 0
949 && (TREE_CODE (dimen) != ARRAY_TYPE
950 || !TYPE_MULTI_ARRAY_P (dimen)))
951 break;
952 last_dimen = dimen;
953 }
954
955 info->ndimensions = i;
956 info->rank = NULL_TREE;
957
958 /* Too many dimensions? Give up generating proper description: yield instead
959 nested arrays. Note that in this case, this hook is invoked once on each
960 intermediate array type: be consistent and output nested arrays for all
961 dimensions. */
962 if (info->ndimensions > DWARF2OUT_ARRAY_DESCR_INFO_MAX_DIMEN
963 || TYPE_MULTI_ARRAY_P (first_dimen))
964 {
965 info->ndimensions = 1;
966 last_dimen = first_dimen;
967 }
968
969 info->element_type = TREE_TYPE (last_dimen);
970
971 /* Now iterate over all dimensions in source-order and fill the info
972 structure. */
973 for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
974 dimen = first_dimen;
975 IN_RANGE (i, 0, info->ndimensions - 1);
976 i += (convention_fortran_p ? -1 : 1),
977 dimen = TREE_TYPE (dimen))
978 {
979 /* We are interested in the stored bounds for the debug info. */
980 tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
981
982 if (is_array || is_fat_ptr)
983 {
984 /* GDB does not handle very well the self-referencial bound
985 expressions we are able to generate here for XUA types (they are
986 used only by XUP encodings) so avoid them in this case. Note that
987 there are two cases where we generate self-referencial bound
988 expressions: arrays that are constrained by record discriminants
989 and XUA types. */
990 if (TYPE_CONTEXT (first_dimen)
991 && TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE
992 && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type))
993 && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
994 {
995 info->dimen[i].lower_bound = NULL_TREE;
996 info->dimen[i].upper_bound = NULL_TREE;
997 }
998 else
999 {
1000 info->dimen[i].lower_bound
1001 = maybe_character_value (TYPE_MIN_VALUE (index_type));
1002 info->dimen[i].upper_bound
1003 = maybe_character_value (TYPE_MAX_VALUE (index_type));
1004 }
1005 }
1006
1007 /* This is a thin pointer. */
1008 else
1009 {
1010 info->dimen[i].lower_bound
1011 = build_component_ref (thinptr_template_expr, thinptr_bound_field,
1012 false);
1013 thinptr_bound_field = DECL_CHAIN (thinptr_bound_field);
1014
1015 info->dimen[i].upper_bound
1016 = build_component_ref (thinptr_template_expr, thinptr_bound_field,
1017 false);
1018 thinptr_bound_field = DECL_CHAIN (thinptr_bound_field);
1019 }
1020
1021 /* The DWARF back-end will output BOUNDS_TYPE as the base type of
1022 the array index, so get to the base type of INDEX_TYPE. */
1023 while (TREE_TYPE (index_type))
1024 index_type = TREE_TYPE (index_type);
1025
1026 info->dimen[i].bounds_type = maybe_debug_type (index_type);
1027 info->dimen[i].stride = NULL_TREE;
1028 }
1029
1030 /* These are Fortran-specific fields. They make no sense here. */
1031 info->allocated = NULL_TREE;
1032 info->associated = NULL_TREE;
1033
1034 if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1035 {
1036 /* When arrays contain dynamically-sized elements, we usually wrap them
1037 in padding types, or we create constrained types for them. Then, if
1038 such types are stripped in the debugging information output, the
1039 debugger needs a way to know the size that is reserved for each
1040 element. This is why we emit a stride in such situations. */
1041 tree source_element_type = info->element_type;
1042
1043 while (true)
1044 {
1045 if (TYPE_DEBUG_TYPE (source_element_type))
1046 source_element_type = TYPE_DEBUG_TYPE (source_element_type);
1047 else if (TYPE_IS_PADDING_P (source_element_type))
1048 source_element_type
1049 = TREE_TYPE (TYPE_FIELDS (source_element_type));
1050 else
1051 break;
1052 }
1053
1054 if (TREE_CODE (TYPE_SIZE_UNIT (source_element_type)) != INTEGER_CST)
1055 {
1056 info->stride = TYPE_SIZE_UNIT (info->element_type);
1057 info->stride_in_bits = false;
1058 }
1059
1060 /* We need to specify a bit stride when it does not correspond to the
1061 natural size of the contained elements. ??? Note that we do not
1062 support packed records and nested packed arrays. */
1063 else if (is_packed_array)
1064 {
1065 info->stride = get_array_bit_stride (info->element_type);
1066 info->stride_in_bits = true;
1067 }
1068 }
1069
1070 return true;
1071 }
1072
1073 /* Given the component type COMP_TYPE of a packed array, return an expression
1074 that computes the bit stride of this packed array. Return NULL_TREE when
1075 unsuccessful. */
1076
1077 static tree
get_array_bit_stride(tree comp_type)1078 get_array_bit_stride (tree comp_type)
1079 {
1080 struct array_descr_info info;
1081 tree stride;
1082
1083 /* Simple case: the array contains an integral type: return its RM size. */
1084 if (INTEGRAL_TYPE_P (comp_type))
1085 return TYPE_RM_SIZE (comp_type);
1086
1087 /* Otherwise, see if this is an array we can analyze; if it's not, punt. */
1088 memset (&info, 0, sizeof (info));
1089 if (!gnat_get_array_descr_info (comp_type, &info) || !info.stride)
1090 return NULL_TREE;
1091
1092 /* Otherwise, the array stride is the inner array's stride multiplied by the
1093 number of elements it contains. Note that if the inner array is not
1094 packed, then the stride is "natural" and thus does not deserve an
1095 attribute. */
1096 stride = info.stride;
1097 if (!info.stride_in_bits)
1098 {
1099 stride = fold_convert (bitsizetype, stride);
1100 stride = build_binary_op (MULT_EXPR, bitsizetype,
1101 stride, build_int_cst (bitsizetype, 8));
1102 }
1103
1104 for (int i = 0; i < info.ndimensions; ++i)
1105 {
1106 tree count;
1107
1108 if (!info.dimen[i].lower_bound || !info.dimen[i].upper_bound)
1109 return NULL_TREE;
1110
1111 /* Put in count an expression that computes the length of this
1112 dimension. */
1113 count = build_binary_op (MINUS_EXPR, sbitsizetype,
1114 fold_convert (sbitsizetype,
1115 info.dimen[i].upper_bound),
1116 fold_convert (sbitsizetype,
1117 info.dimen[i].lower_bound)),
1118 count = build_binary_op (PLUS_EXPR, sbitsizetype,
1119 count, build_int_cst (sbitsizetype, 1));
1120 count = build_binary_op (MAX_EXPR, sbitsizetype,
1121 count,
1122 build_int_cst (sbitsizetype, 0));
1123 count = fold_convert (bitsizetype, count);
1124 stride = build_binary_op (MULT_EXPR, bitsizetype, stride, count);
1125 }
1126
1127 return stride;
1128 }
1129
1130 /* GNU_TYPE is a subtype of an integral type. Set LOWVAL to the low bound
1131 and HIGHVAL to the high bound, respectively. */
1132
1133 static void
gnat_get_subrange_bounds(const_tree gnu_type,tree * lowval,tree * highval)1134 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
1135 {
1136 *lowval = TYPE_MIN_VALUE (gnu_type);
1137 *highval = TYPE_MAX_VALUE (gnu_type);
1138 }
1139
1140 /* Return the bias of GNU_TYPE, if any. */
1141
1142 static tree
gnat_get_type_bias(const_tree gnu_type)1143 gnat_get_type_bias (const_tree gnu_type)
1144 {
1145 if (TREE_CODE (gnu_type) == INTEGER_TYPE
1146 && TYPE_BIASED_REPRESENTATION_P (gnu_type)
1147 && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
1148 return TYPE_RM_MIN_VALUE (gnu_type);
1149
1150 return NULL_TREE;
1151 }
1152
1153 /* GNU_TYPE is the type of a subprogram parameter. Determine if it should be
1154 passed by reference by default. */
1155
1156 bool
default_pass_by_ref(tree gnu_type)1157 default_pass_by_ref (tree gnu_type)
1158 {
1159 /* We pass aggregates by reference if they are sufficiently large for
1160 their alignment. The ratio is somewhat arbitrary. We also pass by
1161 reference if the target machine would either pass or return by
1162 reference. Strictly speaking, we need only check the return if this
1163 is an In Out parameter, but it's probably best to err on the side of
1164 passing more things by reference. */
1165
1166 if (AGGREGATE_TYPE_P (gnu_type)
1167 && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
1168 || compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
1169 TYPE_ALIGN (gnu_type)) > 0))
1170 return true;
1171
1172 if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
1173 return true;
1174
1175 if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
1176 return true;
1177
1178 return false;
1179 }
1180
1181 /* GNU_TYPE is the type of a subprogram parameter. Determine if it must be
1182 passed by reference. */
1183
1184 bool
must_pass_by_ref(tree gnu_type)1185 must_pass_by_ref (tree gnu_type)
1186 {
1187 /* We pass only unconstrained objects, those required by the language
1188 to be passed by reference, and objects of variable size. The latter
1189 is more efficient, avoids problems with variable size temporaries,
1190 and does not produce compatibility problems with C, since C does
1191 not have such objects. */
1192 return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
1193 || TYPE_IS_BY_REFERENCE_P (gnu_type)
1194 || (TYPE_SIZE_UNIT (gnu_type)
1195 && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST));
1196 }
1197
1198 /* This function is called by the front-end to enumerate all the supported
1199 modes for the machine, as well as some predefined C types. F is a function
1200 which is called back with the parameters as listed below, first a string,
1201 then seven ints. The name is any arbitrary null-terminated string and has
1202 no particular significance, except for the case of predefined C types, where
1203 it should be the name of the C type. For integer types, only signed types
1204 should be listed, unsigned versions are assumed. The order of types should
1205 be in order of preference, with the smallest/cheapest types first.
1206
1207 In particular, C predefined types should be listed before other types,
1208 binary floating point types before decimal ones, and narrower/cheaper
1209 type versions before more expensive ones. In type selection the first
1210 matching variant will be used.
1211
1212 NAME pointer to first char of type name
1213 DIGS number of decimal digits for floating-point modes, else 0
1214 COMPLEX_P nonzero is this represents a complex mode
1215 COUNT count of number of items, nonzero for vector mode
1216 FLOAT_REP Float_Rep_Kind for FP, otherwise undefined
1217 PRECISION number of bits used to store data
1218 SIZE number of bits occupied by the mode
1219 ALIGN number of bits to which mode is aligned. */
1220
1221 void
enumerate_modes(void (* f)(const char *,int,int,int,int,int,int,int))1222 enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
1223 {
1224 const tree c_types[]
1225 = { float_type_node, double_type_node, long_double_type_node };
1226 const char *const c_names[]
1227 = { "float", "double", "long double" };
1228 int iloop;
1229
1230 /* We are going to compute it below. */
1231 fp_arith_may_widen = false;
1232
1233 for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
1234 {
1235 machine_mode i = (machine_mode) iloop;
1236 machine_mode inner_mode = i;
1237 bool float_p = false;
1238 bool complex_p = false;
1239 bool vector_p = false;
1240 bool skip_p = false;
1241 int digs = 0;
1242 unsigned int nameloop;
1243 Float_Rep_Kind float_rep = IEEE_Binary; /* Until proven otherwise */
1244
1245 switch (GET_MODE_CLASS (i))
1246 {
1247 case MODE_INT:
1248 break;
1249 case MODE_FLOAT:
1250 float_p = true;
1251 break;
1252 case MODE_COMPLEX_INT:
1253 complex_p = true;
1254 inner_mode = GET_MODE_INNER (i);
1255 break;
1256 case MODE_COMPLEX_FLOAT:
1257 float_p = true;
1258 complex_p = true;
1259 inner_mode = GET_MODE_INNER (i);
1260 break;
1261 case MODE_VECTOR_INT:
1262 vector_p = true;
1263 inner_mode = GET_MODE_INNER (i);
1264 break;
1265 case MODE_VECTOR_FLOAT:
1266 float_p = true;
1267 vector_p = true;
1268 inner_mode = GET_MODE_INNER (i);
1269 break;
1270 default:
1271 skip_p = true;
1272 }
1273
1274 if (float_p)
1275 {
1276 const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
1277
1278 /* ??? Cope with the ghost XFmode of the ARM port. */
1279 if (!fmt)
1280 continue;
1281
1282 /* Be conservative and consider that floating-point arithmetics may
1283 use wider intermediate results as soon as there is an extended
1284 Motorola or Intel mode supported by the machine. */
1285 if (fmt == &ieee_extended_motorola_format
1286 || fmt == &ieee_extended_intel_96_format
1287 || fmt == &ieee_extended_intel_96_round_53_format
1288 || fmt == &ieee_extended_intel_128_format)
1289 {
1290 #ifdef TARGET_FPMATH_DEFAULT
1291 if (TARGET_FPMATH_DEFAULT == FPMATH_387)
1292 #endif
1293 fp_arith_may_widen = true;
1294 }
1295
1296 if (fmt->b == 2)
1297 digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
1298
1299 else if (fmt->b == 10)
1300 digs = fmt->p;
1301
1302 else
1303 gcc_unreachable ();
1304 }
1305
1306 /* First register any C types for this mode that the front end
1307 may need to know about, unless the mode should be skipped. */
1308 if (!skip_p && !vector_p)
1309 for (nameloop = 0; nameloop < ARRAY_SIZE (c_types); nameloop++)
1310 {
1311 tree type = c_types[nameloop];
1312 const char *name = c_names[nameloop];
1313
1314 if (TYPE_MODE (type) == i)
1315 {
1316 f (name, digs, complex_p, 0, float_rep, TYPE_PRECISION (type),
1317 TREE_INT_CST_LOW (TYPE_SIZE (type)), TYPE_ALIGN (type));
1318 skip_p = true;
1319 }
1320 }
1321
1322 /* If no predefined C types were found, register the mode itself. */
1323 int nunits, precision, bitsize;
1324 if (!skip_p
1325 && GET_MODE_NUNITS (i).is_constant (&nunits)
1326 && GET_MODE_PRECISION (i).is_constant (&precision)
1327 && GET_MODE_BITSIZE (i).is_constant (&bitsize))
1328 f (GET_MODE_NAME (i), digs, complex_p,
1329 vector_p ? nunits : 0, float_rep,
1330 precision, bitsize, GET_MODE_ALIGNMENT (i));
1331 }
1332 }
1333
1334 /* Return the size of the FP mode with precision PREC. */
1335
1336 int
fp_prec_to_size(int prec)1337 fp_prec_to_size (int prec)
1338 {
1339 opt_scalar_float_mode opt_mode;
1340
1341 FOR_EACH_MODE_IN_CLASS (opt_mode, MODE_FLOAT)
1342 {
1343 scalar_float_mode mode = opt_mode.require ();
1344 if (GET_MODE_PRECISION (mode) == prec)
1345 return GET_MODE_BITSIZE (mode);
1346 }
1347
1348 gcc_unreachable ();
1349 }
1350
1351 /* Return the precision of the FP mode with size SIZE. */
1352
1353 int
fp_size_to_prec(int size)1354 fp_size_to_prec (int size)
1355 {
1356 opt_scalar_float_mode opt_mode;
1357
1358 FOR_EACH_MODE_IN_CLASS (opt_mode, MODE_FLOAT)
1359 {
1360 scalar_mode mode = opt_mode.require ();
1361 if (GET_MODE_BITSIZE (mode) == size)
1362 return GET_MODE_PRECISION (mode);
1363 }
1364
1365 gcc_unreachable ();
1366 }
1367
1368 static GTY(()) tree gnat_eh_personality_decl;
1369
1370 /* Return the GNAT personality function decl. */
1371
1372 static tree
gnat_eh_personality(void)1373 gnat_eh_personality (void)
1374 {
1375 if (!gnat_eh_personality_decl)
1376 gnat_eh_personality_decl = build_personality_function ("gnat");
1377 return gnat_eh_personality_decl;
1378 }
1379
1380 /* Initialize language-specific bits of tree_contains_struct. */
1381
1382 static void
gnat_init_ts(void)1383 gnat_init_ts (void)
1384 {
1385 MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
1386
1387 MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
1388 MARK_TS_TYPED (NULL_EXPR);
1389 MARK_TS_TYPED (PLUS_NOMOD_EXPR);
1390 MARK_TS_TYPED (MINUS_NOMOD_EXPR);
1391 MARK_TS_TYPED (POWER_EXPR);
1392 MARK_TS_TYPED (ATTR_ADDR_EXPR);
1393 MARK_TS_TYPED (STMT_STMT);
1394 MARK_TS_TYPED (LOOP_STMT);
1395 MARK_TS_TYPED (EXIT_STMT);
1396 }
1397
1398 /* Return the size of a tree with CODE, which is a language-specific tree code
1399 in category tcc_constant, tcc_exceptional or tcc_type. The default expects
1400 never to be called. */
1401
1402 static size_t
gnat_tree_size(enum tree_code code)1403 gnat_tree_size (enum tree_code code)
1404 {
1405 gcc_checking_assert (code >= NUM_TREE_CODES);
1406 switch (code)
1407 {
1408 case UNCONSTRAINED_ARRAY_TYPE:
1409 return sizeof (tree_type_non_common);
1410 default:
1411 gcc_unreachable ();
1412 }
1413 }
1414
1415 /* Return the lang specific structure attached to NODE. Allocate it (cleared)
1416 if needed. */
1417
1418 struct lang_type *
get_lang_specific(tree node)1419 get_lang_specific (tree node)
1420 {
1421 if (!TYPE_LANG_SPECIFIC (node))
1422 TYPE_LANG_SPECIFIC (node) = ggc_cleared_alloc<struct lang_type> ();
1423 return TYPE_LANG_SPECIFIC (node);
1424 }
1425
1426 /* Definitions for our language-specific hooks. */
1427
1428 #undef LANG_HOOKS_NAME
1429 #define LANG_HOOKS_NAME "GNU Ada"
1430 #undef LANG_HOOKS_IDENTIFIER_SIZE
1431 #define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
1432 #undef LANG_HOOKS_TREE_SIZE
1433 #define LANG_HOOKS_TREE_SIZE gnat_tree_size
1434 #undef LANG_HOOKS_INIT
1435 #define LANG_HOOKS_INIT gnat_init
1436 #undef LANG_HOOKS_OPTION_LANG_MASK
1437 #define LANG_HOOKS_OPTION_LANG_MASK gnat_option_lang_mask
1438 #undef LANG_HOOKS_INIT_OPTIONS_STRUCT
1439 #define LANG_HOOKS_INIT_OPTIONS_STRUCT gnat_init_options_struct
1440 #undef LANG_HOOKS_INIT_OPTIONS
1441 #define LANG_HOOKS_INIT_OPTIONS gnat_init_options
1442 #undef LANG_HOOKS_HANDLE_OPTION
1443 #define LANG_HOOKS_HANDLE_OPTION gnat_handle_option
1444 #undef LANG_HOOKS_POST_OPTIONS
1445 #define LANG_HOOKS_POST_OPTIONS gnat_post_options
1446 #undef LANG_HOOKS_PARSE_FILE
1447 #define LANG_HOOKS_PARSE_FILE gnat_parse_file
1448 #undef LANG_HOOKS_TYPE_HASH_EQ
1449 #define LANG_HOOKS_TYPE_HASH_EQ gnat_type_hash_eq
1450 #undef LANG_HOOKS_GETDECLS
1451 #define LANG_HOOKS_GETDECLS hook_tree_void_null
1452 #undef LANG_HOOKS_PUSHDECL
1453 #define LANG_HOOKS_PUSHDECL gnat_return_tree
1454 #undef LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL
1455 #define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL hook_bool_const_tree_false
1456 #undef LANG_HOOKS_GET_ALIAS_SET
1457 #define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
1458 #undef LANG_HOOKS_PRINT_DECL
1459 #define LANG_HOOKS_PRINT_DECL gnat_print_decl
1460 #undef LANG_HOOKS_PRINT_TYPE
1461 #define LANG_HOOKS_PRINT_TYPE gnat_print_type
1462 #undef LANG_HOOKS_TYPE_MAX_SIZE
1463 #define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size
1464 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
1465 #define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name
1466 #undef LANG_HOOKS_DWARF_NAME
1467 #define LANG_HOOKS_DWARF_NAME gnat_dwarf_name
1468 #undef LANG_HOOKS_GIMPLIFY_EXPR
1469 #define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr
1470 #undef LANG_HOOKS_TYPE_FOR_MODE
1471 #define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode
1472 #undef LANG_HOOKS_TYPE_FOR_SIZE
1473 #define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size
1474 #undef LANG_HOOKS_TYPES_COMPATIBLE_P
1475 #define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
1476 #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
1477 #define LANG_HOOKS_GET_ARRAY_DESCR_INFO gnat_get_array_descr_info
1478 #undef LANG_HOOKS_GET_SUBRANGE_BOUNDS
1479 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS gnat_get_subrange_bounds
1480 #undef LANG_HOOKS_GET_TYPE_BIAS
1481 #define LANG_HOOKS_GET_TYPE_BIAS gnat_get_type_bias
1482 #undef LANG_HOOKS_DESCRIPTIVE_TYPE
1483 #define LANG_HOOKS_DESCRIPTIVE_TYPE gnat_descriptive_type
1484 #undef LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE
1485 #define LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE gnat_enum_underlying_base_type
1486 #undef LANG_HOOKS_GET_DEBUG_TYPE
1487 #define LANG_HOOKS_GET_DEBUG_TYPE gnat_get_debug_type
1488 #undef LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO
1489 #define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO gnat_get_fixed_point_type_info
1490 #undef LANG_HOOKS_ATTRIBUTE_TABLE
1491 #define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table
1492 #undef LANG_HOOKS_BUILTIN_FUNCTION
1493 #define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function
1494 #undef LANG_HOOKS_INIT_TS
1495 #define LANG_HOOKS_INIT_TS gnat_init_ts
1496 #undef LANG_HOOKS_EH_PERSONALITY
1497 #define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality
1498 #undef LANG_HOOKS_DEEP_UNSHARING
1499 #define LANG_HOOKS_DEEP_UNSHARING true
1500 #undef LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS
1501 #define LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS true
1502
1503 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
1504
1505 #include "gt-ada-misc.h"
1506