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  }