gcc/fortran/error.cc

   1 /* Handle errors.
   2    Copyright (C) 2000-2024 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught & Niels Kristian Bech Jensen
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 /* Handle the inevitable errors.  A major catch here is that things
  22    flagged as errors in one match subroutine can conceivably be legal
  23    elsewhere.  This means that error messages are recorded and saved
  24    for possible use later.  If a line does not match a legal
  25    construction, then the saved error message is reported.  */
  26
  27 #define INCLUDE_MEMORY
  28 #include "config.h"
  29 #include "system.h"
  30 #include "coretypes.h"
  31 #include "options.h"
  32 #include "gfortran.h"
  33
  34 #include "diagnostic.h"
  35 #include "diagnostic-color.h"
  36 #include "tree-diagnostic.h" /* tree_diagnostics_defaults */
  37 #include "diagnostic-format-text.h"
  38
  39 static int suppress_errors = 0;
  40
  41 static bool warnings_not_errors = false;
  42
  43 /* True if the error/warnings should be buffered.  */
  44 static bool buffered_p;
  45
  46 static gfc_error_buffer *error_buffer;
  47 static diagnostic_buffer *pp_error_buffer, *pp_warning_buffer;
  48
  49 gfc_error_buffer::gfc_error_buffer ()
  50 : flag (false), buffer (*global_dc)
  51 {
  52 }
  53
  54 /* Return a location_t suitable for 'tree' for a gfortran locus.  During
  55    parsing in gfortran, loc->u.lb->location contains only the line number
  56    and LOCATION_COLUMN is 0; hence, the column has to be added when generating
  57    locations for 'tree'.  If available, return location_t directly, which
  58    might be a range. */
  59
  60 location_t
  61 gfc_get_location_with_offset (locus *loc, unsigned offset)
  62 {
  63   if (loc->nextc == (gfc_char_t *) -1)
  64     {
  65       gcc_checking_assert (offset == 0);
  66       return loc->u.location;
  67     }
  68   gcc_checking_assert (loc->nextc >= loc->u.lb->line);
  69   return linemap_position_for_loc_and_offset (line_table, loc->u.lb->location,
  70                                               loc->nextc - loc->u.lb->line
  71                                               + offset);
  72 }
  73
  74 /* Convert a locus to a range. */
  75
  76 locus
  77 gfc_get_location_range (locus *caret_loc, unsigned caret_offset,
  78                         locus *start_loc, unsigned start_offset,
  79                         locus *end_loc)
  80 {
  81   location_t caret;
  82   location_t start = gfc_get_location_with_offset (start_loc, start_offset);
  83   location_t end = gfc_get_location_with_offset (end_loc, 0);
  84
  85   if (caret_loc)
  86     caret = gfc_get_location_with_offset (caret_loc, caret_offset);
  87
  88   locus range;
  89   range.nextc = (gfc_char_t *) -1;
  90   range.u.location = make_location (caret_loc ? caret : start, start, end);
  91   return range;
  92 }
  93
  94 /* Return buffered_p.  */
  95 bool
  96 gfc_buffered_p (void)
  97 {
  98   return buffered_p;
  99 }
 100
 101 /* Go one level deeper suppressing errors.  */
 102
 103 void
 104 gfc_push_suppress_errors (void)
 105 {
 106   gcc_assert (suppress_errors >= 0);
 107   ++suppress_errors;
 108 }
 109
 110 static void
 111 gfc_error_opt (int opt, const char *gmsgid, va_list ap)  ATTRIBUTE_GCC_GFC(2,0);
 112
 113 static bool
 114 gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
 115
 116
 117 /* Leave one level of error suppressing.  */
 118
 119 void
 120 gfc_pop_suppress_errors (void)
 121 {
 122   gcc_assert (suppress_errors > 0);
 123   --suppress_errors;
 124 }
 125
 126
 127 /* Query whether errors are suppressed.  */
 128
 129 bool
 130 gfc_query_suppress_errors (void)
 131 {
 132   return suppress_errors > 0;
 133 }
 134
 135
 136 /* Per-file error initialization.  */
 137
 138 void
 139 gfc_error_init_1 (void)
 140 {
 141   gfc_buffer_error (false);
 142 }
 143
 144
 145 /* Set the flag for buffering errors or not.  */
 146
 147 void
 148 gfc_buffer_error (bool flag)
 149 {
 150   buffered_p = flag;
 151 }
 152
 153
 154 static int
 155 print_wide_char_into_buffer (gfc_char_t c, char *buf)
 156 {
 157   static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
 158     '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
 159
 160   if (gfc_wide_is_printable (c) || c == '\t')
 161     {
 162       buf[1] = '\0';
 163       /* Tabulation is output as a space.  */
 164       buf[0] = (unsigned char) (c == '\t' ? ' ' : c);
 165       return 1;
 166     }
 167   else if (c < ((gfc_char_t) 1 << 8))
 168     {
 169       buf[4] = '\0';
 170       buf[3] = xdigit[c & 0x0F];
 171       c = c >> 4;
 172       buf[2] = xdigit[c & 0x0F];
 173
 174       buf[1] = 'x';
 175       buf[0] = '\\';
 176       return 4;
 177     }
 178   else if (c < ((gfc_char_t) 1 << 16))
 179     {
 180       buf[6] = '\0';
 181       buf[5] = xdigit[c & 0x0F];
 182       c = c >> 4;
 183       buf[4] = xdigit[c & 0x0F];
 184       c = c >> 4;
 185       buf[3] = xdigit[c & 0x0F];
 186       c = c >> 4;
 187       buf[2] = xdigit[c & 0x0F];
 188
 189       buf[1] = 'u';
 190       buf[0] = '\\';
 191       return 6;
 192     }
 193   else
 194     {
 195       buf[10] = '\0';
 196       buf[9] = xdigit[c & 0x0F];
 197       c = c >> 4;
 198       buf[8] = xdigit[c & 0x0F];
 199       c = c >> 4;
 200       buf[7] = xdigit[c & 0x0F];
 201       c = c >> 4;
 202       buf[6] = xdigit[c & 0x0F];
 203       c = c >> 4;
 204       buf[5] = xdigit[c & 0x0F];
 205       c = c >> 4;
 206       buf[4] = xdigit[c & 0x0F];
 207       c = c >> 4;
 208       buf[3] = xdigit[c & 0x0F];
 209       c = c >> 4;
 210       buf[2] = xdigit[c & 0x0F];
 211
 212       buf[1] = 'U';
 213       buf[0] = '\\';
 214       return 10;
 215     }
 216 }
 217
 218 static char wide_char_print_buffer[11];
 219
 220 const char *
 221 gfc_print_wide_char (gfc_char_t c)
 222 {
 223   print_wide_char_into_buffer (c, wide_char_print_buffer);
 224   return wide_char_print_buffer;
 225 }
 226
 227
 228 /* Clear any output buffered in THIS_BUFFER without issuing
 229    it to global_dc.  */
 230
 231 static void
 232 gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer)
 233 {
 234   gcc_assert (this_buffer);
 235   global_dc->clear_diagnostic_buffer (*this_buffer);
 236 }
 237
 238 /* The currently-printing diagnostic, for use by gfc_format_decoder,
 239    for colorizing %C and %L.  */
 240
 241 static diagnostic_info *curr_diagnostic;
 242
 243 /* A helper function to call diagnostic_report_diagnostic, while setting
 244    curr_diagnostic for the duration of the call.  */
 245
 246 static bool
 247 gfc_report_diagnostic (diagnostic_info *diagnostic)
 248 {
 249   gcc_assert (diagnostic != NULL);
 250   curr_diagnostic = diagnostic;
 251   bool ret = diagnostic_report_diagnostic (global_dc, diagnostic);
 252   curr_diagnostic = NULL;
 253   return ret;
 254 }
 255
 256 /* This is just a helper function to avoid duplicating the logic of
 257    gfc_warning.  */
 258
 259 static bool
 260 gfc_warning (int opt, const char *gmsgid, va_list ap)
 261 {
 262   va_list argp;
 263   va_copy (argp, ap);
 264
 265   diagnostic_info diagnostic;
 266   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 267   diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer ();
 268   gcc_assert (!old_buffer);
 269
 270   gfc_clear_diagnostic_buffer (pp_warning_buffer);
 271
 272   if (buffered_p)
 273     global_dc->set_diagnostic_buffer (pp_warning_buffer);
 274
 275   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
 276                        DK_WARNING);
 277   diagnostic.option_id = opt;
 278   bool ret = gfc_report_diagnostic (&diagnostic);
 279
 280   if (buffered_p)
 281     global_dc->set_diagnostic_buffer (old_buffer);
 282
 283   va_end (argp);
 284   return ret;
 285 }
 286
 287 /* Issue a warning.  */
 288
 289 bool
 290 gfc_warning (int opt, const char *gmsgid, ...)
 291 {
 292   va_list argp;
 293
 294   va_start (argp, gmsgid);
 295   bool ret = gfc_warning (opt, gmsgid, argp);
 296   va_end (argp);
 297   return ret;
 298 }
 299
 300
 301 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 302    we should issue an error or a warning, or be quiet.  */
 303
 304 notification
 305 gfc_notification_std (int std)
 306 {
 307   bool warning;
 308
 309   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 310   if ((gfc_option.allow_std & std) != 0 && !warning)
 311     return SILENT;
 312
 313   return warning ? WARNING : ERROR;
 314 }
 315
 316
 317 /* Return a string describing the nature of a standard violation
 318  * and/or the relevant version of the standard.  */
 319
 320 char const*
 321 notify_std_msg(int std)
 322 {
 323
 324   if (std & GFC_STD_F2023_DEL)
 325     return _("Prohibited in Fortran 2023:");
 326   else if (std & GFC_STD_F2023)
 327     return _("Fortran 2023:");
 328   else if (std & GFC_STD_F2018_DEL)
 329     return _("Fortran 2018 deleted feature:");
 330   else if (std & GFC_STD_F2018_OBS)
 331     return _("Fortran 2018 obsolescent feature:");
 332   else if (std & GFC_STD_F2018)
 333     return _("Fortran 2018:");
 334   else if (std & GFC_STD_F2008_OBS)
 335     return _("Fortran 2008 obsolescent feature:");
 336   else if (std & GFC_STD_F2008)
 337     return "Fortran 2008:";
 338   else if (std & GFC_STD_F2003)
 339     return "Fortran 2003:";
 340   else if (std & GFC_STD_GNU)
 341     return _("GNU Extension:");
 342   else if (std & GFC_STD_LEGACY)
 343     return _("Legacy Extension:");
 344   else if (std & GFC_STD_F95_OBS)
 345     return _("Obsolescent feature:");
 346   else if (std & GFC_STD_F95_DEL)
 347     return _("Deleted feature:");
 348   else if (std & GFC_STD_UNSIGNED)
 349     return _("Unsigned:");
 350   else
 351     gcc_unreachable ();
 352 }
 353
 354
 355 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 356    feature.  An error/warning will be issued if the currently selected
 357    standard does not contain the requested bits.  Return false if
 358    an error is generated.  */
 359
 360 bool
 361 gfc_notify_std (int std, const char *gmsgid, ...)
 362 {
 363   va_list argp;
 364   const char *msg, *msg2;
 365   char *buffer;
 366
 367   /* Determine whether an error or a warning is needed.  */
 368   const int wstd = std & gfc_option.warn_std;    /* Standard to warn about.  */
 369   const int estd = std & ~gfc_option.allow_std;  /* Standard to error about.  */
 370   const bool warning = (wstd != 0) && !inhibit_warnings;
 371   const bool error = (estd != 0);
 372
 373   if (!error && !warning)
 374     return true;
 375   if (suppress_errors)
 376     return !error;
 377
 378   if (error)
 379     msg = notify_std_msg (estd);
 380   else
 381     msg = notify_std_msg (wstd);
 382
 383   msg2 = _(gmsgid);
 384   buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
 385   strcpy (buffer, msg);
 386   strcat (buffer, " ");
 387   strcat (buffer, msg2);
 388
 389   va_start (argp, gmsgid);
 390   if (error)
 391     gfc_error_opt (0, buffer, argp);
 392   else
 393     gfc_warning (0, buffer, argp);
 394   va_end (argp);
 395
 396   if (error)
 397     return false;
 398   else
 399     return (warning && !warnings_are_errors);
 400 }
 401
 402
 403 /* Called from output_format -- during diagnostic message processing
 404    to handle Fortran specific format specifiers with the following meanings:
 405
 406    %C  Current locus (no argument)
 407    %L  Takes locus argument
 408 */
 409 static bool
 410 gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
 411                     int precision, bool wide, bool set_locus, bool hash,
 412                     bool *quoted, pp_token_list &formatted_token_list)
 413 {
 414   unsigned offset = 0;
 415   switch (*spec)
 416     {
 417     case 'C':
 418     case 'L':
 419       {
 420         static const char *result[2] = { "(1)", "(2)" };
 421         locus *loc;
 422         if (*spec == 'C')
 423           {
 424             loc = &gfc_current_locus;
 425             /* Point %C first offending character not the last good one. */
 426             if (*loc->nextc != '\0')
 427               offset++;
 428           }
 429         else
 430           loc = va_arg (*text->m_args_ptr, locus *);
 431
 432         /* If location[0] != UNKNOWN_LOCATION means that we already
 433            processed one of %C/%L.  */
 434         int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1;
 435         location_t src_loc = gfc_get_location_with_offset (loc, offset);
 436         text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET);
 437         /* Colorize the markers to match the color choices of
 438            diagnostic_show_locus (the initial location has a color given
 439            by the "kind" of the diagnostic, the secondary location has
 440            color "range1").  */
 441         gcc_assert (curr_diagnostic != NULL);
 442         const char *color
 443           = (loc_num
 444              ? "range1"
 445              : diagnostic_get_color_for_kind (curr_diagnostic->kind));
 446         pp_string (pp, colorize_start (pp_show_color (pp), color));
 447         pp_string (pp, result[loc_num]);
 448         pp_string (pp, colorize_stop (pp_show_color (pp)));
 449         return true;
 450       }
 451     default:
 452       /* Fall through info the middle-end decoder, as e.g. stor-layout.cc
 453          etc. diagnostics can use the FE printer while the FE is still
 454          active.  */
 455       return default_tree_printer (pp, text, spec, precision, wide,
 456                                    set_locus, hash, quoted,
 457                                    formatted_token_list);
 458     }
 459 }
 460
 461 /* Return a malloc'd string describing the kind of diagnostic.  The
 462    caller is responsible for freeing the memory.  */
 463 static char *
 464 gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
 465                                   const diagnostic_info *diagnostic)
 466 {
 467   static const char *const diagnostic_kind_text[] = {
 468 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
 469 #include "gfc-diagnostic.def"
 470 #undef DEFINE_DIAGNOSTIC_KIND
 471     "must-not-happen"
 472   };
 473   static const char *const diagnostic_kind_color[] = {
 474 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
 475 #include "gfc-diagnostic.def"
 476 #undef DEFINE_DIAGNOSTIC_KIND
 477     NULL
 478   };
 479   gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
 480   const char *text = _(diagnostic_kind_text[diagnostic->kind]);
 481   const char *text_cs = "", *text_ce = "";
 482   pretty_printer *const pp = context->get_reference_printer ();
 483
 484   if (diagnostic_kind_color[diagnostic->kind])
 485     {
 486       text_cs = colorize_start (pp_show_color (pp),
 487                                 diagnostic_kind_color[diagnostic->kind]);
 488       text_ce = colorize_stop (pp_show_color (pp));
 489     }
 490   return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
 491 }
 492
 493 /* Return a malloc'd string describing a location.  The caller is
 494    responsible for freeing the memory.  */
 495 static char *
 496 gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy,
 497                                    expanded_location s,
 498                                    bool colorize)
 499 {
 500   const char *locus_cs = colorize_start (colorize, "locus");
 501   const char *locus_ce = colorize_stop (colorize);
 502   return (s.file == NULL
 503           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
 504           : !strcmp (s.file, special_fname_builtin ())
 505           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
 506           : loc_policy.show_column_p ()
 507           ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
 508                                   s.column, locus_ce)
 509           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
 510 }
 511
 512 /* Return a malloc'd string describing two locations.  The caller is
 513    responsible for freeing the memory.  */
 514 static char *
 515 gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy,
 516                                    expanded_location s, expanded_location s2,
 517                                    bool colorize)
 518 {
 519   const char *locus_cs = colorize_start (colorize, "locus");
 520   const char *locus_ce = colorize_stop (colorize);
 521
 522   return (s.file == NULL
 523           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
 524           : !strcmp (s.file, special_fname_builtin ())
 525           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
 526           : loc_policy.show_column_p ()
 527           ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
 528                                   MIN (s.column, s2.column),
 529                                   MAX (s.column, s2.column), locus_ce)
 530           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
 531                                   locus_ce));
 532 }
 533
 534 /* This function prints the locus (file:line:column), the diagnostic kind
 535    (Error, Warning) and (optionally) the relevant lines of code with
 536    annotation lines with '1' and/or '2' below them.
 537
 538    With -fdiagnostic-show-caret (the default) it prints:
 539
 540        [locus of primary range]:
 541
 542           some code
 543                  1
 544        Error: Some error at (1)
 545
 546   With -fno-diagnostic-show-caret or if the primary range is not
 547   valid, it prints:
 548
 549        [locus of primary range]: Error: Some error at (1) and (2)
 550 */
 551 static void
 552 gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output,
 553                              const diagnostic_info *diagnostic)
 554 {
 555   diagnostic_context *const context = &text_output.get_context ();
 556   pretty_printer *const pp = text_output.get_printer ();
 557   char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
 558
 559   expanded_location s1 = diagnostic_expand_location (diagnostic);
 560   expanded_location s2;
 561   bool one_locus = diagnostic->richloc->get_num_locations () < 2;
 562   bool same_locus = false;
 563
 564   if (!one_locus)
 565     {
 566       s2 = diagnostic_expand_location (diagnostic, 1);
 567       same_locus = diagnostic_same_line (context, s1, s2);
 568     }
 569
 570   diagnostic_location_print_policy loc_policy (text_output);
 571   const bool colorize = pp_show_color (pp);
 572   char * locus_prefix = (one_locus || !same_locus)
 573     ? gfc_diagnostic_build_locus_prefix (loc_policy, s1, colorize)
 574     : gfc_diagnostic_build_locus_prefix (loc_policy, s1, s2, colorize);
 575
 576   if (!context->m_source_printing.enabled
 577       || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION
 578       || diagnostic_location (diagnostic, 0) == context->m_last_location)
 579     {
 580       pp_set_prefix (pp,
 581                      concat (locus_prefix, " ", kind_prefix, NULL));
 582       free (locus_prefix);
 583
 584       if (one_locus || same_locus)
 585         {
 586           free (kind_prefix);
 587           return;
 588         }
 589       /* In this case, we print the previous locus and prefix as:
 590
 591           [locus]:[prefix]: (1)
 592
 593          and we flush with a new line before setting the new prefix.  */
 594       pp_string (pp, "(1)");
 595       pp_newline (pp);
 596       locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, s2, colorize);
 597       pp_set_prefix (pp,
 598                      concat (locus_prefix, " ", kind_prefix, NULL));
 599       free (kind_prefix);
 600       free (locus_prefix);
 601     }
 602   else
 603     {
 604       pp_verbatim (pp, "%s", locus_prefix);
 605       free (locus_prefix);
 606       /* Fortran uses an empty line between locus and caret line.  */
 607       pp_newline (pp);
 608       pp_set_prefix (pp, NULL);
 609       pp_newline (pp);
 610       diagnostic_show_locus (context, diagnostic->richloc, diagnostic->kind,
 611                              pp);
 612       /* If the caret line was shown, the prefix does not contain the
 613          locus.  */
 614       pp_set_prefix (pp, kind_prefix);
 615     }
 616 }
 617
 618 static void
 619 gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy,
 620                            pretty_printer *pp,
 621                            expanded_location exploc)
 622 {
 623   const bool colorize = pp_show_color (pp);
 624   char *locus_prefix
 625     = gfc_diagnostic_build_locus_prefix (loc_policy, exploc, colorize);
 626   pp_verbatim (pp, "%s", locus_prefix);
 627   free (locus_prefix);
 628   pp_newline (pp);
 629   /* Fortran uses an empty line between locus and caret line.  */
 630   pp_newline (pp);
 631 }
 632
 633
 634 static void
 635 gfc_diagnostic_text_finalizer (diagnostic_text_output_format &text_output,
 636                                const diagnostic_info *diagnostic ATTRIBUTE_UNUSED,
 637                                diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED)
 638 {
 639   pretty_printer *const pp = text_output.get_printer ();
 640   pp_destroy_prefix (pp);
 641   pp_newline_and_flush (pp);
 642 }
 643
 644 /* Immediate warning (i.e. do not buffer the warning) with an explicit
 645    location.  */
 646
 647 bool
 648 gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
 649 {
 650   va_list argp;
 651   diagnostic_info diagnostic;
 652   rich_location rich_loc (line_table, loc);
 653   bool ret;
 654
 655   va_start (argp, gmsgid);
 656   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
 657   diagnostic.option_id = opt;
 658   ret = gfc_report_diagnostic (&diagnostic);
 659   va_end (argp);
 660   return ret;
 661 }
 662
 663 /* Immediate warning (i.e. do not buffer the warning).  */
 664
 665 bool
 666 gfc_warning_now (int opt, const char *gmsgid, ...)
 667 {
 668   va_list argp;
 669   diagnostic_info diagnostic;
 670   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 671   bool ret;
 672
 673   va_start (argp, gmsgid);
 674   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
 675                        DK_WARNING);
 676   diagnostic.option_id = opt;
 677   ret = gfc_report_diagnostic (&diagnostic);
 678   va_end (argp);
 679   return ret;
 680 }
 681
 682 /* Internal warning, do not buffer.  */
 683
 684 bool
 685 gfc_warning_internal (int opt, const char *gmsgid, ...)
 686 {
 687   va_list argp;
 688   diagnostic_info diagnostic;
 689   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 690   bool ret;
 691
 692   va_start (argp, gmsgid);
 693   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
 694                        DK_WARNING);
 695   diagnostic.option_id = opt;
 696   ret = gfc_report_diagnostic (&diagnostic);
 697   va_end (argp);
 698   return ret;
 699 }
 700
 701 /* Immediate error (i.e. do not buffer).  */
 702
 703 void
 704 gfc_error_now (const char *gmsgid, ...)
 705 {
 706   va_list argp;
 707   diagnostic_info diagnostic;
 708   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 709
 710   error_buffer->flag = true;
 711
 712   va_start (argp, gmsgid);
 713   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
 714   gfc_report_diagnostic (&diagnostic);
 715   va_end (argp);
 716 }
 717
 718
 719 /* Fatal error, never returns.  */
 720
 721 void
 722 gfc_fatal_error (const char *gmsgid, ...)
 723 {
 724   va_list argp;
 725   diagnostic_info diagnostic;
 726   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 727
 728   va_start (argp, gmsgid);
 729   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
 730   gfc_report_diagnostic (&diagnostic);
 731   va_end (argp);
 732
 733   gcc_unreachable ();
 734 }
 735
 736 /* Clear the warning flag.  */
 737
 738 void
 739 gfc_clear_warning (void)
 740 {
 741   gfc_clear_diagnostic_buffer (pp_warning_buffer);
 742 }
 743
 744
 745 /* Check to see if any warnings have been saved.
 746    If so, print the warning.  */
 747
 748 void
 749 gfc_warning_check (void)
 750 {
 751   if (! pp_warning_buffer->empty_p ())
 752     global_dc->flush_diagnostic_buffer (*pp_warning_buffer);
 753 }
 754
 755
 756 /* Issue an error.  */
 757
 758 static void
 759 gfc_error_opt (int opt, const char *gmsgid, va_list ap)
 760 {
 761   va_list argp;
 762   va_copy (argp, ap);
 763
 764   if (warnings_not_errors)
 765     {
 766       gfc_warning (opt, gmsgid, argp);
 767       va_end (argp);
 768       return;
 769     }
 770
 771   if (suppress_errors)
 772     {
 773       va_end (argp);
 774       return;
 775     }
 776
 777   diagnostic_info diagnostic;
 778   rich_location richloc (line_table, UNKNOWN_LOCATION);
 779   diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer ();
 780   gcc_assert (!old_buffer);
 781
 782   gfc_clear_diagnostic_buffer (pp_error_buffer);
 783
 784   if (buffered_p)
 785     global_dc->set_diagnostic_buffer (pp_error_buffer);
 786
 787   diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
 788   gfc_report_diagnostic (&diagnostic);
 789
 790   if (buffered_p)
 791     global_dc->set_diagnostic_buffer (old_buffer);
 792
 793   va_end (argp);
 794 }
 795
 796
 797 void
 798 gfc_error_opt (int opt, const char *gmsgid, ...)
 799 {
 800   va_list argp;
 801   va_start (argp, gmsgid);
 802   gfc_error_opt (opt, gmsgid, argp);
 803   va_end (argp);
 804 }
 805
 806
 807 void
 808 gfc_error (const char *gmsgid, ...)
 809 {
 810   va_list argp;
 811   va_start (argp, gmsgid);
 812   gfc_error_opt (0, gmsgid, argp);
 813   va_end (argp);
 814 }
 815
 816
 817 /* This shouldn't happen... but sometimes does.  */
 818
 819 void
 820 gfc_internal_error (const char *gmsgid, ...)
 821 {
 822   int e, w;
 823   va_list argp;
 824   diagnostic_info diagnostic;
 825   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 826
 827   gfc_get_errors (&w, &e);
 828   if (e > 0)
 829     exit(EXIT_FAILURE);
 830
 831   va_start (argp, gmsgid);
 832   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
 833   gfc_report_diagnostic (&diagnostic);
 834   va_end (argp);
 835
 836   gcc_unreachable ();
 837 }
 838
 839
 840 /* Clear the error flag when we start to compile a source line.  */
 841
 842 void
 843 gfc_clear_error (void)
 844 {
 845   error_buffer->flag = false;
 846   warnings_not_errors = false;
 847   gfc_clear_diagnostic_buffer (pp_error_buffer);
 848 }
 849
 850
 851 /* Tests the state of error_flag.  */
 852
 853 bool
 854 gfc_error_flag_test (void)
 855 {
 856   return (error_buffer->flag
 857           || !pp_error_buffer->empty_p ());
 858 }
 859
 860
 861 /* Check to see if any errors have been saved.
 862    If so, print the error.  Returns the state of error_flag.  */
 863
 864 bool
 865 gfc_error_check (void)
 866 {
 867   if (error_buffer->flag
 868       || ! pp_error_buffer->empty_p ())
 869     {
 870       error_buffer->flag = false;
 871       global_dc->flush_diagnostic_buffer (*pp_error_buffer);
 872       return true;
 873     }
 874
 875   return false;
 876 }
 877
 878 /* Move the text buffered from FROM to TO, then clear
 879    FROM. Independently if there was text in FROM, TO is also
 880    cleared. */
 881
 882 static void
 883 gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
 884                                gfc_error_buffer * buffer_to)
 885 {
 886   diagnostic_buffer * from = &(buffer_from->buffer);
 887   diagnostic_buffer * to =  &(buffer_to->buffer);
 888
 889   buffer_to->flag = buffer_from->flag;
 890   buffer_from->flag = false;
 891
 892   gfc_clear_diagnostic_buffer (to);
 893
 894   if (! from->empty_p ())
 895     {
 896       from->move_to (*to);
 897       gfc_clear_diagnostic_buffer (from);
 898     }
 899 }
 900
 901 /* Save the existing error state.  */
 902
 903 void
 904 gfc_push_error (gfc_error_buffer *err)
 905 {
 906   gfc_move_error_buffer_from_to (error_buffer, err);
 907 }
 908
 909
 910 /* Restore a previous pushed error state.  */
 911
 912 void
 913 gfc_pop_error (gfc_error_buffer *err)
 914 {
 915   gfc_move_error_buffer_from_to (err, error_buffer);
 916 }
 917
 918
 919 /* Free a pushed error state, but keep the current error state.  */
 920
 921 void
 922 gfc_free_error (gfc_error_buffer *err)
 923 {
 924   gfc_clear_diagnostic_buffer (&(err->buffer));
 925 }
 926
 927
 928 /* Report the number of warnings and errors that occurred to the caller.  */
 929
 930 void
 931 gfc_get_errors (int *w, int *e)
 932 {
 933   if (w != NULL)
 934     *w = warningcount + werrorcount;
 935   if (e != NULL)
 936     *e = errorcount + sorrycount + werrorcount;
 937 }
 938
 939
 940 /* Switch errors into warnings.  */
 941
 942 void
 943 gfc_errors_to_warnings (bool f)
 944 {
 945   warnings_not_errors = f;
 946 }
 947
 948 void
 949 gfc_diagnostics_init (void)
 950 {
 951   diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter;
 952   diagnostic_start_span (global_dc) = gfc_diagnostic_start_span;
 953   diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer;
 954   global_dc->set_format_decoder (gfc_format_decoder);
 955   global_dc->m_source_printing.caret_chars[0] = '1';
 956   global_dc->m_source_printing.caret_chars[1] = '2';
 957   pp_warning_buffer = new diagnostic_buffer (*global_dc);
 958   error_buffer = new gfc_error_buffer ();
 959   pp_error_buffer = &(error_buffer->buffer);
 960 }
 961
 962 void
 963 gfc_diagnostics_finish (void)
 964 {
 965   tree_diagnostics_defaults (global_dc);
 966   /* We still want to use the gfc starter and finalizer, not the tree
 967      defaults.  */
 968   diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter;
 969   diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer;
 970   global_dc->m_source_printing.caret_chars[0] = '^';
 971   global_dc->m_source_printing.caret_chars[1] = '^';
 972   delete error_buffer;
 973   error_buffer = nullptr;
 974   pp_error_buffer = nullptr;
 975 }