PROGRAM pstat;

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

{$V-}   { Kein Range-Checking bei String-Uebergabe. }

TYPE line           = STRING [128];
     linelength     = 0..128;
     filetype       = (main, include);
     pufferzeiger   = ^puffer;
     puffer         = RECORD
                        eintrag   : line;
                        naechster : pufferzeiger
                      END;

VAR  wort,
     zeile          : line;
     mainfile,
     inclfile       : text;
     filename,
     mainfilename,
     inclfilename   : STRING [14];
     qq,
     puffergroesse,
     iter           : integer;
     kommentarflag,
     stringflag,
     includeflag,
     namenflag,
     puffervoll     : boolean;
     anfang, p, q   : pufferzeiger;
     i              : integer;
     a, b           : line;

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

{                        Utility - Proceduren                        }

FUNCTION gross (x : line) : line;

VAR i : integer;

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

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

PROCEDURE liesfilename;

VAR n : STRING [14];

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

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

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 }

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

{              Entschluesselung der Include-Anweisungen              }

FUNCTION sonder (VAR x : line) : boolean;

BEGIN { sonder }
  sonder := (pos (chr (39), x) = 0)
            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 }

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

FUNCTION sonderzeile (VAR x : line) : boolean;

VAR h : boolean;
    i : integer;

BEGIN { sonderzeile }
  h := sonder (x);
  IF h
    THEN
      BEGIN
        i := pos ('{$I', x)+3;
        IF i = 3
          THEN
            i := pos ('(*$I', x)+4;
        IF i > 3
          THEN
            BEGIN
              inclfilename := '';
              WHILE x [i] = '' DO
                i := i+1;
              WHILE (i < length (x)) AND (x [i] IN
                    ['-', '.', '0'..'9', 'A'..'Z', 'a'..'z']) DO
                BEGIN
                  inclfilename := inclfilename+gross (x [i]);
                  i := i+1
                END;
              IF mainfilename [2] = ':'
                THEN
                  IF inclfilename [2] = ':'
                    THEN
                      inclfilename [1] := mainfilename [1]
                    ELSE
                      inclfilename :=mainfilename[1]+':'+inclfilename;
              includeflag := fileexists (include);
              h := includeflag
            END
      END;
  sonderzeile := h
END;  { sonderzeile }

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

{                         Puffer-Operationen                         }

FUNCTION endofblock : boolean;

VAR h : boolean;

BEGIN { endofblock }
  h := eof (mainfile);
  IF includeflag
    THEN
      IF eof (inclfile)
        THEN
          BEGIN
            h := true;
            includeflag := false;
            schliessincludefile
          END;
  IF NOT (h)
    THEN
      h := sonder (zeile);
  IF abs (maxavail) < 500
    THEN
      h := true;
  endofblock := h
END;  { endofblock }

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

PROCEDURE clearpuffer;

BEGIN { clearpuffer }
  p := anfang;
  WHILE p^.naechster <> NIL DO
    BEGIN
      q := p;
      dispose (p);
      p := q^.naechster
    END;
  dispose (p);
  puffervoll := false
END;  { clearpuffer }

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

PROCEDURE liespuffer;

VAR h : boolean;

BEGIN { liespuffer }
  puffergroesse := 0;
  new (q);
  anfang := q;
  q^.naechster := NIL;
  REPEAT
    IF includeflag
      THEN
        BEGIN
          readln (inclfile, zeile);
          FILENAME := inclfilename
        END
      ELSE
        BEGIN
          readln (mainfile, zeile);
          filename := mainfilename
        END;
    q^.eintrag := zeile;
    puffergroesse := puffergroesse+1;
    new (p);
    q^.naechster := p;
    p^.naechster := NIL;
    q := p
  UNTIL endofblock;
  puffervoll := true
END;  { liespuffer }

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

PROCEDURE print (a : line);

VAR i : integer;

BEGIN { print }
  IF filename [2] = ':'
    THEN
      filename := copy (filename, 3, length (filename)-2);
  write (LST, filename, ': ':14-length (filename));
  FOR i := 1 TO iter DO
    write (LST, '    ');
  write (LST, a, ' ')
END;  { print }

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

{                           Hauptprogramm                            }

BEGIN { pstat }
  includeflag   := false;
  stringflag    := false;
  anfang        := NIL;
  namenflag     := false;
  kommentarflag := false;
  puffervoll    := false;
  iter          := 0;
  qq            := 0;
  writeln ('PSTAT vers. 2.0');
  writeln;
  REPEAT
write ('Geben Sie den Programm-Namen ein, oder "RETURN" fuer Ende: ');
    liesfilename;
    IF (mainfilename <> '') AND fileexists (main)
      THEN
        BEGIN
          writeln (LST, 'Statische Struktur von ', mainfilename);
          writeln (LST);
          WHILE NOT (eof (mainfile)) OR puffervoll DO
            BEGIN
              IF NOT puffervoll
                THEN
                  BEGIN
                    liespuffer;
                    p := anfang
                  END;
              zeile := p^.eintrag+' ';
              p := p^.naechster;
              IF p^.naechster = NIL
                THEN
                  clearpuffer;
              IF NOT sonderzeile (zeile)
                THEN
                   BEGIN
                     a := '';
                     FOR i := 1 TO length (zeile) DO
                       BEGIN
                         IF zeile [i] IN [#39, '0'..'9', 'A'..'Z',
                                                         'a'..'z']
                           THEN
                             a := a+zeile [i]
                           ELSE
                             IF a <> ''
                               THEN
                                 BEGIN
                                   b := gross (a);
                                   IF (qq > 0) AND NOT (stringflag)
                                           AND NOT (kommentarflag)
                                     THEN
                                       BEGIN
                                         IF (b = 'CASE') OR
                                            (b = 'BEGIN')
                                           THEN
                                              qq := qq+1;
                                         IF b = 'END'
                                           THEN
                                             BEGIN
                                               qq := qq-1;
                                               IF qq = 0
                                                 THEN
                                                   iter := iter-1
                                             END
                                       END
                                     ELSE
                                       IF (qq=0) AND NOT (stringflag)
                                             AND NOT (kommentarflag)
                                         THEN
                                           BEGIN
                                             IF (b = 'FORWARD') OR
                                                (b = 'EXTERN')
                                               THEN
                                                 BEGIN
                                                   write(LST,'; ',b);
                                                   iter := iter-1
                                                 END;
                                             IF namenflag
                                               THEN
                                                 write (LST, a);
                                             namenflag := false;
                                             IF (b = 'PROCEDURE') OR
                                                (b = 'FUNCTION')
                                               THEN
                                                 BEGIN
                                                   writeln (LST);
                                                   print (b);
                                                   iter := succ(iter);
                                                   namenflag := true
                                                 END;
                                             IF (b = 'PROGRAM')
                                               THEN
                                                 BEGIN
                                                   writeln (LST);
                                                   print (b);
                                                   iter := 1;
                                                   namenflag := true
                                                 END;
                                             IF (b = 'BEGIN')
                                               THEN
                                                 qq := 1
                                           END;
                                   a := ''
                                 END;
                                 IF NOT (stringflag)
                                    AND (zeile [i] = '{')
                                   THEN
                                     kommentarflag := true;
                                 IF NOT (stringflag)
                                    AND (zeile [i] = '}')
                                   THEN
                                     kommentarflag := false;
                                 IF NOT (kommentarflag)
                                    AND (zeile [i] = chr (39))
                                   THEN
                                     stringflag := NOT (stringflag)
                       END
                  END
            END;
          close (mainfile);
          writeln (LST);
          writeln (LST)
        END
      ELSE
        IF mainfilename <> ''
          THEN
            writeln ('File existiert nicht.')
  UNTIL mainfilename = ''
END.  { pstat }