CocoR/ListHandler.mod

  MODULE ListHandler;
  (* ------------------- Source Listing and Error handler -------------- *)
  IMPORT FIO, Storage, SYSTEM;
  IMPORT CharAt, ATGFileName, IDE, errors, INT32;
  
  TYPE
    Err = POINTER TO ErrDesc;
    ErrDesc = RECORD
      nr, line, col: INTEGER;
      next: Err
    END;

  CONST
    tab = 11C;

  VAR
    firstErr, lastErr: Err;
    Extra: INTEGER;

  PROCEDURE StoreError (nr, line, col: INTEGER; pos: INT32);
  (* Store an error message for later printing *)
    VAR
      nextErr: Err;
    BEGIN
      (*Storage.ALLOCATE(nextErr, SYSTEM.TSIZE(ErrDesc));*)
      nextErr^.nr := nr; nextErr^.line := line; nextErr^.col := col;
      nextErr^.next := NIL;
      IF firstErr = NIL
        THEN firstErr := nextErr
        ELSE lastErr^.next := nextErr
      END;
      lastErr := nextErr;
      INC(errors)
    END StoreError;

  PROCEDURE GetLine (VAR pos: INT32;
                     VAR line: ARRAY OF CHAR;
                     VAR eof: BOOLEAN);
  (* Read a source line. Return empty line if eof *)
    VAR
      ch: CHAR;
      i:  CARDINAL;
    BEGIN
     (* i := 0; eof := FALSE; ch := CharAt(pos); INC(pos);
      WHILE (ch # CR) & (ch # LF) & (ch # EOF) DO
        line[i] := ch; INC(i); ch := CharAt(pos); INC(pos);
      END;
      eof := (i = 0) & (ch = EOF); line[i] := 0C;
      IF ch = CR THEN (* check for MsDos *)
        ch := CharAt(pos);
        IF ch = LF THEN INC(pos); Extra := 0 END
      END*)
    END GetLine;

  PROCEDURE PrintErr (line: ARRAY OF CHAR; nr, col: INTEGER);
  (* Print an error message *)

    PROCEDURE Msg (s: ARRAY OF CHAR);
      BEGIN
        FIO.WriteString(FIO.File, s)
      END Msg;

    PROCEDURE Pointer;
      VAR
        i: INTEGER;
      BEGIN
        FIO.WriteString(FIO.File, "*****  ");
        i := 0;
        WHILE i < col + Extra - 2 DO
          IF line[i] = tab
            THEN FIO.Write(FIO.File, tab)
            ELSE FIO.Write(FIO.File, ' ')
          END;
          INC(i)
        END;
        FIO.WriteString(FIO.File, "^ ")
      END Pointer;

    BEGIN
      IF ~ IDE THEN Pointer END;
      CASE nr OF
         0: Msg("EOF expected")
      |  1: Msg("ident expected")
      |  2: Msg("string expected")
      |  3: Msg("badstring expected")
      |  4: Msg("number expected")
      |  5: Msg("'COMPILER' expected")
      |  6: Msg("'PRODUCTIONS' expected")
      |  7: Msg("'=' expected")
      |  8: Msg("'.' expected")
      |  9: Msg("'END' expected")
      | 10: Msg("'CHARACTERS' expected")
      | 11: Msg("'TOKENS' expected")
      | 12: Msg("'NAMES' expected")
      | 13: Msg("'PRAGMAS' expected")
      | 14: Msg("'COMMENTS' expected")
      | 15: Msg("'FROM' expected")
      | 16: Msg("'TO' expected")
      | 17: Msg("'NESTED' expected")
      | 18: Msg("'IGNORE' expected")
      | 19: Msg("'CASE' expected")
      | 20: Msg("'+' expected")
      | 21: Msg("'-' expected")
      | 22: Msg("'..' expected")
      | 23: Msg("'ANY' expected")
      | 24: Msg("'CHR' expected")
      | 25: Msg("'(' expected")
      | 26: Msg("')' expected")
      | 27: Msg("'|' expected")
      | 28: Msg("'WEAK' expected")
      | 29: Msg("'[' expected")
      | 30: Msg("']' expected")
      | 31: Msg("'{' expected")
      | 32: Msg("'}' expected")
      | 33: Msg("'SYNC' expected")
      | 34: Msg("'CONTEXT' expected")
      | 35: Msg("'<' expected")
      | 36: Msg("'>' expected")
      | 37: Msg("'<.' expected")
      | 38: Msg("'.>' expected")
      | 39: Msg("'(.' expected")
      | 40: Msg("'.)' expected")
      | 41: Msg("not expected")
      | 42: Msg("invalid TokenFactor")
      | 43: Msg("invalid Factor")
      | 44: Msg("invalid Factor")
      | 45: Msg("invalid Term")
      | 46: Msg("invalid Symbol")
      | 47: Msg("invalid SingleChar")
      | 48: Msg("invalid SimSet")
      | 49: Msg("invalid NameDecl")
      | 50: Msg("this symbol not expected in TokenDecl")
      | 51: Msg("invalid TokenDecl")
      | 52: Msg("invalid Attribs")
      | 53: Msg("invalid Declaration")
      | 54: Msg("invalid Declaration")
      | 55: Msg("invalid Declaration")
      | 56: Msg("this symbol not expected in CR")
      | 57: Msg("invalid CR")
      
      | 101: Msg("character set may not be empty")
      | 102: Msg("string literal may not extend over line end")
      | 103: Msg("a literal must not have attributes")
      | 104: Msg("this symbol kind not allowed in production")
      | 105: Msg("attribute mismatch between declaration and use")
      | 106: Msg("undefined string in production")
      | 107: Msg("name declared twice")
      | 108: Msg("this type not allowed on left side of production")
      | 109: Msg("earlier semantic action was not terminated")
      | 111: Msg("no production found for grammar name")
      | 112: Msg("grammar symbol must not have attributes")
      | 113: Msg("a literal must not be declared with a structure")
      | 114: Msg("semantic action not allowed here")
      | 115: Msg("undefined name")
      | 116: Msg("attributes not allowed in token declaration")
      | 117: Msg("name does not match grammar name")
      | 118: Msg("unacceptable constant value")
      | 119: Msg("may not ignore CHR(0)")
      | 120: Msg("token might be empty")
      | 121: Msg("token must not start with an iteration")
      | 122: Msg("comment delimiters may not be structured")
      | 123: Msg("only terminals may be weak")
      | 124: Msg("literal tokens may not contain white space")
      | 125: Msg("comment delimiter must be 1 or 2 characters long")
      | 126: Msg("character set contains more than one character")
      | 127: Msg("could not make deterministic automaton")
      | 128: Msg("semantic action text too long - please split it")
      | 129: Msg("literal tokens may not be empty")
      | 130: Msg("IGNORE CASE must appear earlier")
      ELSE Msg("Error: "); FIO.WriteInt(FIO.File, nr, 1);
      END;
      FIO.WriteLn(FIO.File)
    END PrintErr;

  PROCEDURE PrintListing;
  (* Print a source listing with error messages *)
    VAR
      nextErr:   Err;
      eof:       BOOLEAN;
      lnr, errC: INTEGER;
      srcPos:    INT32;
      line:      ARRAY [0 .. 255] OF CHAR;
    BEGIN
      IF ~ IDE THEN
        FIO.WriteString(FIO.File, "Listing:");
        FIO.WriteLn(FIO.File); FIO.WriteLn(FIO.File);
      END;
      srcPos := 0; nextErr := firstErr;
      GetLine(srcPos, line, eof); lnr := 1; errC := 0;
      WHILE ~ eof DO
        IF ~ IDE THEN
          FIO.WriteInt(FIO.File, lnr, 5); FIO.WriteString(FIO.File, "  ");
          FIO.WriteString(FIO.File, line); FIO.WriteLn(FIO.File)
        END;
        WHILE (nextErr # NIL) & (nextErr^.line = lnr) DO
          IF IDE THEN
            FIO.WriteString(FIO.File, ATGFileName);
            FIO.WriteString(FIO.File, " (");
            FIO.WriteCard(FIO.File, lnr, 1);
            FIO.WriteString(FIO.File, ",");
            FIO.WriteCard(FIO.File, nextErr^.col-1, 0);
            FIO.WriteString(FIO.File, ") ")
          END;
          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
          nextErr := nextErr^.next
        END;
        GetLine(srcPos, line, eof); INC(lnr);
      END;
      IF nextErr # NIL THEN
        IF ~ IDE THEN FIO.WriteInt(FIO.File, lnr, 5); FIO.WriteLn(FIO.File) END;
        WHILE nextErr # NIL DO
          IF IDE THEN
            FIO.WriteString(FIO.File, ATGFileName);
            FIO.WriteString(FIO.File, " (");
            FIO.WriteCard(FIO.File, lnr, 1);
            FIO.WriteString(FIO.File, ",");
            FIO.WriteCard(FIO.File, nextErr^.col-1, 0);
            FIO.WriteString(FIO.File, ") ")
          END;
          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
          nextErr := nextErr^.next
        END
      END;
      IF ~ IDE AND (errC > 0) THEN
        FIO.WriteLn(FIO.File);
        FIO.WriteInt(FIO.File, errC, 5); FIO.WriteString(FIO.File, " error");
        IF errC # 1 THEN FIO.Write(FIO.File, "s") END;
        FIO.WriteLn(FIO.File); FIO.WriteLn(FIO.File); FIO.WriteLn(FIO.File);
      END
    END PrintListing;

  BEGIN
    firstErr := NIL; Extra := 1;
  END ListHandler.