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-2024 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 (a68_bufprt (txt, SNPRINTF_SIZE, "no information") >= 0);
42 } else {
43 ASSERT (a68_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 (a68_bufprt (txt, (size_t) SMALL_BUFFER_SIZE, "\\^%c", ch + 96) >= 0);
66 } else {
67 ASSERT (a68_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 (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", A68 (a68_cmd_name), file, line, reason) >= 0);
121 if (info != NO_TEXT) {
122 a68_bufcat (A68 (output_line), ", ", BUFFER_SIZE);
123 a68_bufcat (A68 (output_line), info, BUFFER_SIZE);
124 }
125 if (errno != 0) {
126 a68_bufcat (A68 (output_line), " (", BUFFER_SIZE);
127 a68_bufcat (A68 (output_line), error_specification (), BUFFER_SIZE);
128 a68_bufcat (A68 (output_line), ")", BUFFER_SIZE);
129 }
130 a68_bufcat (A68 (output_line), "\n", BUFFER_SIZE);
131 io_close_tty_line ();
132 pretty_diag (A68_STDERR, 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_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 (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, " ") >= 0);
200 } else {
201 ASSERT (a68_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 a68_bufcpy (A68 (output_line), "", BUFFER_SIZE);
215 line_ended = A68_TRUE;
216 } else {
217 if (IS_GRAPH (c[0])) {
218 char *c1;
219 a68_bufcpy (A68 (output_line), "", BUFFER_SIZE);
220 for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) {
221 a68_bufcat (A68 (output_line), char_to_str (c1[0]), BUFFER_SIZE);
222 }
223 if (len > line_width - 5) {
224 a68_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 a68_bufcpy (A68 (output_line), "", BUFFER_SIZE);
234 while (n--) {
235 a68_bufcat (A68 (output_line), " ", BUFFER_SIZE);
236 }
237 new_pos = &c[1];
238 } else if (unprintable (c[0])) {
239 a68_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 a68_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 a68_bufcpy (A68 (output_line), "-", BUFFER_SIZE);
286 } else if (diags_at_this_pos != 0) {
287 if (mask == A68_NO_DIAGNOSTICS) {
288 a68_bufcpy (A68 (output_line), " ", BUFFER_SIZE);
289 } else if (diags_at_this_pos == 1) {
290 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%c", digchar (k)) >= 0);
291 } else {
292 a68_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 a68_bufcpy (A68 (output_line), "", BUFFER_SIZE);
299 while (n--) {
300 a68_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 a68_bufcpy (A68 (output_line), "", BUFFER_SIZE);
306 while (n--) {
307 a68_bufcat (A68 (output_line), " ", BUFFER_SIZE);
308 }
309 } else {
310 a68_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 (a68_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_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_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_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 (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: %s.", A68 (a68_cmd_name), b) >= 0);
436 } else {
437 a68_bufcpy (txt, get_severity (sev), SMALL_BUFFER_SIZE);
438 ASSERT (a68_bufprt (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_STDERR, 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 (a68_bufprt (nst, SNPRINTF_SIZE, ", in %s", nt) >= 0);
484 } else {
485 if (MOID (n) != NO_MOID) {
486 if (LINE_NUMBER (n) == NUMBER (line)) {
487 ASSERT (a68_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);
488 } else {
489 ASSERT (a68_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);
490 }
491 } else {
492 if (LINE_NUMBER (n) == NUMBER (line)) {
493 ASSERT (a68_bufprt (nst, SNPRINTF_SIZE, ", in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0);
494 } else {
495 ASSERT (a68_bufprt (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 (a68_bufprt (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0);
505 } else if (FILENAME (line) != NO_TEXT) {
506 ASSERT (a68_bufprt (a, SNPRINTF_SIZE, "%s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), (unt) k, b) >= 0);
507 } else {
508 ASSERT (a68_bufprt (a, SNPRINTF_SIZE, "%s: %x: %s", A68 (a68_cmd_name), (unt) k, b) >= 0);
509 }
510 } else {
511 a68_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 (a68_bufprt (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 (a68_bufprt (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", A68 (a68_cmd_name), FILENAME (line), st, (unt) k, b) >= 0);
516 } else {
517 ASSERT (a68_bufprt (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 a68_bufcat (a, nst, BUFFER_SIZE);
525 }
526 a68_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, compose = A68_TRUE, issue = A68_TRUE;
543 va_start (args, loc_str);
544 b[0] = NULL_CHAR;
545 force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0);
546 sev &= ~A68_FORCE_DIAGNOSTICS;
547 // Node or line?
548 LINE_T *line = NO_LINE;
549 char *pos = NO_TEXT;
550 if (p == NO_NODE) {
551 line = va_arg (args, LINE_T *);
552 pos = va_arg (args, char *);
553 }
554 // No warnings?
555 if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
556 va_end (args);
557 return;
558 }
559 if (!force && sev == A68_MATH_WARNING && OPTION_NO_WARNINGS (&A68_JOB)) {
560 va_end (args);
561 return;
562 }
563 if (sev == A68_WARNING && OPTION_QUIET (&A68_JOB)) {
564 va_end (args);
565 return;
566 }
567 if (sev == A68_MATH_WARNING && OPTION_QUIET (&A68_JOB)) {
568 va_end (args);
569 return;
570 }
571 // Suppressed?.
572 if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) {
573 if (ERROR_COUNT (&A68_JOB) == MAX_ERRORS) {
574 a68_bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
575 compose = A68_FALSE;
576 sev = A68_ERROR;
577 } else if (ERROR_COUNT (&A68_JOB) > MAX_ERRORS) {
578 ERROR_COUNT (&A68_JOB)++;
579 compose = issue = A68_FALSE;
580 }
581 } else if (sev == A68_WARNING || sev == A68_MATH_WARNING) {
582 if (WARNING_COUNT (&A68_JOB) == MAX_ERRORS) {
583 a68_bufcpy (b, "further diagnostics suppressed", BUFFER_SIZE);
584 compose = A68_FALSE;
585 } else if (WARNING_COUNT (&A68_JOB) > MAX_ERRORS) {
586 WARNING_COUNT (&A68_JOB)++;
587 compose = issue = A68_FALSE;
588 }
589 }
590 if (compose) {
591 // Synthesize diagnostic message.
592 if ((sev & A68_NO_SYNTHESIS) != NULL_MASK) {
593 sev &= ~A68_NO_SYNTHESIS;
594 a68_bufcat (b, t, BUFFER_SIZE);
595 } else {
596 // Legend for special symbols:
597 // * as first character, copy rest of string literally
598 // # skip extra syntactical information
599 // @ non terminal
600 // A non terminal
601 // B keyword
602 // C context
603 // D argument in decimal
604 // H char argument
605 // K 'LONG'
606 // L line number
607 // M moid - if error mode return without giving a message
608 // N mode - M_NIL
609 // O moid - operand
610 // S quoted symbol, when possible with typographical display features
611 // X expected attribute
612 // Y string literal.
613 // Z quoted string literal.
614 if (t[0] == '*') {
615 a68_bufcat (b, &t[1], BUFFER_SIZE);
616 } else
617 while (t[0] != NULL_CHAR) {
618 if (t[0] == '#') {
619 ;
620 } else if (t[0] == '@') {
621 if (p == NO_NODE) {
622 a68_bufcat (b, "construct", BUFFER_SIZE);
623 } else {
624 char *nt = non_terminal_string (A68 (edit_line), ATTRIBUTE (p));
625 if (t != NO_TEXT) {
626 a68_bufcat (b, nt, BUFFER_SIZE);
627 } else {
628 a68_bufcat (b, "construct", BUFFER_SIZE);
629 }
630 }
631 } else if (t[0] == 'A') {
632 int att = va_arg (args, int);
633 char *nt = non_terminal_string (A68 (edit_line), att);
634 if (nt != NO_TEXT) {
635 a68_bufcat (b, nt, BUFFER_SIZE);
636 } else {
637 a68_bufcat (b, "construct", BUFFER_SIZE);
638 }
639 } else if (t[0] == 'B') {
640 int att = va_arg (args, int);
641 KEYWORD_T *nt = find_keyword_from_attribute (A68 (top_keyword), att);
642 if (nt != NO_KEYWORD) {
643 a68_bufcat (b, "\"", BUFFER_SIZE);
644 a68_bufcat (b, TEXT (nt), BUFFER_SIZE);
645 a68_bufcat (b, "\"", BUFFER_SIZE);
646 } else {
647 a68_bufcat (b, "keyword", BUFFER_SIZE);
648 }
649 } else if (t[0] == 'C') {
650 int att = va_arg (args, int);
651 if (att == NO_SORT) {
652 a68_bufcat (b, "this", BUFFER_SIZE);
653 }
654 if (att == SOFT) {
655 a68_bufcat (b, "a soft", BUFFER_SIZE);
656 } else if (att == WEAK) {
657 a68_bufcat (b, "a weak", BUFFER_SIZE);
658 } else if (att == MEEK) {
659 a68_bufcat (b, "a meek", BUFFER_SIZE);
660 } else if (att == FIRM) {
661 a68_bufcat (b, "a firm", BUFFER_SIZE);
662 } else if (att == STRONG) {
663 a68_bufcat (b, "a strong", BUFFER_SIZE);
664 }
665 } else if (t[0] == 'D') {
666 int a = va_arg (args, int);
667 BUFFER d;
668 BUFCLR (d);
669 ASSERT (a68_bufprt (d, SNPRINTF_SIZE, "%d", a) >= 0);
670 a68_bufcat (b, d, BUFFER_SIZE);
671 } else if (t[0] == 'H') {
672 char *a = va_arg (args, char *);
673 char d[SMALL_BUFFER_SIZE];
674 ASSERT (a68_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) >= 0);
675 a68_bufcat (b, d, BUFFER_SIZE);
676 } else if (t[0] == 'K') {
677 a68_bufcat (b, "LONG", BUFFER_SIZE);
678 } else if (t[0] == 'L') {
679 LINE_T *a = va_arg (args, LINE_T *);
680 char d[SMALL_BUFFER_SIZE];
681 ABEND (a == NO_LINE, ERROR_INTERNAL_CONSISTENCY, __func__);
682 if (NUMBER (a) == 0) {
683 a68_bufcat (b, "in standard environment", BUFFER_SIZE);
684 } else {
685 if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) {
686 ASSERT (a68_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "in this line") >= 0);
687 } else {
688 ASSERT (a68_bufprt (d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) >= 0);
689 }
690 a68_bufcat (b, d, BUFFER_SIZE);
691 }
692 } else if (t[0] == 'M') {
693 moid = va_arg (args, MOID_T *);
694 if (moid == NO_MOID || moid == M_ERROR) {
695 moid = M_UNDEFINED;
696 }
697 if (IS (moid, SERIES_MODE)) {
698 if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
699 a68_bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
700 } else {
701 a68_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
702 }
703 } else {
704 a68_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
705 }
706 } else if (t[0] == 'N') {
707 a68_bufcat (b, "NIL name of mode ", BUFFER_SIZE);
708 moid = va_arg (args, MOID_T *);
709 if (moid != NO_MOID) {
710 a68_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
711 }
712 } else if (t[0] == 'O') {
713 moid = va_arg (args, MOID_T *);
714 if (moid == NO_MOID || moid == M_ERROR) {
715 moid = M_UNDEFINED;
716 }
717 if (moid == M_VOID) {
718 a68_bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);
719 } else if (IS (moid, SERIES_MODE)) {
720 if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {
721 a68_bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
722 } else {
723 a68_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
724 }
725 } else {
726 a68_bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
727 }
728 } else if (t[0] == 'S') {
729 if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) {
730 char *txt = NSYMBOL (p);
731 char *sym = NCHAR_IN_LINE (p);
732 int n = 0, size = (int) strlen (txt);
733 a68_bufcat (b, "\"", BUFFER_SIZE);
734 if (txt[0] != sym[0] || (int) strlen (sym) < size) {
735 a68_bufcat (b, txt, BUFFER_SIZE);
736 } else {
737 while (n < size) {
738 if (IS_PRINT (sym[0])) {
739 char str[2];
740 str[0] = sym[0];
741 str[1] = NULL_CHAR;
742 a68_bufcat (b, str, BUFFER_SIZE);
743 }
744 if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) {
745 txt++;
746 n++;
747 }
748 sym++;
749 }
750 }
751 a68_bufcat (b, "\"", BUFFER_SIZE);
752 } else {
753 a68_bufcat (b, "symbol", BUFFER_SIZE);
754 }
755 } else if (t[0] == 'V') {
756 a68_bufcat (b, PACKAGE_STRING, BUFFER_SIZE);
757 } else if (t[0] == 'X') {
758 int att = va_arg (args, int);
759 BUFFER z;
760 (void) non_terminal_string (z, att);
761 a68_bufcat (b, new_string (z, NO_TEXT), BUFFER_SIZE);
762 } else if (t[0] == 'Y') {
763 char *loc_string = va_arg (args, char *);
764 a68_bufcat (b, loc_string, BUFFER_SIZE);
765 } else if (t[0] == 'Z') {
766 char *loc_string = va_arg (args, char *);
767 a68_bufcat (b, "\"", BUFFER_SIZE);
768 a68_bufcat (b, loc_string, BUFFER_SIZE);
769 a68_bufcat (b, "\"", BUFFER_SIZE);
770 } else {
771 char q[2];
772 q[0] = t[0];
773 q[1] = NULL_CHAR;
774 a68_bufcat (b, q, BUFFER_SIZE);
775 }
776 t++;
777 }
778 // Add information from errno, if any.
779 if (errno != 0) {
780 char *loc_str2 = new_string (error_specification (), NO_TEXT);
781 if (loc_str2 != NO_TEXT) {
782 char *stu;
783 a68_bufcat (b, ", ", BUFFER_SIZE);
784 for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) {
785 stu[0] = (char) TO_LOWER (stu[0]);
786 }
787 a68_bufcat (b, loc_str2, BUFFER_SIZE);
788 }
789 }
790 }
791 }
792 // Construct a diagnostic message.
793 if (issue) {
794 if (sev == A68_WARNING) {
795 WARNING_COUNT (&A68_JOB)++;
796 } else {
797 ERROR_COUNT (&A68_JOB)++;
798 }
799 if (p == NO_NODE) {
800 if (line == NO_LINE) {
801 write_diagnostic (sev, b);
802 } else {
803 add_diagnostic (line, pos, NO_NODE, sev, b);
804 }
805 } else {
806 add_diagnostic (NO_LINE, NO_TEXT, p, sev, b);
807 if (sev == A68_MATH_WARNING && p != NO_NODE && LINE (INFO (p)) != NO_LINE) {
808 write_source_line (A68_STDERR, LINE (INFO (p)), p, A68_TRUE);
809 WRITE (A68_STDERR, NEWLINE_STRING);
810 }
811 }
812 }
813 va_end (args);
814 }
