Turbo Toolbox/Turbo_Toolbox.iso/dtx9202/pretty/prparser.mod

Modula Implementation | 1991-02-18 | 23.0 KB | 797 lines

IMPLEMENTATION MODULE PRPARSER;
(*****************************************************************************)
(*                              Modula-2 Parser                              *)
(*                       (c) Peter Engels       1990                         *)
(*****************************************************************************)

FROM PRFILES IMPORT Comments;

FROM PRSCAN IMPORT SymbolTyp,TokenTyp,GetToken,ReadChar,ReadAgain,InitScanner;

FROM PRHASH IMPORT SearchInHashTable;

FROM FIO IMPORT OpenRead,Create,Close,EOF,RdChar,File,Rename,Erase,
                PrinterDevice,PathStr,Exists,AssignBuffer,IOcheck,IOresult,
                WrChar,WrStr,WrLn,WrCharRep,StandardOutput;

IMPORT IO;

FROM FIOR IMPORT ChangeExtension;

FROM Str IMPORT Copy,Compare;

FROM Lib IMPORT FatalError;

CONST BufferSize = 10 * 512;

VAR WriteBuffer,ReadBuffer : ARRAY [1..BufferSize] OF BYTE;

  PROCEDURE MakePretty (sourcename,destname : ARRAY OF CHAR);

  TYPE termset = SET OF SymbolTyp;

  CONST shift = 2; (* Einruecktiefe *)
        maxwidth = 77;
        terminators = termset {semicolon,bar,endsy,ifsy,elsifsy,elsesy,casesy,
                      loopsy,repeatsy,untilsy,withsy,whilesy,forsy};
        BlankBefore = termset {abssy..withsy,alias,colon,define,equal..lpar,
                      notequal,operationsy,shiftl,shiftr};
        Test = FALSE; (* für Testzwecke auf TRUE - Ausgabe auf Schirm *)

  VAR ColNum,lastpos : CARDINAL;
      nocr,defmodule : BOOLEAN;
      source,destination : File;
      token : TokenTyp;
      lastsymbol : SymbolTyp;
      writename : PathStr;

    PROCEDURE closefiles (error : BOOLEAN);

    VAR errorcode : CARDINAL;

    BEGIN
      Close (source);
(*%F Test *)
      IF destination # PrinterDevice THEN
        Close (destination);
        IF NOT error THEN
          IF Exists (destname) THEN
            Erase (destname)
          END;
          errorcode := IOresult ();
          IF errorcode = 0 THEN
            Rename (writename,destname)
          ELSIF errorcode = 5 THEN
            IO.WrLn;
            IO.WrStr ('Access denied' + CHR (7));
            IO.WrLn;
            Erase (writename)
          ELSE
            IO.WrLn;
            IO.WrStr ('IO-Error' + CHR (7));
            IO.WrLn;
            Erase (writename)
          END;
        END
      END
(*%E*)
    END closefiles;

    PROCEDURE errorhandler (msg : ARRAY OF CHAR);

    BEGIN
      closefiles (TRUE);
      IO.WrChar (7C);
      FatalError (msg)
    END errorhandler;

    PROCEDURE SetCol (f : File;
                      pos : CARDINAL);

    BEGIN
      WrCharRep (f,' ',pos);
      INC (ColNum,pos)
    END SetCol;

    PROCEDURE crlf (depth : CARDINAL);

    BEGIN
      lastpos := depth + token.length;
      IF nocr THEN
        nocr := FALSE
      ELSE
        WrLn (destination);
        ColNum := 0;
        SetCol (destination,depth);
        lastsymbol := notallowed
      END
    END crlf;

    PROCEDURE blankline (depth : CARDINAL);

    BEGIN
      WrLn (destination);
      ColNum := 0;
      crlf (depth);
    END blankline;

    PROCEDURE store (VAR token : TokenTyp);

    VAR len : CARDINAL;

    BEGIN
      WITH token DO
        len := length;
        IF (len + ColNum > maxwidth) & (symbol # semicolon) & (symbol # comma
           ) THEN
          WrLn (destination);
          ColNum := 0;
          lastsymbol := notallowed;
          IF len + lastpos >= maxwidth THEN
            IF len <= maxwidth THEN
              SetCol (destination,maxwidth - len)
            END
          ELSE
            SetCol (destination,lastpos + 1)
          END
        END;
        IF ((lastsymbol < alias) OR (lastsymbol IN termset {alias,colon,equal,
           define,operationsy,less,lesseq,gr,greq,notequal,rbk,rpar,rbr,bar,
           drefsy,shiftl,shiftr})) & (symbol IN BlankBefore) THEN
          WrChar (destination,' ');
          INC (ColNum);
        END;
        WrStr (destination,value);
        INC (ColNum,length);
        lastsymbol := symbol
      END
    END store;

    PROCEDURE getsym (VAR token : TokenTyp);

      PROCEDURE getcomment;

      VAR ch : CHAR;
          posi : CARDINAL;
          commentdepth : CARDINAL;

        PROCEDURE writestr (msg : ARRAY OF CHAR);

        BEGIN
          IF Comments THEN
            WrStr (destination,msg)
          END
        END writestr;

        PROCEDURE writech (ch : CHAR);

        BEGIN
          IF Comments THEN
            WrChar (destination,ch);
          END
        END writech;

      BEGIN
        commentdepth := 1;
        posi := ColNum;
        IF token.value [0] # CHR (13) THEN
          writech (' ')
        END;
        writestr (token.value);
        REPEAT
          ReadChar (source,ch);
          writech (ch);
          IF ch = '*' THEN
            ReadChar (source,ch);
            IF ch = ')' THEN
              DEC (commentdepth);
              writech (ch)
            ELSE
              ReadAgain
            END
          ELSIF ch = '(' THEN
            ReadChar (source,ch);
            IF ch = '*' THEN
              INC (commentdepth);
              writech (ch)
            ELSE
              ReadAgain
            END
          END
        UNTIL (commentdepth = 0) OR EOF;
        IF EOF THEN
          errorhandler ('Unexpected End of Source!')
        END;
        lastsymbol := closecom;
        token.symbol := notallowed
      END getcomment;

    BEGIN
      IF token.symbol # notallowed THEN
        store (token)
      END;
      GetToken (source,token);
      WITH token DO
        CASE symbol OF
        | notallowed : errorhandler ('Unexpected Token found!')
        | identifier : SearchInHashTable (token);
        | opencom : getcomment;
                    getsym (token)
        END
      END
    END getsym;

    PROCEDURE program;

      PROCEDURE skipto (terminators : termset);

      BEGIN
        WHILE NOT (token.symbol IN terminators) DO
          getsym (token)
        END
      END skipto;

      PROCEDURE skipover (symbol : SymbolTyp);

      BEGIN
        WHILE token.symbol # symbol DO
          getsym (token)
        END;
        getsym (token)
      END skipover;

      PROCEDURE proceduredeclaration (depth : CARDINAL;
                                      isinline : BOOLEAN;
                                      inclass : BOOLEAN); FORWARD;

      PROCEDURE moduledeclaration (depth : CARDINAL); FORWARD;

      PROCEDURE block (depth : CARDINAL);

        PROCEDURE multiplechoice (depth : CARDINAL); FORWARD;

        PROCEDURE statementsequence (depth : CARDINAL);

          PROCEDURE statement (depth : CARDINAL);

          BEGIN
            WITH token DO
              CASE symbol OF
              | ifsy : crlf (depth);
                       skipover (thensy);
                       statementsequence (depth + shift);
                       WHILE symbol = elsifsy DO
                         crlf (depth);
                         skipover (thensy);
                         statementsequence (depth + shift)
                       END;
                       IF symbol = elsesy THEN
                         crlf (depth);
                         getsym (token);
                         statementsequence (depth + shift)
                       END;
                       crlf (depth);
                       getsym (token)
              | casesy : crlf (depth);
                         skipover (ofsy);
                         multiplechoice (depth);
                         crlf (depth);
                         getsym (token);
              | forsy,withsy,whilesy : crlf (depth);
                                       skipover (dosy);
                                       statementsequence (depth + shift);
                                       crlf (depth);
                                       getsym (token)
              | loopsy : crlf (depth);
                         getsym (token);
                         statementsequence (depth + shift);
                         crlf (depth);
                         getsym (token)
              | repeatsy : crlf (depth);
                           WHILE symbol # untilsy DO
                             getsym (token);
                             statement (depth + shift);
                           END;
                           crlf (depth);
                           getsym (token);
                           skipto (terminators)
              ELSE
                IF NOT (symbol IN terminators) THEN
                  crlf (depth);
                  getsym (token);
                  IF token.symbol = colon THEN
                    getsym (token);
                    statement (depth)
                  ELSE
                    skipto (terminators)
                  END
                ELSE
                  nocr := FALSE
                END
              END
            END
          END statement;

        BEGIN
          statement (depth);
          WHILE token.symbol = semicolon DO
            getsym (token);
            statement (depth)
          END
        END statementsequence;

        PROCEDURE multiplechoice (depth : CARDINAL);

        BEGIN
          WITH token DO
            IF (symbol # elsesy) & (symbol # endsy) THEN
              IF symbol = bar THEN
                crlf (depth)
              ELSE
                crlf (depth + shift)
              END;
              skipover (colon);
              IF symbol # bar THEN
                nocr := TRUE;
                statementsequence (ColNum + 1)
              END;
              WHILE symbol = bar DO
                crlf (depth);
                skipover (colon);
                IF (symbol # bar) & (symbol # elsesy) THEN
                  nocr := TRUE;
                  statementsequence (ColNum + 1)
                END
              END
            END;
            IF symbol = elsesy THEN
              crlf (depth);
              getsym (token);
              statementsequence (depth + shift)
            END
          END
        END multiplechoice;

        PROCEDURE anytype (depth : CARDINAL);

        VAR posi : CARDINAL;

          PROCEDURE fieldlistsequence (depth : CARDINAL);

            PROCEDURE fieldlist (depth : CARDINAL);

              PROCEDURE variant;

              BEGIN
                WITH token DO
                  IF (symbol # elsesy) & (symbol # endsy) THEN
                    skipover (colon);
                    lastpos := ColNum;
                    fieldlistsequence (lastpos + 1)
                  END;
                  IF symbol = semicolon THEN
                    getsym (token)
                  END
                END
              END variant;

            BEGIN
              WITH token DO
                CASE symbol OF
                | identifier : skipover (colon);
                               anytype (depth);
                | procsy : proceduredeclaration (depth,FALSE,TRUE);
                | casesy : skipover (ofsy);
                           IF symbol = bar THEN
                             crlf (depth);
                             getsym (token)
                           ELSE
                             crlf (depth + shift)
                           END;
                           variant;
                           WHILE symbol = bar DO
                             crlf (depth);
                             getsym (token);
                             variant;
                           END;
                           IF symbol = elsesy THEN
                             crlf (depth);
                             getsym (token);
                             fieldlist (depth + shift)
                           END;
                           crlf (depth);
                           getsym (token)
                END
              END
            END fieldlist;

          BEGIN
            WITH token DO
              fieldlist (depth);
              WHILE symbol IN termset {semicolon,procsy} DO
                IF symbol = semicolon THEN
                  getsym (token)
                END;
                IF symbol # endsy THEN
                  IF NOT (symbol IN termset {bar,elsesy,procsy}) THEN
                    crlf (depth)
                  END;
                  fieldlist (depth)
                END
              END
            END
          END fieldlistsequence;

          PROCEDURE simpletype;

          BEGIN
            WITH token DO
              IF symbol = lpar THEN
                lastpos := ColNum + 1;
                skipover (rpar)
              ELSIF symbol = lbk THEN
                lastpos := ColNum + 1;
                skipover (rbk)
              ELSE
                getsym (token);
                IF symbol = period THEN
                  getsym (token);
                  getsym (token)
                ELSIF symbol = lbk THEN
                  lastpos := ColNum + 1;
                  skipover (rbk)
                END
              END
            END
          END simpletype;

        BEGIN
          WITH token DO
            CASE symbol OF
            | pointersy : skipover (tosy);
                          anytype (depth)
            | arraysy : getsym (token);
                        simpletype;
                        WHILE symbol = comma DO
                          getsym (token);
                          simpletype
                        END;
                        getsym (token);
                        lastpos := ColNum;
                        anytype (lastpos + 1)
            | setsy : getsym (token);
                      getsym (token);
                      simpletype
            | procsy : skipover (rpar);
                       skipto (termset {semicolon})
            | recordsy : posi := ColNum + 1;
                         getsym (token);
                         crlf (posi + shift);
                         fieldlistsequence (posi + shift);
                         crlf (posi);
                         getsym (token)
            | classsy : posi := ColNum + 1;
                        getsym (token);
                        IF token.symbol = lpar THEN
                          skipover (rpar)
                        END;
                        crlf (posi + shift);
                        fieldlistsequence (posi + shift);
                        crlf (posi);
                        getsym (token)
            ELSE
              simpletype
            END
          END
        END anytype;

        PROCEDURE typedeclaration (depth : CARDINAL);

        VAR posi : CARDINAL;

        BEGIN
          blankline (depth);
          getsym (token);
          lastpos := ColNum;
          posi := lastpos + 1;
          WITH token DO
            WHILE symbol = identifier DO
              getsym (token);
              IF symbol # semicolon THEN
                getsym (token);
                anytype (posi)
              ELSIF NOT defmodule THEN
                errorhandler ('TYPE Identifier expected!')
              END;
              getsym (token);
              IF symbol = identifier THEN
                crlf (posi)
              END
            END
          END
        END typedeclaration;

        PROCEDURE constdeclaration (depth : CARDINAL);

        VAR posi : CARDINAL;

        BEGIN
          blankline (depth);
          getsym (token);
          posi := ColNum + 1;
          WITH token DO
            WHILE symbol = identifier DO
              getsym (token);
              getsym (token);
              lastpos := ColNum;
              skipover (semicolon);
              IF symbol = identifier THEN
                crlf (posi)
              END
            END
          END
        END constdeclaration;

        PROCEDURE variabledeclaration (depth : CARDINAL);

        VAR posi : CARDINAL;

        BEGIN
          blankline (depth);
          getsym (token);
          lastpos := ColNum;
          posi := lastpos + 1;
          WITH token DO
            WHILE symbol = identifier DO
              getsym (token);
              IF symbol = lbk THEN
                skipover (rbk)
              END;
              WHILE symbol = comma DO
                getsym (token);
                getsym (token)
              END;
              getsym (token);
              anytype (posi);
              getsym (token);
              IF symbol = identifier THEN
                crlf (posi)
              END
            END
          END
        END variabledeclaration;

        PROCEDURE labellist (depth : CARDINAL);

        VAR posi : CARDINAL;

        BEGIN
          blankline (depth);
          getsym (token);
          lastpos := ColNum;
          posi := lastpos + 1;
          WITH token DO
            WHILE symbol = identifier DO
              getsym (token);
              WHILE symbol = comma DO
                getsym (token);
                getsym (token)
              END
            END
          END;
          getsym (token)
        END labellist;

      BEGIN
        WITH token DO
          WHILE (symbol # beginsy) & (symbol # endsy) DO
            CASE symbol OF
            | typesy : typedeclaration (depth)
            | constsy : constdeclaration (depth)
            | varsy : variabledeclaration (depth)
            | labelsy : labellist (depth)
            | inlinesy : IF defmodule THEN
                           proceduredeclaration (depth + shift,TRUE,FALSE)
                         ELSE
                           errorhandler ('INLINE Symbol recognized!')
                         END
            | procsy : proceduredeclaration (depth + shift,FALSE,FALSE)
            | modulesy : moduledeclaration (depth + shift)
            ELSE
              errorhandler ('Error In Block')
            END
          END;
          blankline (depth);
          IF symbol = beginsy THEN
            getsym (token);
            statementsequence (depth + shift);
            crlf (depth)
          END;
          getsym (token);
          getsym (token);
        END
      END block;

      PROCEDURE moduledeclaration (depth : CARDINAL);

      VAR help : TokenTyp;

        PROCEDURE importdeclaration (depth : CARDINAL);

        BEGIN
          WITH token DO
            IF symbol = fromsy THEN
              blankline (depth);
              getsym (token);
              getsym (token);
              getsym (token);
              lastpos := ColNum;
              WHILE token.symbol # semicolon DO
                getsym (token)
              END;
              getsym (token)
            ELSIF symbol = importsy THEN
              blankline (depth);
              getsym (token);
              lastpos := ColNum;
              LOOP
                getsym (token);
                IF symbol = semicolon THEN
                  EXIT
                END;
                getsym (token)
              END;
              getsym (token)
            ELSIF symbol = exportsy THEN
              blankline (depth);
              getsym (token);
              lastpos := ColNum;
              LOOP
                getsym (token);
                IF symbol = semicolon THEN
                  EXIT
                END;
                getsym (token)
              END;
              getsym (token)
            END
          END
        END importdeclaration;

      BEGIN
        WITH token DO
          IF depth > 0 THEN
            blankline (depth)
          END;
          skipover (semicolon);
          WHILE symbol IN termset {fromsy,importsy,exportsy} DO
            importdeclaration (depth)
          END;
          block (depth);
          IF symbol = semicolon THEN
            getsym (token)
          END
        END
      END moduledeclaration;

      PROCEDURE proceduredeclaration (depth : CARDINAL;
                                      isinline : BOOLEAN;
                                      inclass : BOOLEAN);

        PROCEDURE varlist;

        VAR posi : CARDINAL;

        BEGIN
          WITH token DO
            IF symbol = lpar THEN
              lastpos := ColNum + 1;
              posi := lastpos + 1;
              REPEAT
                getsym (token);
                IF symbol = semicolon THEN
                  getsym (token);
                  crlf (posi);
                END
              UNTIL symbol = rpar;
              getsym (token)
            END;
            IF symbol = colon THEN
              getsym (token);
              getsym (token)
            END
          END
        END varlist;

      BEGIN
        IF inclass & defmodule THEN
          crlf (depth)
        ELSE
          blankline (depth)
        END;
        IF isinline THEN
          getsym (token)
        END;
        getsym (token);
        getsym (token);
        varlist;
        WITH token DO
          IF symbol = semicolon THEN
            getsym (token);
            IF inclass THEN
              IF symbol = virtualsy THEN
                WrChar (destination,' ');
                getsym (token);
                IF NOT defmodule THEN
                  getsym (token)
                END
              END
            END;
            IF symbol = forwardsy THEN
              WrChar (destination,' ');
              getsym (token)
            ELSIF symbol = insy THEN
              WrChar (destination,' ');
              skipto (termset {semicolon})
            ELSIF NOT defmodule THEN
              block (depth);
            END
          ELSIF symbol = equal THEN
            lastpos := ColNum + 1;
            skipto (termset {semicolon})
          END
        END;
        IF NOT defmodule THEN
          getsym (token)
        END
      END proceduredeclaration;

    BEGIN (* program *)
      WITH token DO
        symbol := notallowed;
        lastsymbol := notallowed;
        getsym (token);
        nocr := FALSE;
        WrLn (destination);
        ColNum := 0;
        IF (symbol = implsy) OR (symbol = defsy) THEN
          defmodule := symbol = defsy;
          getsym (token)
        ELSE
          defmodule := FALSE;
        END
      END;
      moduledeclaration (0);
      store (token);
    END program;

  BEGIN
    InitScanner;
    IOcheck := FALSE;
    source := OpenRead (sourcename);
    IF IOresult () # 0 THEN
      errorhandler ("Can't open Source!")
    END;
    AssignBuffer (source,ReadBuffer);
    IF Compare (destname,'PRN') # 0 THEN
(*%F Test*)
      Copy (writename,destname);
      ChangeExtension (writename,'$$$');
      destination := Create (writename);
      IF IOresult () # 0 THEN
        errorhandler ("Can't create Destination-File!")
      END;
      AssignBuffer (destination,WriteBuffer);
(*%E*)
(*%T Test*)
      destination := StandardOutput
(*%E*)
    ELSE
      destination := PrinterDevice;
    END;
    program;
    closefiles (FALSE);
  END MakePretty;

END PRPARSER.