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