PROGRAM plist;

{$C+}   { ^S und ^C freigeben }

{$V-}   { kein Range-Checking bei String-Uebergabe }

CONST pl          : integer = 72;
      mt          : integer =  3;
      mb          : integer =  3;
      po          : integer =  0;
      cp          : integer =  0;
      he          : STRING [128] = '';
      fo          : STRING [128] = '';
      spaltenzahl : integer = 80;

TYPE line           = STRING [128];
     linelength     = 0..128;
     filetype       = (main, include);
     pufferzeiger   = ^puffer;
     puffer         = RECORD
                        eintrag   : line;
                        naechster : pufferzeiger
                      END;
     bez            = STRING [20];
     zeilenliste    = ^zeileneintrag;
     zeileneintrag  = RECORD
                        nummer : integer;
                        znext  : zeilenliste
                      END;
     identlist      = ^bezeichner;
     bezeichner     = RECORD
                        iname : bez;
                        l, r  : identlist;
                        zlist : zeilenliste
                      END;

VAR  wort,
     zeile          : line;
     mainfile,
     inclfile       : text;
     options        : SET OF (cross, lnummer, rmark,
                              fincl, autoblock, versch);
     mainfilename,
     inclfilename   : STRING [14];
     seitenzahl,
     zeilenzahl,
     zeilennummer,
     puffergroesse,
     iter           : integer;
     warteflag,
     kommentarflag,
     stringflag,
     includeflag,
     autoblockflag,
     listflag,
     puffervoll,
     caseflag       : boolean;
     anfang, p, q   : pufferzeiger;
     crosslist      : identlist;

{======================================================================}

{          Erzeugung und Ausdruck der Cross-Referenz-Liste             }

PROCEDURE neueseite; FORWARD;

{----------------------------------------------------------------------}

FUNCTION gross (x : line) : line;

VAR i : linelength;

BEGIN { gross }
  FOR i := 1 TO length (x) DO
    x [i] := upcase (x [i]);
  gross := x
END;  { gross }

{----------------------------------------------------------------------}

FUNCTION standard (VAR n : bez) : boolean;

CONST standardbezeichner : ARRAY [1..87] OF bez =
      ('ABS', 'ADDR', 'ARCTAN', 'ASSIGN', 'BDOS', 'BDOSHL', 'BIOS',
       'BIOSHL', 'BLOCKREAD', 'BLOCKWRITE', 'BOOLEAN', 'BYTE', 'CHAIN',
       'CHR', 'CLOSE', 'CLREOL', 'CLRSCR', 'CONCAT', 'COPY', 'COS',
       'CRTEXIT', 'CRTINIT', 'DELETE', 'DELAY', 'DELLINE', 'DISPOSE',
       'EOF', 'EOLN', 'EREASE', 'EXECUTE', 'EXP', 'FALSE', 'FILEPOS',
       'FILESIZE', 'FILLCHAR', 'FRAC', 'FREEMEM', 'GETMEM', 'GOTOXY',
       'HALT', 'HI', 'HIGHVIDEO', 'INSERT', 'INSLINE', ' INT',
       'INTEGER', 'IORESULT', 'KEYPRESSED', 'LENGTH', 'LN', 'LO',
       'LOWVIDEO', 'MARK', 'MAXAVAIL', 'MEMAVAIL', 'MOVE', 'NEW',
       'NORMVIDEO', 'ODD', 'ORD', 'POS', 'PRED', 'PTR', 'RANDOM',
       'RANDOMIZE', 'READ', 'READLN', 'REAL', 'RELEASE', 'RENAME',
       'RESET', 'REWRITE', 'ROUND', 'SEEK', 'SIN', 'SIZEOF', 'SQR',
       'SQRT', 'STR', 'SUCC', 'SWAP', 'TRUE', 'TRUNC', 'UPCASE',
       'VAL', 'WRITE', 'WRITELN');

VAR b       : bez;
    i, j, m : integer;

BEGIN { standard }
  b := gross (n);
  i := 1;
  j := 87;
  REPEAT
    m := (i+j) DIV 2;
    IF b <= standardbezeichner [m]
      THEN
        j := m
      ELSE
        i := m+1
  UNTIL i = j;
  standard := (standardbezeichner [i] = b)
END;  { standard }

{----------------------------------------------------------------------}

{ Die folgenden Prozeduren sind fuer die Cross-Referenz-Liste
  zustaendig. Dabei werden Standard-Prozeduren und -Funktionen nicht
  beruecksichtigt. }

PROCEDURE einfuegen (w : bez; ln : integer);

LABEL exit;

VAR gefunden : boolean;
    p, q     : identlist;
    cl, cnl  : zeilenliste;

{......................................................................}

PROCEDURE machzweig (VAR b : identlist; w : bez);

BEGIN { machzweig }
  new (b);
  gefunden := true;
  WITH b^ DO
    BEGIN
      l := NIL;
      r := NIL;
      iname := w;
      new (zlist);
      zlist^.nummer := ln;
      zlist^.znext  := NIL
    END
END;  { machzweig }

{......................................................................}

BEGIN { einfuegen }
  IF standard (w)
    THEN
      GOTO exit;
  gefunden := false;
  q := crosslist;
  IF crosslist = NIL
    THEN
      machzweig (crosslist, w)
    ELSE
      REPEAT
        IF gross (w) < gross (q^.iname)
          THEN
            IF q^.l = NIL
              THEN
                BEGIN
                  machzweig (p, w);
                  q^.l := p
                END
              ELSE
                q := q^.l
          ELSE
            IF gross (w) > gross (q^.iname)
              THEN
                IF q^.r = NIL
                  THEN
                    BEGIN
                      machzweig (p, w);
                      q^.r := p
                    END
                  ELSE
                    q := q^.r
              ELSE
                WITH q^ DO
                  BEGIN
                    gefunden := true;
                    cl := zlist;
                    WHILE cl^.znext <> NIL DO
                      cl := cl^.znext;
                    IF cl^.nummer <> ln
                      THEN
                        BEGIN
                          new (cnl);
                          cnl^.nummer := ln;
                          cnl^.znext := NIL;
                          cl^.znext := cnl
                        END
                  END
      UNTIL gefunden;
  exit:
END;  { einfuegen }

{----------------------------------------------------------------------}

PROCEDURE schreibliste (l : identlist; az : integer);

VAR h : zeilenliste;
    z : integer;

BEGIN { schreibliste }
  mt := 3;
  IF pl-zeilenzahl-mb < 8
    THEN
      neueseite;
  IF pl-zeilenzahl-mb < 5
    THEN
      neueseite;
  write (LST, '':po, l^.iname, ':':20-length (l^.iname));
  h := l^.zlist;
  z := 0;
  WHILE h <> NIL DO
    BEGIN
      IF z = az
        THEN
          BEGIN
            writeln (LST);
            zeilenzahl := succ (zeilenzahl);
            write (LST, '':20+po);
            z :=0
          END;
      write (LST, h^.nummer:6);
      h := h^.znext;
      z := succ (z)
    END;
    writeln (LST);
    zeilenzahl := succ (zeilenzahl)
END;  { schreibliste }

{----------------------------------------------------------------------}

{$A-}

PROCEDURE schreibbaum (b : identlist; az : integer);

VAR xl, xr : integer;

BEGIN { schreibbaum }
  IF b <> NIL
    THEN
      BEGIN
        IF b^.l <> NIL
          THEN
            schreibbaum (b^.l, az);
        schreibliste (b, az);
        IF b^.r <> NIL
          THEN
            schreibbaum (b^.r, az)
      END
END;  { schreibbaum }

{$A+}

{----------------------------------------------------------------------}

PROCEDURE schreibcrossliste;

BEGIN { schreibcrossliste }
  mt := 3;
  IF pl-zeilenzahl-mt < 8
    THEN
      neueseite;
  writeln (LST);
  writeln (LST, 'Cross-Referenz-Liste:');
  writeln (LST);
  zeilenzahl := zeilenzahl+3;
  schreibbaum (crosslist, (spaltenzahl-21-po) DIV 6)
END;  { schreibcrossliste }

{======================================================================}

{              Eingabe von Programm-Namen und Optionen                 }

PROCEDURE liesfilename;

VAR n : STRING [14];

BEGIN { liesfilename }
  readln (n);
  mainfilename := gross (n);
  writeln
END;  { liesfilename }

{----------------------------------------------------------------------}

PROCEDURE liesoptions;

VAR i : 1..6;
    o : STRING [6];

BEGIN { liesoptions }
  writeln ('L - Zeilen-Nummern werden mitgedruckt');
  writeln ('M - Reservierte Woerter werden markiert');
  writeln ('I - Include-Files werden ausgedruckt');
  writeln ('A - Absaetze werden zusammengehalten');
  writeln ('V - druckt Verschachtelungstiefe');
  writeln ('C - generiert Cross-Referenz-Liste');
  writeln;
  write ('L, M, I, A, V, C, LM, LI, MI, LMI ... LMIAVC : ');
  readln (o);
  options := [];
  FOR i := 1 TO length (o) DO
    CASE o [i] OF
      'L', 'l' : options := options+[lnummer];
      'M', 'm' : options := options+[rmark];
      'I', 'i' : options := options+[fincl];
      'A', 'a' : options := options+[autoblock];
      'V', 'v' : options := options+[versch];
      'C', 'c' : options := options+[cross]
    END;
  autoblockflag := autoblock IN options;
  IF cross IN options
    THEN
      REPEAT
        {$I-}
        write ('Anzahl der darstellbaren Zeichen pro Zeile : ');
        readln (spaltenzahl)
        {$I+}
      UNTIL ioresult = 0;
  write ('Warten nach jeder Seite (J/N) ? ');
  readln (o);
  warteflag := (o = 'J') OR (o = 'j')
END;  { liesoptions }

{----------------------------------------------------------------------}

FUNCTION fileexists (x : filetype) : boolean;
{ Falls das File existiert wird es zugleich eroeffnet. }

BEGIN { fileexists }
  CASE x OF
    main    : BEGIN
                assign (mainfile, mainfilename);
                {$I-}
                reset (mainfile)
                {$I+}
              END;
    include : BEGIN
                assign (inclfile, inclfilename);
                {$I-}
                reset (inclfile)
                {$I+}
              END
  END;
  fileexists := (ioresult = 0)
END;  { fileexists }

{----------------------------------------------------------------------}

PROCEDURE schliessincludefile;

BEGIN { schliessincludefile }
  close (inclfile);
  includeflag := false
END;  { schliessincludefile }

{======================================================================}

{                           Drucker-Ausgabe                            }

PROCEDURE drucke (VAR x : line);

VAR i : linelength;
    a : line;

{......................................................................}

FUNCTION reserviert (VAR x : line) : boolean;

CONST reswords : ARRAY [1..45] OF STRING [10] =
      ('ABSOLUTE', 'AND', 'ARRAY', 'BEGIN', 'CASE', 'CONST', 'DIV',
       'DO', 'DOWNTO', 'ELSE', 'END', 'END.', 'EXTERNAL', 'FILE',
       'FOR', 'FORWARD', 'FUNCTION', 'GOTO', 'IF', 'IN', 'INLINE',
       'LABEL', 'MOD', 'NIL', 'NOT', 'OF', 'OR', 'OVERLAY', 'PACKED',
       'PROCEDURE', 'PROGRAM', 'RECORD', 'REPEAT', 'SET', 'SHL',
       'SHR', 'STRING', 'THEN', 'TO', 'TYPE', 'UNTIL', 'VAR',
       'WHILE', 'WITH', ' XOR');

VAR i, j, m : 1..50;
    h       : boolean;
    w       : line;

BEGIN { reserviert }
  h := false;
  i := 1;
  j := 45;
  w := gross (x);
  IF NOT (kommentarflag) AND NOT (stringflag)
    THEN
      BEGIN
        REPEAT
          m := (i+j) DIV 2;
          IF w <= reswords [m]
            THEN
              j := m
            ELSE
              i := m+1
        UNTIL i = j;
        h := (reswords [i] = w)
      END;
  reserviert := h;
  IF h
    THEN
      IF (w = 'BEGIN') OR (w = 'REPEAT')
        THEN
          iter := iter+1
        ELSE
          IF (w = 'RECORD')
            THEN
              BEGIN
                caseflag := false;
                iter := iter+1
              END
            ELSE
              IF (w = 'CASE') AND caseflag
                THEN
                  iter := iter+1
    ELSE
      IF (w = 'END') OR (w = 'UNTIL') OR (w = 'END.')
        THEN
          BEGIN
            caseflag := true;
            iter := iter-1
          END
END;  { reserviert }

{......................................................................}

PROCEDURE markiere (VAR x : line);

{ Hier koennen die Druckersteuersequenzen zum markieren der reservier-
  ten Woerter eingesetzt werden.                                       }

VAR i, j : byte;

BEGIN { markiere }
  IF rmark IN options
    THEN
      BEGIN
        FOR i := 1 TO 3 DO
          BEGIN
            write (LST, gross (x));
            FOR j := 1 TO length (x) DO
              write (LST, #8)
          END;
          write (LST, gross (x))
      END
    ELSE
      write (LST, x)
END;  { markiere }

{......................................................................}

BEGIN { drucke }
  write (LST, '':po);
  IF lnummer IN options
    THEN
      write (LST, zeilennummer:5, ': ');
  IF versch IN options
    THEN
      write (LST, iter:2, ' ');
  a := '';
  i := 1;
  WHILE i <= length (x) DO
    BEGIN
      IF x [i] IN ['^', 'A'..'Z', 'a'..'z']
        THEN
          BEGIN
            a := x [i];
            i := succ (i);
            WHILE (x [i] IN ['.', '^', '0'..'9', 'A'..'Z',
                                                 'a'..'z', '_'])
                         AND (i <= length (x)) DO
              BEGIN
                a := a+x [i];
                i := succ (i)
              END
          END
        ELSE
          BEGIN
            IF a <> ''
              THEN
                IF reserviert (a)
                  THEN
                    markiere (a)
                  ELSE
                    BEGIN
                      write (LST, a);
                      IF cross IN options
                        THEN
                          IF NOT kommentarflag
                            THEN
                              IF NOT stringflag
                                THEN
                                  einfuegen (a, zeilennummer)
                    END;
                a := '';
                write (LST, x[i]);
                IF NOT (stringflag)   AND ((x [i] = '{')
                    OR ((x [i] = '(') AND (x [i+1] = '*')))
                  THEN
                    kommentarflag := true;
                IF NOT (stringflag)   AND ((x [i] = '}')
                    OR ((x [i] = '*') AND (x [i+1] = ')')))
                  THEN
                    kommentarflag := false;
                IF NOT (kommentarflag)   AND (x [i] = chr (39))
                  THEN
                    stringflag := NOT (stringflag);
                i := succ (i)
          END
    END;
    IF a <> ''
      THEN
        IF reserviert (a)
          THEN
            markiere (a)
          ELSE
            BEGIN
              write (LST, a);
              IF NOT (kommentarflag OR stringflag)
                 AND (cross IN options)
                THEN
                  einfuegen (a, zeilennummer)
            END;
        writeln (LST);
        stringflag := false
END;  { drucke }

{----------------------------------------------------------------------}

PROCEDURE seitenkopf;

VAR i : linelength;

BEGIN { seitenkopf }
  IF listflag
    THEN
      BEGIN
        writeln (LST);
        write (LST, '':po);
        FOR i := 1 TO length (he) DO
          IF he [i] = '#'
            THEN
              write (LST, seitenzahl)
            ELSE
              write (LST, he [i]);
        writeln (LST);
        FOR i := 1 TO mt DO
          writeln (LST);
        zeilenzahl := mt+3
      END
END;  { seitenkopf }

{----------------------------------------------------------------------}

PROCEDURE neueseite;

VAR i : linelength;

BEGIN { neueseite }
  puffergroesse := 0;
  IF listflag
    THEN
      BEGIN
        write (LST, '':po);
        FOR i := zeilenzahl TO pl-3 DO
          writeln (LST);
        FOR i := 1 TO length (fo) DO
          IF fo [i] = '#'
            THEN
              write (LST, seitenzahl)
            ELSE
              write (LST, fo [i]);
        FOR i := 1 TO 3 DO
          writeln (LST);
        seitenzahl := seitenzahl+1;
        IF warteflag
          THEN
            BEGIN
              write ('Weiter mit RETURN');
              readln
            END;
        seitenkopf
      END
END;  { neueseite }

{======================================================================}

{         Bearbeitung von Punkt- und Compiler-Anweisungen              }

FUNCTION sonder (VAR x : line) : boolean;

BEGIN { sonder }
  sonder := (pos (chr (39), x) = 0)     AND ((pos ('{.', x) > 0)
             OR (pos ('(*.', x) > 0)     OR ((fincl IN options)
            AND ((pos ('{$I', x) > 0)    OR (pos ('(*$I', x) > 0))
            AND ( pos ('{$I+', x) = 0)  AND (pos ('{$I-', x) = 0)
            AND ( pos ('(*$I+', x) = 0) AND (pos ('(*$I-', x) = 0)));
END;  { sonder }

{----------------------------------------------------------------------}

