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-2023 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 (snprintf (txt, SNPRINTF_SIZE, "no information") >= 0);
  42    } else {
  43      ASSERT (snprintf (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 (snprintf (txt, (size_t) SMALL_BUFFER_SIZE, "\\^%c", ch + 96) >= 0);
  66    } else {
  67      ASSERT (snprintf (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_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 (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", A68 (a68_cmd_name), file, line, reason) >= 0);
 121    if (info != NO_TEXT) {
 122      bufcat (A68 (output_line), ", ", BUFFER_SIZE);
 123      bufcat (A68 (output_line), info, BUFFER_SIZE);
 124    }
 125    if (errno != 0) {
 126      bufcat (A68 (output_line), " (", BUFFER_SIZE);
 127      bufcat (A68 (output_line), error_specification (), BUFFER_SIZE);
 128      bufcat (A68 (output_line), ")", BUFFER_SIZE);
 129    }
 130    bufcat (A68 (output_line), "\n", BUFFER_SIZE);
 131    io_close_tty_line ();
 132    pretty_diag (A68_STDOUT, A68 (output_line));
 133    a68_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_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_STDOUT) {
 194      io_close_tty_line ();
 195    } else {
 196      WRITE (f, NEWLINE_STRING);
 197    }
 198    if (NUMBER (p) == 0) {
 199      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "      ") >= 0);
 200    } else {
 201      ASSERT (snprintf (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        bufcpy (A68 (output_line), "", BUFFER_SIZE);
 215        line_ended = A68_TRUE;
 216      } else {
 217        if (IS_GRAPH (c[0])) {
 218          char *c1;
 219          bufcpy (A68 (output_line), "", BUFFER_SIZE);
 220          for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) {
 221            bufcat (A68 (output_line), char_to_str (c1[0]), BUFFER_SIZE);
 222          }
 223          if (len > line_width - 5) {
 224            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          bufcpy (A68 (output_line), "", BUFFER_SIZE);
 234          while (n--) {
 235            bufcat (A68 (output_line), " ", BUFFER_SIZE);
 236          }
 237          new_pos = &c[1];
 238        } else if (unprintable (c[0])) {
 239          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          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              bufcpy (A68 (output_line), "-", BUFFER_SIZE);
 286            } else if (diags_at_this_pos != 0) {
 287              if (mask == A68_NO_DIAGNOSTICS) {
 288                bufcpy (A68 (output_line), " ", BUFFER_SIZE);
 289              } else if (diags_at_this_pos == 1) {
 290                ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%c", digchar (k)) >= 0);
 291              } else {
 292                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                bufcpy (A68 (output_line), "", BUFFER_SIZE);
 299                while (n--) {
 300                  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                bufcpy (A68 (output_line), "", BUFFER_SIZE);
 306                while (n--) {
 307                  bufcat (A68 (output_line), " ", BUFFER_SIZE);
 308                }
 309              } else {
 310                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 (snprintf (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_SUPPRESS_SEVERITY)));
 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_STDOUT, 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_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, error_specification ());
 379    } else {
 380      diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, ERROR_UNSPECIFIED);
 381    }
 382    longjmp (RENDEZ_VOUS (&A68_JOB), 1);
 383  }
 384  
 385  //! @brief Give an intelligible warning.
 386  
 387  void scan_warning (LINE_T * u, char *v, char *txt)
 388  {
 389    if (errno != 0) {
 390      diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, error_specification ());
 391    } else {
 392      diagnostic (A68_SUPPRESS_SEVERITY, NO_NODE, txt, u, v, ERROR_UNSPECIFIED);
 393    }
 394  }
 395  
 396  //! @brief Get severity text.
 397  
 398  char *get_severity (int sev)
 399  {
 400    switch (sev) {
 401    case A68_ERROR: {
 402        return "error";
 403      }
 404    case A68_SYNTAX_ERROR: {
 405        return "syntax error";
 406      }
 407    case A68_RUNTIME_ERROR: {
 408        return "runtime error";
 409      }
 410    case A68_MATH_ERROR: {
 411        return "math error";
 412      }
 413    case A68_MATH_WARNING: {
 414        return "math warning";
 415      }
 416    case A68_WARNING: {
 417        return "warning";
 418      }
 419    case A68_SUPPRESS_SEVERITY: {
 420        return NO_TEXT;
 421      }
 422    default: {
 423        return NO_TEXT;
 424      }
 425    }
 426  }
 427  
 428  //! @brief Print diagnostic.
 429  
 430  void write_diagnostic (int sev, char *b)
 431  {
 432    char txt[SMALL_BUFFER_SIZE];
 433    char *severity = get_severity (sev);
 434    if (severity == NO_TEXT) {
 435      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s.", A68 (a68_cmd_name), b) >= 0);
 436    } else {
 437      bufcpy (txt, get_severity (sev), SMALL_BUFFER_SIZE);
 438      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s: %s.", A68 (a68_cmd_name), txt, b) >= 0);
 439    }
 440    io_close_tty_line ();
 441    pretty_diag (A68_STDOUT, A68 (output_line));
 442  }
 443  
 444  //! @brief Add diagnostic to source line.
 445  
 446  void add_diagnostic (LINE_T * line, char *pos, NODE_T * p, int sev, char *b)
 447  {
 448  // Add diagnostic and choose GNU style or non-GNU style.
 449    DIAGNOSTIC_T *msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) SIZE_ALIGNED (DIAGNOSTIC_T));
 450    DIAGNOSTIC_T **ref_msg;
 451    BUFFER a, nst;
 452    char st[SMALL_BUFFER_SIZE];
 453    char *severity = get_severity (sev);
 454    int k = 1;
 455    if (line == NO_LINE && p == NO_NODE) {
 456      return;
 457    }
 458    if (A68 (in_monitor)) {
 459      monitor_error (b, NO_TEXT);
 460      return;
 461    }
 462    nst[0] = NULL_CHAR;
 463    if (line == NO_LINE && p != NO_NODE) {
 464      line = LINE (INFO (p));
 465    }
 466    while (line != NO_LINE && NUMBER (line) == 0) {
 467      FORWARD (line);
 468    }
 469    if (line == NO_LINE) {
 470      return;
 471    }
 472    ref_msg = &(DIAGNOSTICS (line));
 473    while (*ref_msg != NO_DIAGNOSTIC) {
 474      ref_msg = &(NEXT (*ref_msg));
 475      k++;
 476    }
 477    if (p != NO_NODE) {
 478      NODE_T *n = NEST (p);
 479      if (n != NO_NODE && NSYMBOL (n) != NO_TEXT) {
 480        char *nt = non_terminal_string (A68 (edit_line), ATTRIBUTE (n));
 481        if (nt != NO_TEXT) {
 482          if (LINE_NUMBER (n) == 0) {
 483            ASSERT (snprintf (nst, SNPRINTF_SIZE, ", in %s", nt) >= 0);
 484          } else {
 485            if (MOID (n) != NO_MOID) {
 486              if (LINE_NUMBER (n) == NUMBER (line)) {
 487                ASSERT (snprintf (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);
 488              } else {
 489                ASSERT (snprintf (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);
 490              }
 491            } else {
 492              if (LINE_NUMBER (n) == NUMBER (line)) {
 493                ASSERT (snprintf (nst, SNPRINTF_SIZE, ", in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0);
 494              } else {
 495                ASSERT (snprintf (nst, SNPRINTF_SIZE, ", in %s starting at \"%.64s\" in line %d", nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0);
 496              }
 497            }
 498          }
 499        }
 500      }
 501    }
 502    if (severity == NO_TEXT) {
 503      if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&A68_JOB), FILENAME (line)) == 0) {
 504        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0);
 505      } else if (FILENAME (line) != NO_TEXT) {
 506        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), (unt) k, b) >= 0);
 507      } else {
 508        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0);
 509      }
 510    } else {
 511      bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE);
 512      if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&A68_JOB), FILENAME (line)) == 0) {
 513        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), st, (unt) k, b) >= 0);
 514      } else if (FILENAME (line) != NO_TEXT) {
 515        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), st, (unt) k, b) >= 0);
 516      } else {
 517        ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), st, (unt) k, b) >= 0);
 518      }
 519    }
 520  // cppcheck might complain here but this memory is not returned, for obvious reasons.
 521    *ref_msg = msg;
 522    ATTRIBUTE (msg) = sev;
 523    if (nst[0] != NULL_CHAR) {
 524      bufcat (a, nst, BUFFER_SIZE);
 525    }
 526    bufcat (a, ".", BUFFER_SIZE);
 527    TEXT (msg) = new_string (a, NO_TEXT);
 528    WHERE (msg) = p;
 529    LINE (msg) = line;
 530    SYMBOL (msg) = pos;
 531    NUMBER (msg) = k;
 532    NEXT (msg) = NO_DIAGNOSTIC;
 533  }
 534  
 535  //! @brief Give a diagnostic message.
 536  
 537  void diagnostic (STATUS_MASK_T sev, NODE_T * p, char *loc_str, ...)
 538  {
 539    va_list args;
 540    MOID_T *moid = NO_MOID;
 541    char *t = loc_str, b[BUFFER_SIZE];
 542    BOOL_T force, extra_syntax = A68_TRUE, compose = A68_TRUE, issue = A68_TRUE;
 543    va_start (args, loc_str);
 544    (void) extra_syntax;
 545    b[0] = NULL_CHAR;
 546    force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0);
 547    sev &= ~A68_FORCE_DIAGNOSTICS;
 548  // Node or line?
 549    LINE_T *line = NO_LINE;
 550    char *pos = NO_TEXT;
 551    if (p == NO_NODE) {
 552      line = va_arg (args, LINE_T *);
 553      pos = va_arg (args, char *);
 554    }
 555  // No warnings?
 556    if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
 557      va_end (args);
 558      return;
 559    }
 560    if (!force && sev == A68_MATH_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
 561      va_end (args);
 562      return;
 563    }
 564    if (sev == A68_WARNING && OPTION_QUIET (&A68_JOB)) {
 565      va_end (args);
 566      return;
 567    }
 568    if (sev == A68_MATH_WARNING && OPTION_QUIET (&A68_JOB)) {
 569      va_end (args);
 570      return;
 571    }
 572  // Suppressed?.
 573    if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) {
 574      if (ERROR_COUNT (&A68_JOB) == MAX_ERRORS) {
 575        bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
 576        compose = A68_FALSE;
 577        sev = A68_ERROR;
 578      } else if (ERROR_COUNT (&A68_JOB) > MAX_ERRORS) {
 579        ERROR_COUNT (&A68_JOB)++;
 580        compose = issue = A68_FALSE;
 581      }
 582    } else if (sev == A68_WARNING || sev == A68_MATH_WARNING) {
 583      if (WARNING_COUNT (&A68_JOB) == MAX_ERRORS) {
 584        bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
 585        compose = A68_FALSE;
 586      } else if (WARNING_COUNT (&A68_JOB) > MAX_ERRORS) {
 587        WARNING_COUNT (&A68_JOB)++;
 588        compose = issue = A68_FALSE;
 589      }
 590    }
 591    if (compose) {
 592  // Synthesize diagnostic message.
 593      if ((sev & A68_NO_SYNTHESIS) != NULL_MASK) {
 594        sev &= ~A68_NO_SYNTHESIS;
 595        bufcat (b, t, BUFFER_SIZE);
 596      } else {
 597  // Legend for special symbols:
 598  // * as first character, copy rest of string literally
 599  // # skip extra syntactical information
 600  // @ non terminal
 601  // A non terminal
 602  // B keyword
 603  // C context
 604  // D argument in decimal
 605  // H char argument
 606  // K 'LONG'
 607  // L line number
 608  // M moid - if error mode return without giving a message
 609  // N mode - M_NIL
 610  // O moid - operand
 611  // S quoted symbol, when possible with typographical display features
 612  // X expected attribute
 613  // Y string literal. 
 614  // Z quoted string literal. 
 615        if (t[0] == '*') {
 616          bufcat (b, &t[1], BUFFER_SIZE);
 617        } else
 618          while (t[0] != NULL_CHAR) {
 619            if (t[0] == '#') {
 620              extra_syntax = A68_FALSE;
 621            } else if (t[0] == '@') {
 622              char *nt = non_terminal_string (A68 (edit_line), ATTRIBUTE (p));
 623              if (t != NO_TEXT) {
 624                bufcat (b, nt, BUFFER_SIZE);
 625              } else {
 626                bufcat (b, "construct", BUFFER_SIZE);
 627              }
 628            } else if (t[0] == 'A') {
 629              int att = va_arg (args, int);
 630              char *nt = non_terminal_string (A68 (edit_line), att);
 631              if (nt != NO_TEXT) {
 632                bufcat (b, nt, BUFFER_SIZE);
 633              } else {
 634                bufcat (b, "construct", BUFFER_SIZE);
 635              }
 636            } else if (t[0] == 'B') {
 637              int att = va_arg (args, int);
 638              KEYWORD_T *nt = find_keyword_from_attribute (A68 (top_keyword), att);
 639              if (nt != NO_KEYWORD) {
 640                bufcat (b, "\"", BUFFER_SIZE);
 641                bufcat (b, TEXT (nt), BUFFER_SIZE);
 642                bufcat (b, "\"", BUFFER_SIZE);
 643              } else {
 644                bufcat (b, "keyword", BUFFER_SIZE);
 645              }
 646            } else if (t[0] == 'C') {
 647              int att = va_arg (args, int);
 648              if (att == NO_SORT) {
 649                bufcat (b, "this", BUFFER_SIZE);
 650              }
 651              if (att == SOFT) {
 652                bufcat (b, "a soft", BUFFER_SIZE);
 653              } else if (att == WEAK) {
 654                bufcat (b, "a weak", BUFFER_SIZE);
 655              } else if (att == MEEK) {
 656                bufcat (b, "a meek", BUFFER_SIZE);
 657              } else if (att == FIRM) {
 658                bufcat (b, "a firm", BUFFER_SIZE);
 659              } else if (att == STRONG) {
 660                bufcat (b, "a strong", BUFFER_SIZE);
 661              }
 662            } else if (t[0] == 'D') {
 663              int a = va_arg (args, int);
 664              BUFFER d;
 665              BUFCLR (d);
 666              ASSERT (snprintf (d, SNPRINTF_SIZE, "%d", a) >= 0);
 667              bufcat (b, d, BUFFER_SIZE);
 668            } else if (t[0] == 'H') {
 669              char *a = va_arg (args, char *);
 670              char d[SMALL_BUFFER_SIZE];
 671              ASSERT (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) >= 0);
 672              bufcat (b, d, BUFFER_SIZE);
 673            } else if (t[0] == 'K') {
 674              bufcat (b, "LONG", BUFFER_SIZE);
 675            } else if (t[0] == 'L') {
 676              LINE_T *a = va_arg (args, LINE_T *);
 677              char d[SMALL_BUFFER_SIZE];
 678              ABEND (a == NO_LINE, ERROR_INTERNAL_CONSISTENCY, __func__);
 679              if (NUMBER (a) == 0) {
 680                bufcat (b, "in standard environment", BUFFER_SIZE);
 681              } else {
 682                if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) {
 683                  ASSERT (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "in this line") >= 0);
 684                } else {
 685                  ASSERT (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) >= 0);
 686                }
 687                bufcat (b, d, BUFFER_SIZE);
 688              }
 689            } else if (t[0] == 'M') {
 690              moid = va_arg (args, MOID_T *);
 691              if (moid == NO_MOID || moid == M_ERROR) {
 692                moid = M_UNDEFINED;
 693              }
 694              if (IS (moid, SERIES_MODE)) {
 695                if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
 696                  bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 697                } else {
 698                  bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 699                }
 700              } else {
 701                bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 702              }
 703            } else if (t[0] == 'N') {
 704              bufcat (b, "NIL name of mode ", BUFFER_SIZE);
 705              moid = va_arg (args, MOID_T *);
 706              if (moid != NO_MOID) {
 707                bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 708              }
 709            } else if (t[0] == 'O') {
 710              moid = va_arg (args, MOID_T *);
 711              if (moid == NO_MOID || moid == M_ERROR) {
 712                moid = M_UNDEFINED;
 713              }
 714              if (moid == M_VOID) {
 715                bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);
 716              } else if (IS (moid, SERIES_MODE)) {
 717                if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
 718                  bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 719                } else {
 720                  bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 721                }
 722              } else {
 723                bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
 724              }
 725            } else if (t[0] == 'S') {
 726              if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) {
 727                char *txt = NSYMBOL (p);
 728                char *sym = NCHAR_IN_LINE (p);
 729                int n = 0, size = (int) strlen (txt);
 730                bufcat (b, "\"", BUFFER_SIZE);
 731                if (txt[0] != sym[0] || (int) strlen (sym) < size) {
 732                  bufcat (b, txt, BUFFER_SIZE);
 733                } else {
 734                  while (n < size) {
 735                    if (IS_PRINT (sym[0])) {
 736                      char str[2];
 737                      str[0] = sym[0];
 738                      str[1] = NULL_CHAR;
 739                      bufcat (b, str, BUFFER_SIZE);
 740                    }
 741                    if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) {
 742                      txt++;
 743                      n++;
 744                    }
 745                    sym++;
 746                  }
 747                }
 748                bufcat (b, "\"", BUFFER_SIZE);
 749              } else {
 750                bufcat (b, "symbol", BUFFER_SIZE);
 751              }
 752            } else if (t[0] == 'V') {
 753              bufcat (b, PACKAGE_STRING, BUFFER_SIZE);
 754            } else if (t[0] == 'X') {
 755              int att = va_arg (args, int);
 756              BUFFER z;
 757              (void) non_terminal_string (z, att);
 758              bufcat (b, new_string (z, NO_TEXT), BUFFER_SIZE);
 759            } else if (t[0] == 'Y') {
 760              char *loc_string = va_arg (args, char *);
 761              bufcat (b, loc_string, BUFFER_SIZE);
 762            } else if (t[0] == 'Z') {
 763              char *loc_string = va_arg (args, char *);
 764              bufcat (b, "\"", BUFFER_SIZE);
 765              bufcat (b, loc_string, BUFFER_SIZE);
 766              bufcat (b, "\"", BUFFER_SIZE);
 767            } else {
 768              char q[2];
 769              q[0] = t[0];
 770              q[1] = NULL_CHAR;
 771              bufcat (b, q, BUFFER_SIZE);
 772            }
 773            t++;
 774          }
 775  // Add information from errno, if any.
 776        if (errno != 0) {
 777          char *loc_str2 = new_string (error_specification (), NO_TEXT);
 778          if (loc_str2 != NO_TEXT) {
 779            char *stu;
 780            bufcat (b, ", ", BUFFER_SIZE);
 781            for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) {
 782              stu[0] = (char) TO_LOWER (stu[0]);
 783            }
 784            bufcat (b, loc_str2, BUFFER_SIZE);
 785          }
 786        }
 787      }
 788    }
 789  // Construct a diagnostic message.
 790    if (issue) {
 791      if (sev == A68_WARNING) {
 792        WARNING_COUNT (&A68_JOB)++;
 793      } else {
 794        ERROR_COUNT (&A68_JOB)++;
 795      }
 796      if (p == NO_NODE) {
 797        if (line == NO_LINE) {
 798          write_diagnostic (sev, b);
 799        } else {
 800          add_diagnostic (line, pos, NO_NODE, sev, b);
 801        }
 802      } else {
 803        add_diagnostic (NO_LINE, NO_TEXT, p, sev, b);
 804        if (sev == A68_MATH_WARNING && p != NO_NODE && LINE (INFO (p)) != NO_LINE) {
 805          write_source_line (A68_STDOUT, LINE (INFO (p)), p, A68_TRUE);
 806          WRITE (A68_STDOUT, NEWLINE_STRING);
 807        }
 808      }
 809    }
 810    va_end (args);
 811  }