a68g-listing.c
1 //! @file a68g-listing.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 //! Old-school listing file.
25
26 #include "a68g.h"
27 #include "a68g-prelude.h"
28 #include "a68g-mp.h"
29 #include "a68g-genie.h"
30 #include "a68g-listing.h"
31 #include "a68g-parser.h"
32 #include "a68g-optimiser.h"
33
34 // Routines for making a "fat" listing file.
35
36 #define SHOW_EQ A68_FALSE
37
38 //! @brief a68_print_short_mode.
39
40 void a68_print_short_mode (FILE_T f, MOID_T * z)
41 {
42 if (IS (z, STANDARD)) {
43 int i = DIM (z);
44 if (i > 0) {
45 while (i--) {
46 WRITE (f, "LONG ");
47 }
48 } else if (i < 0) {
49 while (i++) {
50 WRITE (f, "SHORT ");
51 }
52 }
53 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0);
54 WRITE (f, A68 (output_line));
55 } else if (IS_REF (z) && IS (SUB (z), STANDARD)) {
56 WRITE (f, "REF ");
57 a68_print_short_mode (f, SUB (z));
58 } else if (IS (z, PROC_SYMBOL) && PACK (z) == NO_PACK && IS (SUB (z), STANDARD)) {
59 WRITE (f, "PROC ");
60 a68_print_short_mode (f, SUB (z));
61 } else {
62 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "#%d", NUMBER (z)) >= 0);
63 WRITE (f, A68 (output_line));
64 }
65 }
66
67 //! @brief A68g_print_flat_mode.
68
69 void a68_print_flat_mode (FILE_T f, MOID_T * z)
70 {
71 if (IS (z, STANDARD)) {
72 int i = DIM (z);
73 if (i > 0) {
74 while (i--) {
75 WRITE (f, "LONG ");
76 }
77 } else if (i < 0) {
78 while (i++) {
79 WRITE (f, "SHORT ");
80 }
81 }
82 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0);
83 WRITE (f, A68 (output_line));
84 } else if (IS_REF (z)) {
85 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "REF ") >= 0);
86 WRITE (f, A68 (output_line));
87 a68_print_short_mode (f, SUB (z));
88 } else if (IS (z, PROC_SYMBOL) && DIM (z) == 0) {
89 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "PROC ") >= 0);
90 WRITE (f, A68 (output_line));
91 a68_print_short_mode (f, SUB (z));
92 } else if (IS_ROW (z)) {
93 int i = DIM (z);
94 WRITE (f, "[");
95 while (--i) {
96 WRITE (f, ", ");
97 }
98 WRITE (f, "] ");
99 a68_print_short_mode (f, SUB (z));
100 } else {
101 a68_print_short_mode (f, z);
102 }
103 }
104
105 //! @brief Brief_fields_flat.
106
107 void a68_print_short_pack (FILE_T f, PACK_T * pack)
108 {
109 if (pack != NO_PACK) {
110 a68_print_short_mode (f, MOID (pack));
111 if (NEXT (pack) != NO_PACK) {
112 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", ") >= 0);
113 WRITE (f, A68 (output_line));
114 a68_print_short_pack (f, NEXT (pack));
115 }
116 }
117 }
118
119 //! @brief A68g_print_mode.
120
121 void a68_print_mode (FILE_T f, MOID_T * z)
122 {
123 if (z != NO_MOID) {
124 if (IS (z, STANDARD)) {
125 a68_print_flat_mode (f, z);
126 } else if (IS (z, INDICANT)) {
127 WRITE (f, NSYMBOL (NODE (z)));
128 } else if (z == M_COLLITEM) {
129 WRITE (f, "\"COLLITEM\"");
130 } else if (IS_REF (z)) {
131 WRITE (f, "REF ");
132 a68_print_flat_mode (f, SUB (z));
133 } else if (IS_FLEX (z)) {
134 WRITE (f, "FLEX ");
135 a68_print_flat_mode (f, SUB (z));
136 } else if (IS_ROW (z)) {
137 int i = DIM (z);
138 WRITE (f, "[");
139 while (--i) {
140 WRITE (f, ", ");
141 }
142 WRITE (f, "] ");
143 a68_print_flat_mode (f, SUB (z));
144 } else if (IS_STRUCT (z)) {
145 WRITE (f, "STRUCT (");
146 a68_print_short_pack (f, PACK (z));
147 WRITE (f, ")");
148 } else if (IS_UNION (z)) {
149 WRITE (f, "UNION (");
150 a68_print_short_pack (f, PACK (z));
151 WRITE (f, ")");
152 } else if (IS (z, PROC_SYMBOL)) {
153 WRITE (f, "PROC ");
154 if (PACK (z) != NO_PACK) {
155 WRITE (f, "(");
156 a68_print_short_pack (f, PACK (z));
157 WRITE (f, ") ");
158 }
159 a68_print_flat_mode (f, SUB (z));
160 } else if (IS (z, IN_TYPE_MODE)) {
161 WRITE (f, "\"SIMPLIN\"");
162 } else if (IS (z, OUT_TYPE_MODE)) {
163 WRITE (f, "\"SIMPLOUT\"");
164 } else if (IS (z, ROWS_SYMBOL)) {
165 WRITE (f, "\"ROWS\"");
166 } else if (IS (z, SERIES_MODE)) {
167 WRITE (f, "\"SERIES\" (");
168 a68_print_short_pack (f, PACK (z));
169 WRITE (f, ")");
170 } else if (IS (z, STOWED_MODE)) {
171 WRITE (f, "\"STOWED\" (");
172 a68_print_short_pack (f, PACK (z));
173 WRITE (f, ")");
174 }
175 }
176 }
177
178 //! @brief Print_mode_flat.
179
180 void print_mode_flat (FILE_T f, MOID_T * m)
181 {
182 if (m != NO_MOID) {
183 a68_print_mode (f, m);
184 if (NODE (m) != NO_NODE && NUMBER (NODE (m)) > 0) {
185 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " node %d", NUMBER (NODE (m))) >= 0);
186 WRITE (f, A68 (output_line));
187 }
188 if (EQUIVALENT_MODE (m) != NO_MOID) {
189 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " equi #%d", NUMBER (EQUIVALENT (m))) >= 0);
190 WRITE (f, A68 (output_line));
191 }
192 if (SLICE (m) != NO_MOID) {
193 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " slice #%d", NUMBER (SLICE (m))) >= 0);
194 WRITE (f, A68 (output_line));
195 }
196 if (TRIM (m) != NO_MOID) {
197 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " trim #%d", NUMBER (TRIM (m))) >= 0);
198 WRITE (f, A68 (output_line));
199 }
200 if (ROWED (m) != NO_MOID) {
201 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " rowed #%d", NUMBER (ROWED (m))) >= 0);
202 WRITE (f, A68 (output_line));
203 }
204 if (DEFLEXED (m) != NO_MOID) {
205 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " deflex #%d", NUMBER (DEFLEXED (m))) >= 0);
206 WRITE (f, A68 (output_line));
207 }
208 if (MULTIPLE (m) != NO_MOID) {
209 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " multiple #%d", NUMBER (MULTIPLE (m))) >= 0);
210 WRITE (f, A68 (output_line));
211 }
212 if (NAME (m) != NO_MOID) {
213 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " name #%d", NUMBER (NAME (m))) >= 0);
214 WRITE (f, A68 (output_line));
215 }
216 if (USE (m)) {
217 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " used") >= 0);
218 WRITE (f, A68 (output_line));
219 }
220 if (DERIVATE (m)) {
221 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " derivate") >= 0);
222 WRITE (f, A68 (output_line));
223 }
224 if (SIZE (m) > 0) {
225 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " size %d", SIZE (m)) >= 0);
226 WRITE (f, A68 (output_line));
227 }
228 if (HAS_ROWS (m)) {
229 WRITE (f, " []");
230 }
231 }
232 }
233
234 //! @brief Xref_tags.
235
236 void xref_tags (FILE_T f, TAG_T * s, int a)
237 {
238 for (; s != NO_TAG; FORWARD (s)) {
239 NODE_T *where_tag = NODE (s);
240 if ((where_tag != NO_NODE) && ((STATUS_TEST (where_tag, CROSS_REFERENCE_MASK)) || TAG_TABLE (s) == A68_STANDENV)) {
241 WRITE (f, "\n ");
242 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "tag %d ", NUMBER (s)) >= 0);
243 WRITE (f, A68 (output_line));
244 switch (a) {
245 case IDENTIFIER:
246 {
247 a68_print_mode (f, MOID (s));
248 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s", NSYMBOL (NODE (s))) >= 0);
249 WRITE (f, A68 (output_line));
250 break;
251 }
252 case INDICANT:
253 {
254 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "indicant %s ", NSYMBOL (NODE (s))) >= 0);
255 WRITE (f, A68 (output_line));
256 a68_print_mode (f, MOID (s));
257 break;
258 }
259 case PRIO_SYMBOL:
260 {
261 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "priority %s %d", NSYMBOL (NODE (s)), PRIO (s)) >= 0);
262 WRITE (f, A68 (output_line));
263 break;
264 }
265 case OP_SYMBOL:
266 {
267 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "operator %s ", NSYMBOL (NODE (s))) >= 0);
268 WRITE (f, A68 (output_line));
269 a68_print_mode (f, MOID (s));
270 break;
271 }
272 case LABEL:
273 {
274 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "label %s", NSYMBOL (NODE (s))) >= 0);
275 WRITE (f, A68 (output_line));
276 break;
277 }
278 case ANONYMOUS:
279 {
280 switch (PRIO (s)) {
281 case ROUTINE_TEXT:
282 {
283 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "routine text ") >= 0);
284 break;
285 }
286 case FORMAT_TEXT:
287 {
288 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "format text ") >= 0);
289 break;
290 }
291 case FORMAT_IDENTIFIER:
292 {
293 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "format item ") >= 0);
294 break;
295 }
296 case COLLATERAL_CLAUSE:
297 {
298 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "display ") >= 0);
299 break;
300 }
301 case GENERATOR:
302 {
303 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "generator ") >= 0);
304 break;
305 }
306 }
307 WRITE (f, A68 (output_line));
308 a68_print_mode (f, MOID (s));
309 break;
310 }
311 default:
312 {
313 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "internal %d ", a) >= 0);
314 WRITE (f, A68 (output_line));
315 a68_print_mode (f, MOID (s));
316 break;
317 }
318 }
319 if (NODE (s) != NO_NODE && NUMBER (NODE (s)) > 0) {
320 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", node %d", NUMBER (NODE (s))) >= 0);
321 WRITE (f, A68 (output_line));
322 }
323 if (where_tag != NO_NODE && INFO (where_tag) != NO_NINFO && LINE (INFO (where_tag)) != NO_LINE) {
324 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", line %d", LINE_NUMBER (where_tag)) >= 0);
325 WRITE (f, A68 (output_line));
326 }
327 }
328 }
329 }
330
331 //! @brief Xref_decs.
332
333 void xref_decs (FILE_T f, TABLE_T * t)
334 {
335 if (INDICANTS (t) != NO_TAG) {
336 xref_tags (f, INDICANTS (t), INDICANT);
337 }
338 if (OPERATORS (t) != NO_TAG) {
339 xref_tags (f, OPERATORS (t), OP_SYMBOL);
340 }
341 if (PRIO (t) != NO_TAG) {
342 xref_tags (f, PRIO (t), PRIO_SYMBOL);
343 }
344 if (IDENTIFIERS (t) != NO_TAG) {
345 xref_tags (f, IDENTIFIERS (t), IDENTIFIER);
346 }
347 if (LABELS (t) != NO_TAG) {
348 xref_tags (f, LABELS (t), LABEL);
349 }
350 if (ANONYMOUS (t) != NO_TAG) {
351 xref_tags (f, ANONYMOUS (t), ANONYMOUS);
352 }
353 }
354
355 //! @brief Xref1_moid.
356
357 void xref1_moid (FILE_T f, MOID_T * p)
358 {
359 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n #%d ", NUMBER (p)) >= 0);
360 WRITE (f, A68 (output_line));
361 print_mode_flat (f, p);
362 }
363
364 //! @brief Moid_listing.
365
366 void moid_listing (FILE_T f, MOID_T * m)
367 {
368 for (; m != NO_MOID; FORWARD (m)) {
369 xref1_moid (f, m);
370 }
371 WRITE (f, "\n");
372 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE STRING #%d ", NUMBER (M_STRING)) >= 0);
373 WRITE (f, A68 (output_line));
374 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE COMPLEX #%d ", NUMBER (M_COMPLEX)) >= 0);
375 WRITE (f, A68 (output_line));
376 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n MODE SEMA #%d ", NUMBER (M_SEMA)) >= 0);
377 WRITE (f, A68 (output_line));
378 }
379
380 //! @brief Cross_reference.
381
382 void cross_reference (FILE_T f, NODE_T * p, LINE_T * l)
383 {
384 if (p != NO_NODE && CROSS_REFERENCE_SAFE (&A68_JOB)) {
385 for (; p != NO_NODE; FORWARD (p)) {
386 if (is_new_lexical_level (p) && l == LINE (INFO (p))) {
387 TABLE_T *c = TABLE (SUB (p));
388 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n\n[level %d", LEVEL (c)) >= 0);
389 WRITE (f, A68 (output_line));
390 if (PREVIOUS (c) == A68_STANDENV) {
391 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", in standard environ") >= 0);
392 } else {
393 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", in level %d", LEVEL (PREVIOUS (c))) >= 0);
394 }
395 WRITE (f, A68 (output_line));
396 #if (A68_LEVEL >= 3)
397 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %llu increment]", AP_INCREMENT (c)) >= 0);
398 #else
399 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %u increment]", AP_INCREMENT (c)) >= 0);
400 #endif
401 WRITE (f, A68 (output_line));
402 if (c != NO_TABLE) {
403 xref_decs (f, c);
404 }
405 WRITE (f, "\n");
406 }
407 cross_reference (f, SUB (p), l);
408 }
409 }
410 }
411
412 //! @brief Tree listing for source line.
413
414 BOOL_T empty_leaf (NODE_T * p)
415 {
416 #define TEST_LEAVE(n)\
417 if (IS (p, (n)) && NEXT (p) == NO_NODE && PREVIOUS (p) == NO_NODE) {\
418 return A68_TRUE;\
419 }
420 TEST_LEAVE (ENCLOSED_CLAUSE);
421 TEST_LEAVE (UNIT);
422 TEST_LEAVE (TERTIARY);
423 TEST_LEAVE (SECONDARY);
424 TEST_LEAVE (PRIMARY);
425 TEST_LEAVE (DENOTATION);
426 return A68_FALSE;
427 #undef TEST_LEAVE
428 }
429
430 //! @brief Tree listing for source line.
431
432 void tree_listing (FILE_T f, NODE_T * q, int x, LINE_T * l, int *ld, BOOL_T comment)
433 {
434 for (; q != NO_NODE; FORWARD (q)) {
435 NODE_T *p = q;
436 int k, dist;
437 if (((STATUS_TEST (p, TREE_MASK)) || comment) && l == LINE (INFO (p))) {
438 if (*ld < 0) {
439 *ld = x;
440 }
441 // Indent.
442 if (comment && empty_leaf (p)) {
443 ;
444 } else {
445 if (comment) {
446 WRITE (f, "\n// ");
447 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%06d ", NUMBER (p)) >= 0);
448 WRITE (f, A68 (output_line));
449 } else {
450 WRITE (f, "\n ");
451 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%02d %06d p%02d ", x, NUMBER (p), PROCEDURE_LEVEL (INFO (p))) >= 0);
452 WRITE (f, A68 (output_line));
453 if (PREVIOUS (TABLE (p)) != NO_TABLE) {
454 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%02d-%02d-%02d ", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (TABLE (p) != NO_TABLE ? LEVEL (PREVIOUS (TABLE (p))) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0)
455 ) >= 0);
456 } else {
457 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%02d- -%02d", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0)
458 ) >= 0);
459 }
460 WRITE (f, A68 (output_line));
461 if (MOID (q) != NO_MOID) {
462 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "#%04d ", NUMBER (MOID (p))) >= 0);
463 } else {
464 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " ") >= 0);
465 }
466 WRITE (f, A68 (output_line));
467 }
468 for (k = 0; k < (x - *ld); k++) {
469 WRITE (f, A68 (marker)[k]);
470 }
471 if (MOID (p) != NO_MOID) {
472 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s ", moid_to_string (MOID (p), MOID_WIDTH, NO_NODE)) >= 0);
473 WRITE (f, A68 (output_line));
474 }
475 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s", non_terminal_string (A68 (edit_line), ATTRIBUTE (p))) >= 0);
476 WRITE (f, A68 (output_line));
477 if (SUB (p) == NO_NODE) {
478 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0);
479 WRITE (f, A68 (output_line));
480 }
481 if (!comment) {
482 if (TAX (p) != NO_TAG) {
483 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", tag %06u", (unt) NUMBER (TAX (p))) >= 0);
484 WRITE (f, A68 (output_line));
485 if (MOID (TAX (p)) != NO_MOID) {
486 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", mode %06u", (unt) NUMBER (MOID (TAX (p)))) >= 0);
487 WRITE (f, A68 (output_line));
488 }
489 }
490 if (GINFO (p) != NO_GINFO && propagator_name (UNIT (&GPROP (p))) != NO_TEXT) {
491 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %s", propagator_name (UNIT (&GPROP (p)))) >= 0);
492 WRITE (f, A68 (output_line));
493 }
494 if (GINFO (p) != NO_GINFO && COMPILE_NAME (GINFO (p)) != NO_TEXT) {
495 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %s", COMPILE_NAME (GINFO (p))) >= 0);
496 WRITE (f, A68 (output_line));
497 }
498 if (GINFO (p) != NO_GINFO && COMPILE_NODE (GINFO (p)) > 0) {
499 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %6d", COMPILE_NODE (GINFO (p))) >= 0);
500 WRITE (f, A68 (output_line));
501 }
502 }
503 }
504 dist = x - (*ld);
505 if (dist >= 0 && dist < BUFFER_SIZE) {
506 A68 (marker)[dist] = (NEXT (p) != NO_NODE && l == LINE (INFO (NEXT (p))) ? "|" : " ");
507 }
508 }
509 tree_listing (f, SUB (p), x + 1, l, ld, comment);
510 dist = x - (*ld);
511 if (dist >= 0 && dist < BUFFER_SIZE) {
512 A68 (marker)[dist] = " ";
513 }
514 }
515 }
516
517 //! @brief Leaves_to_print.
518
519 int leaves_to_print (NODE_T * p, LINE_T * l)
520 {
521 int z = 0;
522 for (; p != NO_NODE && z == 0; FORWARD (p)) {
523 if (l == LINE (INFO (p)) && ((STATUS_TEST (p, TREE_MASK)))) {
524 z++;
525 } else {
526 z += leaves_to_print (SUB (p), l);
527 }
528 }
529 return z;
530 }
531
532 //! @brief List_source_line.
533
534 void list_source_line (FILE_T f, LINE_T * line, BOOL_T tree)
535 {
536 int k = (int) strlen (STRING (line)) - 1;
537 if (NUMBER (line) <= 0) {
538 // Mask the prelude and postlude.
539 return;
540 }
541 if ((STRING (line))[k] == NEWLINE_CHAR) {
542 (STRING (line))[k] = NULL_CHAR;
543 }
544 // Print source line.
545 write_source_line (f, line, NO_NODE, A68_ALL_DIAGNOSTICS);
546 // Cross reference for lexical levels starting at this line.
547 if (OPTION_CROSS_REFERENCE (&A68_JOB)) {
548 cross_reference (f, TOP_NODE (&A68_JOB), line);
549 }
550 // Syntax tree listing connected with this line.
551 if (tree && OPTION_TREE_LISTING (&A68_JOB)) {
552 if (TREE_LISTING_SAFE (&A68_JOB) && leaves_to_print (TOP_NODE (&A68_JOB), line)) {
553 int ld = -1, k2;
554 WRITE (f, "\n\nSyntax tree");
555 for (k2 = 0; k2 < BUFFER_SIZE; k2++) {
556 A68 (marker)[k2] = " ";
557 }
558 tree_listing (f, TOP_NODE (&A68_JOB), 1, line, &ld, A68_FALSE);
559 WRITE (f, "\n");
560 }
561 }
562 }
563
564 //! @brief Source_listing.
565
566 void write_source_listing (void)
567 {
568 LINE_T *line = TOP_LINE (&A68_JOB);
569 FILE_T f = FILE_LISTING_FD (&A68_JOB);
570 int listed = 0;
571 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
572 WRITE (FILE_LISTING_FD (&A68_JOB), "\nSource listing");
573 WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ -------");
574 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
575 if (FILE_LISTING_OPENED (&A68_JOB) == 0) {
576 diagnostic (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING);
577 return;
578 }
579 for (; line != NO_LINE; FORWARD (line)) {
580 if (NUMBER (line) > 0 && LIST (line)) {
581 listed++;
582 }
583 list_source_line (f, line, A68_FALSE);
584 }
585 // Warn if there was no source at all.
586 if (listed == 0) {
587 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n No lines to list") >= 0);
588 WRITE (f, A68 (output_line));
589 }
590 }
591
592 //! @brief Write_source_listing.
593
594 void write_tree_listing (void)
595 {
596 LINE_T *line = TOP_LINE (&A68_JOB);
597 FILE_T f = FILE_LISTING_FD (&A68_JOB);
598 int listed = 0;
599 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
600 WRITE (FILE_LISTING_FD (&A68_JOB), "\nSyntax tree listing");
601 WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ ---- -------");
602 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
603 if (FILE_LISTING_OPENED (&A68_JOB) == 0) {
604 diagnostic (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING);
605 return;
606 }
607 for (; line != NO_LINE; FORWARD (line)) {
608 if (NUMBER (line) > 0 && LIST (line)) {
609 listed++;
610 }
611 list_source_line (f, line, A68_TRUE);
612 }
613 // Warn if there was no source at all.
614 if (listed == 0) {
615 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n No lines to list") >= 0);
616 WRITE (f, A68 (output_line));
617 }
618 }
619
620 //! @brief Write_object_listing.
621
622 void write_object_listing (void)
623 {
624 if (OPTION_OBJECT_LISTING (&A68_JOB)) {
625 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
626 WRITE (FILE_LISTING_FD (&A68_JOB), "\nObject listing");
627 WRITE (FILE_LISTING_FD (&A68_JOB), "\n------ -------");
628 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
629 compiler (FILE_LISTING_FD (&A68_JOB));
630 }
631 }
632
633 //! @brief Write_listing.
634
635 void write_listing (void)
636 {
637 FILE_T f = FILE_LISTING_FD (&A68_JOB);
638 if (OPTION_MOID_LISTING (&A68_JOB)) {
639 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
640 WRITE (FILE_LISTING_FD (&A68_JOB), "\nMode listing");
641 WRITE (FILE_LISTING_FD (&A68_JOB), "\n---- -------");
642 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
643 moid_listing (f, TOP_MOID (&A68_JOB));
644 }
645 if (OPTION_STANDARD_PRELUDE_LISTING (&A68_JOB) && A68_STANDENV != NO_TABLE) {
646 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
647 WRITE (FILE_LISTING_FD (&A68_JOB), "\nStandard prelude listing");
648 WRITE (FILE_LISTING_FD (&A68_JOB), "\n-------- ------- -------");
649 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
650 xref_decs (f, A68_STANDENV);
651 }
652 if (TOP_REFINEMENT (&A68_JOB) != NO_REFINEMENT) {
653 REFINEMENT_T *x = TOP_REFINEMENT (&A68_JOB);
654 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
655 WRITE (FILE_LISTING_FD (&A68_JOB), "\nRefinement listing");
656 WRITE (FILE_LISTING_FD (&A68_JOB), "\n---------- -------");
657 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
658 while (x != NO_REFINEMENT) {
659 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n \"%s\"", NAME (x)) >= 0);
660 WRITE (f, A68 (output_line));
661 if (LINE_DEFINED (x) != NO_LINE) {
662 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", defined in line %d", NUMBER (LINE_DEFINED (x))) >= 0);
663 WRITE (f, A68 (output_line));
664 }
665 if (LINE_APPLIED (x) != NO_LINE) {
666 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", applied in line %d", NUMBER (LINE_APPLIED (x))) >= 0);
667 WRITE (f, A68 (output_line));
668 }
669 switch (APPLICATIONS (x)) {
670 case 0:
671 {
672 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", not applied") >= 0);
673 WRITE (f, A68 (output_line));
674 break;
675 }
676 case 1:
677 {
678 break;
679 }
680 default:
681 {
682 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", applied more than once") >= 0);
683 WRITE (f, A68 (output_line));
684 break;
685 }
686 }
687 FORWARD (x);
688 }
689 }
690 if (OPTION_LIST (&A68_JOB) != NO_OPTION_LIST) {
691 OPTION_LIST_T *i;
692 int k = 1;
693 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
694 WRITE (FILE_LISTING_FD (&A68_JOB), "\nPragmat listing");
695 WRITE (FILE_LISTING_FD (&A68_JOB), "\n------- -------");
696 WRITE (FILE_LISTING_FD (&A68_JOB), NEWLINE_STRING);
697 for (i = OPTION_LIST (&A68_JOB); i != NO_OPTION_LIST; FORWARD (i)) {
698 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\n%d: %s", k++, STR (i)) >= 0);
699 WRITE (f, A68 (output_line));
700 }
701 }
702 }
703
704 //! @brief Write_listing_header.
705
706 void write_listing_header (void)
707 {
708 FILE_T f = FILE_LISTING_FD (&A68_JOB);
709 LINE_T *z;
710 state_version (FILE_LISTING_FD (&A68_JOB));
711 WRITE (FILE_LISTING_FD (&A68_JOB), "\nFile \"");
712 WRITE (FILE_LISTING_FD (&A68_JOB), FILE_SOURCE_NAME (&A68_JOB));
713 WRITE (FILE_LISTING_FD (&A68_JOB), "\"");
714 if (OPTION_STATISTICS_LISTING (&A68_JOB)) {
715 if (ERROR_COUNT (&A68_JOB) + WARNING_COUNT (&A68_JOB) > 0) {
716 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nDiagnostics: %d error(s), %d warning(s)", ERROR_COUNT (&A68_JOB), WARNING_COUNT (&A68_JOB)) >= 0);
717 WRITE (f, A68 (output_line));
718 for (z = TOP_LINE (&A68_JOB); z != NO_LINE; FORWARD (z)) {
719 if (DIAGNOSTICS (z) != NO_DIAGNOSTIC) {
720 write_source_line (f, z, NO_NODE, A68_TRUE);
721 }
722 }
723 }
724 }
725 }
