Wirth-AT-grammars/TopSpeedV3-grammar/build/M2.mod

MODULE M2;
(* This is an example of a rudimentary main module for use with COCO/R.
   It assumes the FileIO/Storage I/O libraries (as supplied with this
   project) are available.
   The auxiliary modules <Grammar>S (scanner) and <Grammar>P (parser)
   are assumed to have been constructed with COCO/R compiler generator. *)

  FROM M2S IMPORT lst, src, errors, Error, CharAt;
  FROM M2P IMPORT Parse, Successful;
  IMPORT
    Strings, Storage, SYSTEM, FileIO, SymTab, QbeGen;
    (* and any others needed *)

  TYPE
    INT32 = FileIO.INT32 (* 32 bit integers needed *);

  MODULE ListHandler;
  (* ------------------- Source Listing and Error handler -------------- *)
    FROM FileIO IMPORT CR, LF, EOF, File, StdOut,
      WriteString, Write, WriteLn, WriteInt, Long0;
    FROM Storage IMPORT ALLOCATE;
    FROM SYSTEM IMPORT TSIZE;
    IMPORT lst, CharAt, errors, INT32;
    EXPORT StoreError, PrintListing, PrintConsoleErrors, ResetErrors;

    TYPE
      Err = POINTER TO ErrDesc;
      ErrDesc = RECORD
        nr, line, col: INTEGER;
        next: Err
      END;

    CONST
      tab = CHR(9);

    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
        ALLOCATE(nextErr, 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) AND (ch # LF) AND (ch # EOF) DO
          line[i] := ch; INC(i); ch := CharAt(pos); INC(pos);
        END;
        eof := (i = 0) AND (ch = EOF); line[i] := CHR(0);
        IF ch = CR THEN (* check for MsDos *)
          ch := CharAt(pos);
          IF ch = LF THEN INC(pos); Extra := 0 END
        END
      END GetLine;

    PROCEDURE ErrText (nr: INTEGER; f: File);
    (* Error message text for nr on file f (listing and console share it) *)

      PROCEDURE Msg (s: ARRAY OF CHAR);
        BEGIN
          WriteString(f, s)
        END Msg;

      BEGIN
        CASE nr OF
           0: Msg("EOF expected")
        |  1: Msg("ident expected")
        |  2: Msg("integer expected")
        |  3: Msg("real expected")
        |  4: Msg("string expected")
        |  5: Msg("'.' expected")
        |  6: Msg("'DEFINITION' expected")
        |  7: Msg("'MODULE' expected")
        |  8: Msg("';' expected")
        |  9: Msg("'END' expected")
        | 10: Msg("'IMPLEMENTATION' expected")
        | 11: Msg("'BEGIN' expected")
        | 12: Msg("'INLINE' expected")
        | 13: Msg("'LABEL' expected")
        | 14: Msg("',' expected")
        | 15: Msg("'[' expected")
        | 16: Msg("']' expected")
        | 17: Msg("'EXPORT' expected")
        | 18: Msg("'QUALIFIED' expected")
        | 19: Msg("'FROM' expected")
        | 20: Msg("'IMPORT' expected")
        | 21: Msg("'TYPE' expected")
        | 22: Msg("'=' expected")
        | 23: Msg("'VIRTUAL' expected")
        | 24: Msg("'POINTER' expected")
        | 25: Msg("'..' expected")
        | 26: Msg("'(' expected")
        | 27: Msg("')' expected")
        | 28: Msg("'ARRAY' expected")
        | 29: Msg("'OF' expected")
        | 30: Msg("'RECORD' expected")
        | 31: Msg("'CASE' expected")
        | 32: Msg("':' expected")
        | 33: Msg("'|' expected")
        | 34: Msg("'ELSE' expected")
        | 35: Msg("'SET' expected")
        | 36: Msg("'TO' expected")
        | 37: Msg("'PROCEDURE' expected")
        | 38: Msg("'VAR' expected")
        | 39: Msg("'CLASS' expected")
        | 40: Msg("'FORWARD' expected")
        | 41: Msg("'CONST' expected")
        | 42: Msg("'::=' expected")
        | 43: Msg("'IN' expected")
        | 44: Msg("'GOTO' expected")
        | 45: Msg("'EXIT' expected")
        | 46: Msg("':=' expected")
        | 47: Msg("'IF' expected")
        | 48: Msg("'THEN' expected")
        | 49: Msg("'ELSIF' expected")
        | 50: Msg("'WHILE' expected")
        | 51: Msg("'DO' expected")
        | 52: Msg("'REPEAT' expected")
        | 53: Msg("'UNTIL' expected")
        | 54: Msg("'LOOP' expected")
        | 55: Msg("'FOR' expected")
        | 56: Msg("'BY' expected")
        | 57: Msg("'RETURN' expected")
        | 58: Msg("'WITH' expected")
        | 59: Msg("'^' expected")
        | 60: Msg("'IS' expected")
        | 61: Msg("'#' expected")
        | 62: Msg("'<>' expected")
        | 63: Msg("'<' expected")
        | 64: Msg("'<=' expected")
        | 65: Msg("'>' expected")
        | 66: Msg("'>=' expected")
        | 67: Msg("'+' expected")
        | 68: Msg("'-' expected")
        | 69: Msg("'OR' expected")
        | 70: Msg("'*' expected")
        | 71: Msg("'/' expected")
        | 72: Msg("'DIV' expected")
        | 73: Msg("'MOD' expected")
        | 74: Msg("'AND' expected")
        | 75: Msg("'&' expected")
        | 76: Msg("'<<' expected")
        | 77: Msg("'>>' expected")
        | 78: Msg("'{' expected")
        | 79: Msg("'}' expected")
        | 80: Msg("'NOT' expected")
        | 81: Msg("'~' expected")
        | 82: Msg("not expected")
        | 83: Msg("invalid MulOp")
        | 84: Msg("invalid Fact")
        | 85: Msg("invalid AddOp")
        | 86: Msg("invalid Rel")
        | 87: Msg("invalid DesignStat")
        | 88: Msg("invalid Statement")
        | 89: Msg("invalid MethodImpl")
        | 90: Msg("invalid ClassField")
        | 91: Msg("invalid ClassRest")
        | 92: Msg("invalid FieldList")
        | 93: Msg("invalid FieldList")
        | 94: Msg("invalid SetType")
        | 95: Msg("invalid ArrayType")
        | 96: Msg("invalid Type")
        | 97: Msg("invalid TypeItem")
        | 98: Msg("invalid ProcDecl")
        | 99: Msg("invalid ProcDecl")
        |100: Msg("invalid ClassItem")
        |101: Msg("invalid ConstDecl")
        |102: Msg("invalid Import")
        |103: Msg("invalid Unit")
        
        (* add customized cases here *)
        | 200: Msg("duplicate identifier")
        | 201: Msg("undeclared identifier")
        | 202: Msg("module name mismatch")
        | 210: Msg("incompatible assignment")
        | 211: Msg("arithmetic operand must be numeric")
        | 212: Msg("boolean operand required")
        | 213: Msg("incompatible comparison")
        | 214: Msg("BOOLEAN condition required")
        | 215: Msg("not a RECORD type")
        | 216: Msg("unknown field")
        | 217: Msg("not an ARRAY type")
        | 218: Msg("array index must be integer")
        | 219: Msg("not a POINTER type")
        | 220: Msg("FOR needs integer variable and bounds")
        | 221: Msg("not a type name")
        | 222: Msg("set operand mismatch")
        | 223: Msg("cyclical type definition")
        | 224: Msg("ordinal type required")
        | 230: Msg("not supported yet")
        | 231: Msg("opaque type outside definition")
        | 232: Msg("bad RETURN")
        | 233: Msg("invalid call")
        | 234: Msg("invalid UTF-8 in U-literal")
        | 235: Msg("implementation does not match definition")
        | 236: Msg("bad variant record")
        ELSE         Msg("Error: "); WriteInt(f, nr, 0);
        END
      END ErrText;

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

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

      BEGIN
        Pointer;
        ErrText(nr, lst);
        WriteLn(lst)
      END PrintErr;

    PROCEDURE PrintListing;
    (* Print a source listing with error messages *)
      VAR
        nextErr: Err;
        eof, done: BOOLEAN;
        lnr, errC: INTEGER;
        srcPos: INT32;
        line: ARRAY [0 .. 255] OF CHAR;
      BEGIN
        WriteString(lst, "Listing:");
        WriteLn(lst); WriteLn(lst);
        srcPos := 0; nextErr := firstErr;
        GetLine(srcPos, line, eof); lnr := 1; errC := 0;
        WHILE NOT eof DO
          WriteInt(lst, lnr, 5); WriteString(lst, "  ");
          WriteString(lst, line); WriteLn(lst);
          done := FALSE;
          WHILE (nextErr # NIL) AND NOT done DO
            IF nextErr^.line = lnr THEN
              PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
              nextErr := nextErr^.next
            ELSE done := TRUE
            END
          END;
          GetLine(srcPos, line, eof); INC(lnr);
        END;
        IF nextErr # NIL THEN
          WriteInt(lst, lnr, 5); WriteLn(lst);
          WHILE nextErr # NIL DO
            PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
            nextErr := nextErr^.next
          END
        END;
        WriteLn(lst);
        WriteInt(lst, errC, 5); WriteString(lst, " error");
        IF errC # 1 THEN Write(lst, 's') END;
        WriteLn(lst); WriteLn(lst); WriteLn(lst);
      END PrintListing;

    PROCEDURE PrintConsoleErrors (fname: ARRAY OF CHAR);
    (* "file:line:col: message" errors on StdOut, for editor
       integration. Columns are 1-based token starts, matching the
       listing carets (NOT the col-1 of CRQ.FRM). *)

      PROCEDURE WriteNum (n: INTEGER);
      (* FileIO.WriteInt pads a leading blank; editors want none. *)
        VAR
          buf: ARRAY [0 .. 15] OF CHAR;
          i: CARDINAL;
        BEGIN
          IF n < 0 THEN Write(StdOut, "-"); n := -n END;
          i := 0;
          IF n = 0 THEN buf[0] := "0"; i := 1 END;
          WHILE (n > 0) AND (i <= HIGH(buf)) DO
            buf[i] := CHR(ORD("0") + VAL(CARDINAL, n MOD 10));
            n := n DIV 10; INC(i)
          END;
          WHILE i > 0 DO DEC(i); Write(StdOut, buf[i]) END
        END WriteNum;

      VAR
        e: Err;
      BEGIN
        e := firstErr;
        WHILE e # NIL DO
          WriteString(StdOut, fname);
          Write(StdOut, ":");
          WriteNum(e^.line);
          Write(StdOut, ":");
          WriteNum(e^.col);
          WriteString(StdOut, ": ");
          ErrText(e^.nr, StdOut);
          WriteLn(StdOut);
          e := e^.next
        END
      END PrintConsoleErrors;

    PROCEDURE ResetErrors;
    (* Fresh error list per source file in a session. *)
      BEGIN
        firstErr := NIL
      END ResetErrors;

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

  (* --------------------------- main module ------------------------------- *)

  PROCEDURE ChangeExtension (oldName, Ext: ARRAY OF CHAR;
                             VAR newName: ARRAY OF CHAR);
  (* Constructs newName as complete file name by appending ext to oldName
     Examples: (assume ext = "EXT")
           old.any ==> old.EXT
           old     ==> old.EXT
     This is not a file renaming facility, merely a string manipulation
     routine. *)
    VAR
      i, l: CARDINAL;
    BEGIN
      Strings.Assign(oldName, newName);
      i := LENGTH(oldName); l := i;
      WHILE (i > 0) AND (oldName[i -1] # '.')
 AND (oldName[i -1] # '\') AND (oldName[i -1] # '/') DO
        DEC(i)
      END;
      IF (i > 0) AND (oldName[i-1] = '.') THEN
        Strings.Delete(newName, i - 1, l + 1 - i)
      END;
      IF Ext[0] = '.' THEN Strings.Delete(Ext, 0, 1) END;
      Strings.Append(".", newName);
      Strings.Append(Ext, newName)
    END ChangeExtension;

  PROCEDURE BaseName (path: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
  (* Basename of a path without its extension (program image name). *)
    VAR
      i, j, k: CARDINAL;
    BEGIN
      i := 0; j := 0;
      WHILE (i <= HIGH(path)) AND (path[i] # CHR(0)) DO
        IF (path[i] = '/') OR (path[i] = '\') THEN j := i + 1 END;
        INC(i)
      END;
      k := j;
      WHILE (k < i) AND (path[k] # '.') DO INC(k) END;
      i := 0;
      WHILE j < k DO name[i] := path[j]; INC(i); INC(j) END;
      name[i] := CHR(0)
    END BaseName;

  VAR
    sourceName, listName, progName: ARRAY [0 .. 255] OF CHAR;
    files: ARRAY [0 .. 31] OF ARRAY [0 .. 255] OF CHAR;
    nFiles: CARDINAL;
    f: CARDINAL;
    bad: BOOLEAN;

  BEGIN
    (* collect the session's source files (program module last) *)
    nFiles := 0;
    LOOP
      FileIO.NextParameter(sourceName);
      IF (sourceName[0] = CHR(0)) OR (nFiles > HIGH(files)) THEN EXIT END;
      Strings.Assign(sourceName, files[nFiles]);
      INC(nFiles)
    END;
    IF nFiles = 0 THEN
      FileIO.WriteString(FileIO.StdOut, "No input file specified");
      HALT
    END;

    BaseName(files[nFiles - 1], progName);
    SymTab.Init;
    QbeGen.OpenModule(progName);
    Error := StoreError;

    (* parse each unit into the shared session *)
    bad := FALSE; f := 0;
    WHILE f < nFiles DO
      Strings.Assign(files[f], sourceName);
      FileIO.Open(src, sourceName, FALSE);
      IF NOT FileIO.Okay THEN
        FileIO.WriteString(FileIO.StdOut, "Could not open input file");
        FileIO.WriteLn(FileIO.StdOut);
        HALT
      END;
      ChangeExtension(sourceName, ".LST", listName);
      FileIO.Open(lst, listName, TRUE);
      IF NOT FileIO.Okay THEN lst := FileIO.StdOut END;
      ResetErrors;

      FileIO.WriteString(FileIO.StdOut, "Parsing");
      FileIO.WriteLn(FileIO.StdOut);
      Parse;
      PrintListing;
      IF lst # FileIO.StdOut THEN FileIO.Close(lst) END;
      IF NOT Successful() THEN
        PrintConsoleErrors(sourceName);
        bad := TRUE
      END;
      (* Release the source handle before the next file: the host
         FileIO caps open files at BitSetSize (16), and a session may
         compile more sources than that. *)
      IF (src # FileIO.StdIn) & (src # FileIO.StdOut) THEN
        FileIO.Close(src)
      END;
      INC(f)
    END;

    IF bad OR NOT SymTab.HaveProgram()
      THEN FileIO.WriteString(FileIO.StdOut, "Incorrect source")
      ELSE FileIO.WriteString(FileIO.StdOut, "Parsed correctly")
    END
  END M2.