a68g-diagnostics.c

     
   1  //! @file a68g-diagnostics.c
   2  //! @author J. Marcel van der Veer
   3  
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2025 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Error and warning routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-prelude.h"
  28  #include "a68g-transput.h"
  29  #include "a68g-parser.h"
  30  
  31  // Error handling routines.
  32  
  33  #define TABULATE(n) (8 * (n / 8 + 1) - n)
  34  
  35  //! @brief Return error test from errno.
  36  
  37  char *error_specification (void)
  38  {
  39    static BUFFER txt;
  40    if (errno == 0) {
  41      ASSERT (a68g_bufprt (txt, SNPRINTF_SIZE, "no information") >= 0);
  42    } else {
  43      ASSERT (a68g_bufprt (txt, SNPRINTF_SIZE, "%s", strerror (errno)) >= 0);
  44    }
  45    if (strlen (txt) > 0) {
  46      txt[0] = TO_LOWER (txt[0]);
  47    }
  48    return txt;
  49  }
  50  
  51  //! @brief Whether unprintable control character.
  52  
  53  BOOL_T unprintable (char ch)
  54  {
  55    return (BOOL_T) (!IS_PRINT (ch) && ch != TAB_CHAR);
  56  }
  57  
  58  //! @brief Format for printing control character.
  59  
  60  char *ctrl_char (int ch)
  61  {
  62    static char txt[SMALL_BUFFER_SIZE];
  63    ch = TO_UCHAR (ch);
  64    if (IS_CNTRL (ch) && IS_LOWER (ch + 96)) {
  65      ASSERT (a68g_bufprt (txt, (size_t) SMALL_BUFFER_SIZE, "\\^%c", ch + 96) >= 0);
  66    } else {
  67      ASSERT (a68g_bufprt (txt, (size_t) SMALL_BUFFER_SIZE, "\\%02x", (unt) ch) >= 0);
  68    }
  69    return txt;
  70  }
  71  
  72  //! @brief Widen single char to string.
  73  
  74  char *char_to_str (char ch)
  75  {
  76    static char txt[2];
  77    txt[0] = ch;
  78    txt[1] = NULL_CHAR;
  79    return txt;
  80  }
  81  
  82  //! @brief Pretty-print diagnostic.
  83  
  84  void pretty_diag (FILE_T f, char *p)
  85  {
  86    int line_width = (f == A68_STDERR || f == A68_STDOUT ? A68 (term_width) : MAX_TERM_WIDTH);
  87    int pos = 1;
  88    while (p[0] != NULL_CHAR) {
  89      char *q;
  90      int k;
  91  // Count the number of characters in token to print.
  92      if (IS_GRAPH (p[0])) {
  93        for (k = 0, q = p; q[0] != BLANK_CHAR && q[0] != NULL_CHAR && k <= line_width; q++, k++) {
  94          ;
  95        }
  96      } else {
  97        k = 1;
  98      }
  99  // Now see if there is space for the token.
 100      if (k > line_width) {
 101        k = 1;
 102      }
 103      if ((pos + k) >= line_width) {
 104        WRITE (f, NEWLINE_STRING);
 105        pos = 1;
 106      }
 107      for (; k > 0; k--, p++, pos++) {
 108        WRITE (f, char_to_str (p[0]));
 109      }
 110    }
 111    for (; p[0] == BLANK_CHAR; p++, pos++) {
 112      WRITE (f, char_to_str (p[0]));
 113    }
 114  }
 115  
 116  //! @brief Abnormal end.
 117  
 118  void abend (char *reason, char *info, char *file, int line)
 119  {
 120    ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", A68 (a68g_cmd_name), file, line, reason) >= 0);
 121    if (info != NO_TEXT) {
 122      a68g_bufcat (A68 (output_line), ", ", BUFFER_SIZE);
 123      a68g_bufcat (A68 (output_line), info, BUFFER_SIZE);
 124    }
 125    if (errno != 0) {
 126      a68g_bufcat (A68 (output_line), " (", BUFFER_SIZE);
 127      a68g_bufcat (A68 (output_line), error_specification (), BUFFER_SIZE);
 128      a68g_bufcat (A68 (output_line), ")", BUFFER_SIZE);
 129    }
 130    a68g_bufcat (A68 (output_line), "\n", BUFFER_SIZE);
 131    io_close_tty_line ();
 132    pretty_diag (A68_STDERR, A68 (output_line));
 133    a68g_exit (EXIT_FAILURE);
 134  }
 135  
 136  //! @brief Position in line .
 137  
 138  char *where_pos (LINE_T * p, NODE_T * q)
 139  {
 140    char *pos;
 141    if (q != NO_NODE && p == LINE (INFO (q))) {
 142      pos = CHAR_IN_LINE (INFO (q));
 143    } else {
 144      pos = STRING (p);
 145    }
 146    if (pos == NO_TEXT) {
 147      pos = STRING (p);
 148    }
 149    for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) {
 150      ;
 151    }
 152    if (pos[0] == NULL_CHAR) {
 153      pos = STRING (p);
 154    }
 155    return pos;
 156  }
 157  
 158  //! @brief Position in line where diagnostic points at.
 159  
 160  char *diag_pos (LINE_T * p, DIAGNOSTIC_T * d)
 161  {
 162    char *pos;
 163    if (WHERE (d) != NO_NODE && p == LINE (INFO (WHERE (d)))) {
 164      pos = CHAR_IN_LINE (INFO (WHERE (d)));
 165    } else {
 166      pos = STRING (p);
 167    }
 168    if (pos == NO_TEXT) {
 169      pos = STRING (p);
 170    }
 171    for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) {
 172      ;
 173    }
 174    if (pos[0] == NULL_CHAR) {
 175      pos = STRING (p);
 176    }
 177    return pos;
 178  }
 179  
 180  //! @brief Write source line to file with diagnostics.
 181  
 182  void write_source_line (FILE_T f, LINE_T * p, NODE_T * nwhere, int mask)
 183  {
 184    int line_width = (f == A68_STDERR || f == A68_STDOUT ? A68 (term_width) : MAX_TERM_WIDTH);
 185  // Terminate properly.
 186    if ((STRING (p))[strlen (STRING (p)) - 1] == NEWLINE_CHAR) {
 187      (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR;
 188      if ((STRING (p))[strlen (STRING (p)) - 1] == CR_CHAR) {
 189        (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR;
 190      }
 191    }
 192  // Print line number.
 193    if (f == A68_STDERR || f == A68_STDOUT) {
 194      io_close_tty_line ();
 195    } else {
 196      WRITE (f, NEWLINE_STRING);
 197    }
 198    if (NUMBER (p) == 0) {
 199      ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "      ") >= 0);
 200    } else {
 201      ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "%-5d ", NUMBER (p) % 100000) >= 0);
 202    }
 203    WRITE (f, A68 (output_line));
 204  // Pretty print line.
 205    char *c, *c0;
 206    c = c0 = STRING (p);
 207    int pos = 5, col = 1;
 208    int continuations = 0;
 209    BOOL_T line_ended = A68_FALSE;
 210    while (!line_ended) {
 211      int len = 0;
 212      char *new_pos = NO_TEXT;
 213      if (c[0] == NULL_CHAR) {
 214        a68g_bufcpy (A68 (output_line), "", BUFFER_SIZE);
 215        line_ended = A68_TRUE;
 216      } else {
 217        if (IS_GRAPH (c[0])) {
 218          char *c1;
 219          a68g_bufcpy (A68 (output_line), "", BUFFER_SIZE);
 220          for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) {
 221            a68g_bufcat (A68 (output_line), char_to_str (c1[0]), BUFFER_SIZE);
 222          }
 223          if (len > line_width - 5) {
 224            a68g_bufcpy (A68 (output_line), char_to_str (c[0]), BUFFER_SIZE);
 225            len = 1;
 226          }
 227          new_pos = &c[len];
 228          col += len;
 229        } else if (c[0] == TAB_CHAR) {
 230          int n = TABULATE (col);
 231          len = n;
 232          col += n;
 233          a68g_bufcpy (A68 (output_line), "", BUFFER_SIZE);
 234          while (n--) {
 235            a68g_bufcat (A68 (output_line), " ", BUFFER_SIZE);
 236          }
 237          new_pos = &c[1];
 238        } else if (unprintable (c[0])) {
 239          a68g_bufcpy (A68 (output_line), ctrl_char ((int) c[0]), BUFFER_SIZE);
 240          len = (int) strlen (A68 (output_line));
 241          new_pos = &c[1];
 242          col++;
 243        } else {
 244          a68g_bufcpy (A68 (output_line), char_to_str (c[0]), BUFFER_SIZE);
 245          len = 1;
 246          new_pos = &c[1];
 247          col++;
 248        }
 249      }
 250      if (!line_ended && (pos + len) <= line_width) {
 251  // Still room - print a character.
 252        WRITE (f, A68 (output_line));
 253        pos += len;
 254        c = new_pos;
 255      } else {
 256  // First see if there are diagnostics to be printed.
 257        BOOL_T y = A68_FALSE, z = A68_FALSE;
 258        DIAGNOSTIC_T *d = DIAGNOSTICS (p);
 259        if (d != NO_DIAGNOSTIC || nwhere != NO_NODE) {
 260          char *c1;
 261          for (c1 = c0; c1 != c; c1++) {
 262            y |= (BOOL_T) (nwhere != NO_NODE && p == LINE (INFO (nwhere)) ? c1 == where_pos (p, nwhere) : A68_FALSE);
 263            if (mask != A68_NO_DIAGNOSTICS) {
 264              for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) {
 265                z = (BOOL_T) (z | (c1 == diag_pos (p, d)));
 266              }
 267            }
 268          }
 269        }
 270  // If diagnostics are to be printed then print marks.
 271        if (y || z) {
 272          DIAGNOSTIC_T *d2;
 273          char *c1;
 274          int col_2 = 1;
 275          WRITE (f, "\n      ");
 276          for (c1 = c0; c1 != c; c1++) {
 277            int k = 0, diags_at_this_pos = 0;
 278            for (d2 = DIAGNOSTICS (p); d2 != NO_DIAGNOSTIC; FORWARD (d2)) {
 279              if (c1 == diag_pos (p, d2)) {
 280                diags_at_this_pos++;
 281                k = NUMBER (d2);
 282              }
 283            }
 284            if (y == A68_TRUE && c1 == where_pos (p, nwhere)) {
 285              a68g_bufcpy (A68 (output_line), "-", BUFFER_SIZE);
 286            } else if (diags_at_this_pos != 0) {
 287              if (mask == A68_NO_DIAGNOSTICS) {
 288                a68g_bufcpy (A68 (output_line), " ", BUFFER_SIZE);
 289              } else if (diags_at_this_pos == 1) {
 290                ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "%c", digchar (k)) >= 0);
 291              } else {
 292                a68g_bufcpy (A68 (output_line), "*", BUFFER_SIZE);
 293              }
 294            } else {
 295              if (unprintable (c1[0])) {
 296                int n = (int) strlen (ctrl_char (c1[0]));
 297                col_2 += 1;
 298                a68g_bufcpy (A68 (output_line), "", BUFFER_SIZE);
 299                while (n--) {
 300                  a68g_bufcat (A68 (output_line), " ", BUFFER_SIZE);
 301                }
 302              } else if (c1[0] == TAB_CHAR) {
 303                int n = TABULATE (col_2);
 304                col_2 += n;
 305                a68g_bufcpy (A68 (output_line), "", BUFFER_SIZE);
 306                while (n--) {
 307                  a68g_bufcat (A68 (output_line), " ", BUFFER_SIZE);
 308                }
 309              } else {
 310                a68g_bufcpy (A68 (output_line), " ", BUFFER_SIZE);
 311                col_2++;
 312              }
 313            }
 314            WRITE (f, A68 (output_line));
 315          }
 316        }
 317  // Resume pretty printing of line.
 318        if (!line_ended) {
 319          continuations++;
 320          ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "\n.%1d   ", continuations) >= 0);
 321          WRITE (f, A68 (output_line));
 322          if (continuations >= 9) {
 323            WRITE (f, "...");
 324            line_ended = A68_TRUE;
 325          } else {
 326            c0 = c;
 327            pos = 5;
 328            col = 1;
 329          }
 330        }
 331      }
 332    }
 333  // Print the diagnostics.
 334    if (mask) {
 335      if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) {
 336        DIAGNOSTIC_T *d;
 337        for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) {
 338          if (mask == A68_RUNTIME_ERROR) {
 339            if (IS (d, A68_RUNTIME_ERROR) || IS (d, A68_MATH_ERROR) || (IS (d, A68_MATH_WARNING))) {
 340              WRITE (f, NEWLINE_STRING);
 341              pretty_diag (f, TEXT (d));
 342            }
 343          } else {
 344            WRITE (f, NEWLINE_STRING);
 345            pretty_diag (f, TEXT (d));
 346          }
 347        }
 348      }
 349    }
 350  }
 351  
 352  //! @brief Write diagnostics to STDOUT.
 353  
 354  void diagnostics_to_terminal (LINE_T * p, int sev)
 355  {
 356    for (; p != NO_LINE; FORWARD (p)) {
 357      if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) {
 358        BOOL_T z = A68_FALSE;
 359        for (DIAGNOSTIC_T *d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) {
 360          if (sev == A68_ALL_DIAGNOSTICS) {
 361            z = (BOOL_T) (z | (IS (d, A68_WARNING) || IS (d, A68_ERROR) || IS (d, A68_SYNTAX_ERROR) || IS (d, A68_MATH_ERROR) || IS (d, A68_RUNTIME_ERROR) || IS (d, A68_SCANNER_ERROR)));
 362          } else if (sev == A68_RUNTIME_ERROR) {
 363            z = (BOOL_T) (z | (IS (d, A68_RUNTIME_ERROR) || (IS (d, A68_MATH_ERROR))));
 364          }
 365        }
 366        if (z) {
 367          write_source_line (A68_STDERR, p, NO_NODE, sev);
 368        }
 369      }
 370    }
 371  }
 372  
 373  //! @brief Give an intelligible error and exit.
 374  
 375  void scan_error (LINE_T * u, char *v, char *txt)
 376  {
 377    if (errno != 0) {
 378      diagnostic (A68_SCANNER_ERROR, NO_NODE, txt, u, v, error_specification ());
 379    } else {
 380      diagnostic (A68_SCANNER_ERROR, NO_NODE, txt, u, v, ERROR_UNSPECIFIED);
 381    }
 382    longjmp (RENDEZ_VOUS (&A68_JOB), 1);
 383  }
 384  
 385  void scan_error_info (LINE_T * u, char *v, char *txt, char *info)
 386  {
 387    if (info != NO_TEXT) {
 388      size_t len = strlen (txt) + 3;
 389      char *txti = a68g_alloc(len, __FILE__, __LINE__);
 390      ABEND (txti == NO_TEXT, ERROR_OUT_OF_CORE, __func__);
 391      a68g_bufcpy (txti, txt, len);
 392      a68g_bufcat (txti, " Z", len);
 393      if (errno != 0) {
 394        diagnostic (A68_SCANNER_ERROR, NO_NODE, txti, u, v, info, error_specification ());
 395      } else {
 396        diagnostic (A68_SCANNER_ERROR, NO_NODE, txti, u, v, info, ERROR_UNSPECIFIED);
 397      }
 398      longjmp (RENDEZ_VOUS (&A68_JOB), 1);
 399    } else {
 400      scan_error(u, v, txt);
 401    }
 402  }
 403  
 404  //! @brief Give an intelligible warning.
 405  
 406  void scan_warning (LINE_T * u, char *v, char *txt)
 407  {
 408    if (errno != 0) {
 409      diagnostic (A68_SCANNER_WARNING, NO_NODE, txt, u, v, error_specification ());
 410    } else {
 411      diagnostic (A68_SCANNER_WARNING, NO_NODE, txt, u, v, ERROR_UNSPECIFIED);
 412    }
 413  }
 414  
 415  //! @brief Get severity text.
 416  
 417  char *get_severity (int sev)
 418  {
 419    switch (sev) {
 420    case A68_ERROR: {
 421        return "error";
 422      }
 423    case A68_SYNTAX_ERROR: {
 424        return "syntax error";
 425      }
 426    case A68_RUNTIME_ERROR: {
 427        return "runtime error";
 428      }
 429    case A68_MATH_ERROR: {
 430        return "math error";
 431      }
 432    case A68_MATH_WARNING: {
 433        return "math warning";
 434      }
 435    case A68_WARNING: {
 436        return "warning";
 437      }
 438    case A68_SCANNER_ERROR: {
 439        return "scanner error";
 440      }
 441    case A68_SCANNER_WARNING: {
 442        return "scanner warning";
 443      }
 444    default: {
 445        return NO_TEXT;
 446      }
 447    }
 448  }
 449  
 450  //! @brief Print diagnostic.
 451  
 452  void write_diagnostic (int sev, char *b)
 453  {
 454    char txt[SMALL_BUFFER_SIZE];
 455    char *severity = get_severity (sev);
 456    if (severity == NO_TEXT) {
 457      ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: %s.", A68 (a68g_cmd_name), b) >= 0);
 458    } else {
 459      a68g_bufcpy (txt, get_severity (sev), SMALL_BUFFER_SIZE);
 460      ASSERT (a68g_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: %s: %s.", A68 (a68g_cmd_name), txt, b) >= 0);
 461    }
 462    io_close_tty_line ();
 463    pretty_diag (A68_STDERR, A68 (output_line));
 464  }
 465  
 466  //! @brief Add diagnostic to source line.
 467  
 468  void add_diagnostic (LINE_T * line, char *pos, NODE_T * p, int sev, char *b)
 469  {
 470  // Add diagnostic and choose GNU style or non-GNU style.
 471    DIAGNOSTIC_T *msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) SIZE_ALIGNED (DIAGNOSTIC_T));
 472    DIAGNOSTIC_T **ref_msg;
 473    BUFFER a, nst;
 474    char st[SMALL_BUFFER_SIZE];
 475    char *severity = get_severity (sev);
 476    int k = 1;
 477    if (line == NO_LINE && p == NO_NODE) {
 478      return;
 479    }
 480    if (A68 (in_monitor)) {
 481      monitor_error (b, NO_TEXT);
 482      return;
 483    }
 484    nst[0] = NULL_CHAR;
 485    if (line == NO_LINE && p != NO_NODE) {
 486      line = LINE (INFO (p));
 487    }
 488    while (line != NO_LINE && NUMBER (line) == 0) {
 489      FORWARD (line);
 490    }
 491    if (line == NO_LINE) {
 492      return;
 493    }
 494    ref_msg = &(DIAGNOSTICS (line));
 495    while (*ref_msg != NO_DIAGNOSTIC) {
 496      ref_msg = &(NEXT (*ref_msg));
 497      k++;
 498    }
 499    if (p != NO_NODE) {
 500      NODE_T *n = NEST (p);
 501      if (n != NO_NODE && NSYMBOL (n) != NO_TEXT) {
 502        char *nt = non_terminal_string (A68 (edit_line), ATTRIBUTE (n));
 503        if (nt != NO_TEXT) {
 504          if (LINE_NUMBER (n) == 0) {
 505            ASSERT (a68g_bufprt (nst, SNPRINTF_SIZE, ", in %s", nt) >= 0);
 506          } else {
 507            if (MOID (n) != NO_MOID) {
 508              if (LINE_NUMBER (n) == NUMBER (line)) {
 509                ASSERT (a68g_bufprt (nst, SNPRINTF_SIZE, ", in %s %s starting at \"%.64s\" in this line", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n)) >= 0);
 510              } else {
 511                ASSERT (a68g_bufprt (nst, SNPRINTF_SIZE, ", in %s %s starting at \"%.64s\" in line %d", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0);
 512              }
 513            } else {
 514              if (LINE_NUMBER (n) == NUMBER (line)) {
 515                ASSERT (a68g_bufprt (nst, SNPRINTF_SIZE, ", in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0);
 516              } else {
 517                ASSERT (a68g_bufprt (nst, SNPRINTF_SIZE, ", in %s starting at \"%.64s\" in line %d", nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0);
 518              }
 519            }
 520          }
 521        }
 522      }
 523    }
 524    if (severity == NO_TEXT) {
 525      if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&A68_JOB), FILENAME (line)) == 0) {
 526        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68g_cmd_name), (unt) k, b) >= 0);
 527      } else if (FILENAME (line) != NO_TEXT) {
 528        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68g_cmd_name), FILENAME (line), (unt) k, b) >= 0);
 529      } else {
 530        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68g_cmd_name), (unt) k, b) >= 0);
 531      }
 532    } else {
 533      a68g_bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE);
 534      if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&A68_JOB), FILENAME (line)) == 0) {
 535        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68g_cmd_name), st, (unt) k, b) >= 0);
 536      } else if (FILENAME (line) != NO_TEXT) {
 537        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", A68 (a68g_cmd_name), FILENAME (line), st, (unt) k, b) >= 0);
 538      } else {
 539        ASSERT (a68g_bufprt (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68g_cmd_name), st, (unt) k, b) >= 0);
 540      }
 541    }
 542  // cppcheck might complain here but this memory is not returned, for obvious reasons.
 543    *ref_msg = msg;
 544    ATTRIBUTE (msg) = sev;
 545    if (nst[0] != NULL_CHAR) {
 546      a68g_bufcat (a, nst, BUFFER_SIZE);
 547    }
 548    a68g_bufcat (a, ".", BUFFER_SIZE);
 549    TEXT (msg) = new_string (a, NO_TEXT);
 550    WHERE (msg) = p;
 551    LINE (msg) = line;
 552    SYMBOL (msg) = pos;
 553    NUMBER (msg) = k;
 554    NEXT (msg) = NO_DIAGNOSTIC;
 555  }
 556  
 557  //! @brief Give a diagnostic message.
 558  
 559  void diagnostic (STATUS_MASK_T sev, NODE_T * p, char *loc_str, ...)
 560  {
 561    va_list args;
 562    MOID_T *moid = NO_MOID;
 563    char *t = loc_str, b[BUFFER_SIZE];
 564    BOOL_T force, compose = A68_TRUE, issue = A68_TRUE;
 565    va_start (args, loc_str);
 566    b[0] = NULL_CHAR;
 567    force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0);
 568    sev &= ~A68_FORCE_DIAGNOSTICS;
 569  // Node or line?
 570    LINE_T *line = NO_LINE;
 571    char *pos = NO_TEXT;
 572    if (p == NO_NODE) {
 573      line = va_arg (args, LINE_T *);
 574      pos = va_arg (args, char *);
 575    }
 576  // No warnings?
 577    if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
 578      va_end (args);
 579      return;
 580    }
 581    if (!force && sev == A68_MATH_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
 582      va_end (args);
 583      return;
 584    }
 585    if (sev == A68_WARNING && OPTION_QUIET (&A68_JOB)) {
 586      va_end (args);
 587      return;
 588    }
 589    if (sev == A68_MATH_WARNING && OPTION_QUIET (&A68_JOB)) {
 590      va_end (args);
 591      return;
 592    }
 593  // Suppressed?.
 594    if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) {
 595      if (ERROR_COUNT (&A68_JOB) == MAX_ERRORS) {
 596        a68g_bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
 597        compose = A68_FALSE;
 598        sev = A68_ERROR;
 599      } else if (ERROR_COUNT (&A68_JOB) > MAX_ERRORS) {
 600        ERROR_COUNT (&A68_JOB)++;
 601        compose = issue = A68_FALSE;
 602      }
 603    } else if (sev == A68_WARNING || sev == A68_MATH_WARNING) {
 604      if (WARNING_COUNT (&A68_JOB) == MAX_ERRORS) {
 605        a68g_bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
 606        compose = A68_FALSE;
 607      } else if (WARNING_COUNT (&A68_JOB) > MAX_ERRORS) {
 608        WARNING_COUNT (&A68_JOB)++;
 609        compose = issue = A68_FALSE;
 610      }
 611    }
 612    if (compose) {
 613  // Synthesize diagnostic message.
 614      if ((sev & A68_NO_SYNTHESIS) != NULL_MASK) {
 615        sev &= ~A68_NO_SYNTHESIS;
 616        a68g_bufcat (b, t, BUFFER_SIZE);
 617      } else {
 618  // Legend for special symbols:
 619  // * as first character, copy rest of string literally
 620  // # skip extra syntactical information
 621  // @ non terminal
 622  // A non terminal
 623  // B keyword
 624  // C context
 625  // D argument in decimal
 626  // H char argument
 627  // K 'LONG'
 628  // L line number
 629  // M moid - if error mode return without giving a message
 630  // N mode - M_NIL
 631  // O moid - operand
 632  // S quoted symbol, when possible with typographical display features
 633  // X expected attribute
 634  // Y string literal. 
 635  // Z quoted string literal. 
 636        if (t[0] == '*') {
 637          a68g_bufcat (b, &t[1], BUFFER_SIZE);
 638        } else
 639          while (t[0] != NULL_CHAR) {
 640            if (t[0] == '#') {
 641              ;
 642            } else if (t[0] == '@') {
 643              if (p == NO_NODE) {
 644                a68g_bufcat (b, "construct", BUFFER_SIZE);
 645              } else {
 646                char *nt = non_terminal_string (A68 (edit_line), ATTRIBUTE (p));
 647                if (t != NO_TEXT) {
 648                  a68g_bufcat (b, nt, BUFFER_SIZE);
 649                } else {
 650                  a68g_bufcat (b, "construct", BUFFER_SIZE);
 651                }
 652              }
 653            } else if (t[0] == 'A') {
 654              int att = va_arg (args, int);
 655              char *nt = non_terminal_string (A68 (edit_line), att);
 656              if (nt != NO_TEXT) {
 657                a68g_bufcat (b, nt, BUFFER_SIZE);
 658              } else {
 659                a68g_bufcat (b, "construct", BUFFER_SIZE);
 660              }
 661            } else if (t[0] == 'B') {
 662              int att = va_arg (args, int);
 663              KEYWORD_T *nt = find_keyword_from_attribute (A68 (top_keyword), att);
 664              if (nt != NO_KEYWORD) {
 665                a68g_bufcat (b, "\"", BUFFER_SIZE);
 666                a68g_bufcat (b, TEXT (nt), BUFFER_SIZE);
 667                a68g_bufcat (b, "\"", BUFFER_SIZE);
 668              } else {
 669                a68g_bufcat (b, "keyword", BUFFER_SIZE);
 670              }
 671            } else if (t[0] == 'C') {
 672              int att = va_arg (args, int);
 673              if (att == NO_SORT) {
 674                a68g_bufcat (b, "this", BUFFER_SIZE);
 675              }
 676              if (att == SOFT) {
 677                a68g_bufcat (b, "a soft", BUFFER_SIZE);
 678              } else if (att == WEAK) {
 679                a68g_bufcat (b, "a weak", BUFFER_SIZE);
 680              } else if (att == MEEK) {
 681                a68g_bufcat (b, "a meek", BUFFER_SIZE);
 682              } else if (att == FIRM) {
 683                a68g_bufcat (b, "a firm", BUFFER_SIZE);
 684              } else if (att == STRONG) {
 685                a68g_bufcat (b, "a strong", BUFFER_SIZE);
 686              }
 687            } else if (t[0] == 'D') {
 688              int a = va_arg (args, int);
 689              BUFFER d;
 690              BUFCLR (d);
 691              ASSERT (a68g_bufprt (d, SNPRINTF_SIZE, "%d", a) >= 0);
 692              a68g_bufcat (b, d, BUFFER_SIZE);
 693            } else if (t[0] == 'H') {
 694              char *a = va_arg (args, char *);
 695              char d[SMALL_BUFFER_SIZE];
 696              ASSERT (a68g_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) >= 0);
 697              a68g_bufcat (b, d, BUFFER_SIZE);
 698            } else if (t[0] == 'K') {
 699              a68g_bufcat (b, "LONG", BUFFER_SIZE);
 700            } else if (t[0] == 'L') {
 701              LINE_T *a = va_arg (args, LINE_T *);
 702              char d[SMALL_BUFFER_SIZE];
 703              ABEND (a == NO_LINE, ERROR_INTERNAL_CONSISTENCY, __func__);
 704              if (NUMBER (a) == 0) {
 705                a68g_bufcat (b, "in standard environment", BUFFER_SIZE);
 706              } else {
 707                if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) {
 708                  ASSERT (a68g_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "in this line") >= 0);
 709                } else {
 710                  ASSERT (a68g_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) >= 0);
 711                }
 712                a68g_bufcat (b, d, BUFFER_SIZE);
 713              }
 714            } else if (t[0] == 'M') {
 715              moid = va_arg (args, MOID_T *);
 716              if (moid == NO_MOID || moid == M_ERROR) {
 717                moid = M_UNDEFINED;
 718              }
 719              if (IS (moid, SERIES_MODE)) {
 720                if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
 721                  a68g_bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 722                } else {
 723                  a68g_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 724                }
 725              } else {
 726                a68g_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 727              }
 728            } else if (t[0] == 'N') {
 729              a68g_bufcat (b, "NIL name of mode ", BUFFER_SIZE);
 730              moid = va_arg (args, MOID_T *);
 731              if (moid != NO_MOID) {
 732                a68g_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 733              }
 734            } else if (t[0] == 'O') {
 735              moid = va_arg (args, MOID_T *);
 736              if (moid == NO_MOID || moid == M_ERROR) {
 737                moid = M_UNDEFINED;
 738              }
 739              if (moid == M_VOID) {
 740                a68g_bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);
 741              } else if (IS (moid, SERIES_MODE)) {
 742                if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
 743                  a68g_bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 744                } else {
 745                  a68g_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 746                }
 747              } else {
 748                a68g_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 749              }
 750            } else if (t[0] == 'S') {
 751              if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) {
 752                char *txt = NSYMBOL (p);
 753                char *sym = NCHAR_IN_LINE (p);
 754                int n = 0, size = (int) strlen (txt);
 755                a68g_bufcat (b, "\"", BUFFER_SIZE);
 756                if (txt[0] != sym[0] || (int) strlen (sym) < size) {
 757                  a68g_bufcat (b, txt, BUFFER_SIZE);
 758                } else {
 759                  while (n < size) {
 760                    if (IS_PRINT (sym[0])) {
 761                      char str[2];
 762                      str[0] = sym[0];
 763                      str[1] = NULL_CHAR;
 764                      a68g_bufcat (b, str, BUFFER_SIZE);
 765                    }
 766                    if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) {
 767                      txt++;
 768                      n++;
 769                    }
 770                    sym++;
 771                  }
 772                }
 773                a68g_bufcat (b, "\"", BUFFER_SIZE);
 774              } else {
 775                a68g_bufcat (b, "symbol", BUFFER_SIZE);
 776              }
 777            } else if (t[0] == 'V') {
 778              a68g_bufcat (b, PACKAGE_STRING, BUFFER_SIZE);
 779            } else if (t[0] == 'X') {
 780              int att = va_arg (args, int);
 781              BUFFER z;
 782              (void) non_terminal_string (z, att);
 783              a68g_bufcat (b, new_string (z, NO_TEXT), BUFFER_SIZE);
 784            } else if (t[0] == 'Y') {
 785              char *loc_string = va_arg (args, char *);
 786              if (loc_string != NO_TEXT) {
 787                a68g_bufcat (b, loc_string, BUFFER_SIZE);
 788              }
 789            } else if (t[0] == 'Z') {
 790              char *loc_string = va_arg (args, char *);
 791              a68g_bufcat (b, "\"", BUFFER_SIZE);
 792              if (loc_string != NO_TEXT) {
 793                a68g_bufcat (b, loc_string, BUFFER_SIZE);
 794              }
 795              a68g_bufcat (b, "\"", BUFFER_SIZE);
 796            } else {
 797              char q[2];
 798              q[0] = t[0];
 799              q[1] = NULL_CHAR;
 800              a68g_bufcat (b, q, BUFFER_SIZE);
 801            }
 802            t++;
 803          }
 804  // Add information from errno, if any.
 805        if (errno != 0) {
 806          char *loc_str2 = new_string (error_specification (), NO_TEXT);
 807          if (loc_str2 != NO_TEXT) {
 808            char *stu;
 809            a68g_bufcat (b, ", ", BUFFER_SIZE);
 810            for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) {
 811              stu[0] = (char) TO_LOWER (stu[0]);
 812            }
 813            a68g_bufcat (b, loc_str2, BUFFER_SIZE);
 814          }
 815        }
 816      }
 817    }
 818  // Construct a diagnostic message.
 819    if (issue) {
 820      if (sev == A68_WARNING) {
 821        WARNING_COUNT (&A68_JOB)++;
 822      } else {
 823        ERROR_COUNT (&A68_JOB)++;
 824      }
 825      if (p == NO_NODE) {
 826        if (line == NO_LINE) {
 827          write_diagnostic (sev, b);
 828        } else {
 829          add_diagnostic (line, pos, NO_NODE, sev, b);
 830        }
 831      } else {
 832        add_diagnostic (NO_LINE, NO_TEXT, p, sev, b);
 833        if (sev == A68_MATH_WARNING && p != NO_NODE && LINE (INFO (p)) != NO_LINE) {
 834          write_source_line (A68_STDERR, LINE (INFO (p)), p, A68_TRUE);
 835          WRITE (A68_STDERR, NEWLINE_STRING);
 836        }
 837      }
 838    }
 839    va_end (args);
 840  }
     


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)