M2compiler-V2/src/compiler.frm

MODULE -->Grammar;
(* Driver for the M2comp Modula-2 compiler (Coco/R frontend).
   Generated <Grammar>S (scanner) + <Grammar>P (parser) do lexing,
   parsing, SymTab checking and AST building; on success the MGen
   tree-walking backend emits a single-module MC64 .MC4 image. *)

  FROM -->Scanner IMPORT lst, src, errors, Error, CharAt;
  FROM -->Parser IMPORT Parse, Successful;
  IMPORT
    Strings, Storage, SYSTEM, FileIO, AST, MGen, SymTab;

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

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

    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
        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) & (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
          WriteString(lst, s)
        END Msg;

      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;
        CASE nr OF
        -->Errors
        (* add customized cases here *)
        | 200: Msg("duplicate identifier")
        | 201: Msg("undeclared identifier")
        | 202: Msg("module/procedure 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 in this phase")
        | 231: Msg("procedure forward mismatch or missing body")
        | 232: Msg("bad RETURN")
        | 233: Msg("invalid procedure call")
        ELSE         Msg("Error: "); WriteInt(lst, nr, 0);
        END;
        WriteLn(lst)
      END PrintErr;

    PROCEDURE ResetErrors;
    (* Drops stored errors so the next input file starts clean. *)
      BEGIN
        firstErr := NIL; lastErr := NIL
      END ResetErrors;

    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
        WriteString(lst, "Listing:");
        WriteLn(lst); WriteLn(lst);
        srcPos := 0; nextErr := firstErr;
        GetLine(srcPos, line, eof); lnr := 1; errC := 0;
        WHILE ~ eof DO
          WriteInt(lst, lnr, 5); WriteString(lst, "  ");
          WriteString(lst, line); WriteLn(lst);
          WHILE (nextErr # NIL) & (nextErr^.line = lnr) DO
            PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
            nextErr := nextErr^.next
          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;

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

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

  PROCEDURE ChangeExtension (oldName, Ext: ARRAY OF CHAR;
                             VAR newName: ARRAY OF CHAR);
  (* Constructs newName by replacing the extension of oldName with Ext. *)
    VAR
      i, l: CARDINAL;
    BEGIN
      Strings.Assign(oldName, newName);
      i := LENGTH(oldName); l := i;
      WHILE (i > 0) & (oldName[i -1] # '.')
            & (oldName[i -1] # '\') & (oldName[i -1] # '/') DO
        DEC(i)
      END;
      IF (i > 0) & (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;

  VAR
    sourceName, listName: ARRAY [0 .. 255] OF CHAR;
    failed: BOOLEAN;
    emitOk: BOOLEAN;
    progSeen: BOOLEAN;
    uk: INTEGER;
    nDefs, nImpls: CARDINAL;
    i, j: CARDINAL;
    found: BOOLEAN;
    progRoot, sessionRoot, chain: AST.Node;
    progName: SymTab.Name;
    unitRoots: ARRAY [0 .. 15] OF AST.Node;
    unitIsDef: ARRAY [0 .. 15] OF BOOLEAN;

  PROCEDURE Fail (msg: ARRAY OF CHAR);
  (* Fail-fast session abort with a one-line outcome. *)
    BEGIN
      FileIO.WriteString(FileIO.StdOut, msg);
      FileIO.WriteLn(FileIO.StdOut);
      failed := TRUE
    END Fail;

  BEGIN
    (* check on correct parameter usage *)
    FileIO.NextParameter(sourceName);
    IF sourceName[0] = 0C THEN
      FileIO.WriteString(FileIO.StdOut, "No input file specified");
      HALT
    END;

    (* step 5: one symbol table per session (not per file), so
       definitions, implementations and the program share it *)

    (* install error reporting procedure - Scanner.Error *)
    Error := StoreError;

    SymTab.Init();
    failed := FALSE;
    progSeen := FALSE;
    nDefs := 0;
    nImpls := 0;
    LOOP
      IF sourceName[0] = 0C THEN EXIT END;

      (* open the source file - Scanner.src *)
      FileIO.Open(src, sourceName, FALSE);
      IF ~ FileIO.Okay THEN
        FileIO.WriteString(FileIO.StdOut, "Could not open input file");
        FileIO.WriteLn(FileIO.StdOut);
        HALT
      END;

      (* open the output file for the source listing - Scanner.lst *)
      ChangeExtension(sourceName, ".LST", listName);
      FileIO.Open(lst, listName, TRUE);
      IF ~ FileIO.Okay THEN
        FileIO.WriteString(FileIO.StdOut, "Could not open listing file");
        FileIO.WriteLn(FileIO.StdOut);
        (* default Scanner.lst to screen *) lst := FileIO.StdOut;
      END;

      (* fresh error list per input file (M2compS.Reset already
         zeroes the error count inside Parse) *)
      ResetErrors;

      (* instigate the compilation - Parser.Parse *)
      FileIO.WriteString(FileIO.StdOut, "Parsing ");
      FileIO.WriteString(FileIO.StdOut, sourceName);
      FileIO.WriteLn(FileIO.StdOut);
      Parse;

      (* generate the source listing on lst file *)
      PrintListing;
      IF lst # FileIO.StdOut THEN FileIO.Close(lst) END;

      (* fail fast: later files build on this one's tables *)
      IF NOT Successful()
        THEN
          FileIO.WriteString(FileIO.StdOut, "Incorrect source");
          FileIO.WriteLn(FileIO.StdOut);
          failed := TRUE;
          EXIT
      END;

      (* session order: definitions and implementations in
         dependency order (the grammar enforces per-library order:
         a definition precedes its implementation, an IMPORT needs
         a completed implementation), then exactly one program;
         remember each unit root for the single backend pass *)
      uk := SymTab.UnitKind();
      IF progSeen THEN
        Fail("Incorrect source"); EXIT
      ELSIF uk = SymTab.UnitDef THEN
        IF nDefs + nImpls > 15 THEN
          Fail("Incorrect source"); EXIT
        END;
        unitRoots[nDefs + nImpls] := AST.GetRoot();
        unitIsDef[nDefs + nImpls] := TRUE;
        INC(nDefs)
      ELSIF uk = SymTab.UnitImpl THEN
        IF nDefs + nImpls > 15 THEN
          Fail("Incorrect source"); EXIT
        END;
        unitRoots[nDefs + nImpls] := AST.GetRoot();
        unitIsDef[nDefs + nImpls] := FALSE;
        INC(nImpls)
      ELSE
        progSeen := TRUE;
        progRoot := AST.GetRoot();
        Strings.Assign(progRoot^.name, progName)
      END;

      FileIO.NextParameter(sourceName);
    END;

    (* a session without a program emits nothing *)
    IF NOT failed & ~progSeen THEN
      Fail("Incorrect source")
    END;

    (* merge each implementation into its definition unit, then emit
       the program together with the library units in one image *)
    IF NOT failed THEN
      i := 0;
      WHILE (i < nDefs + nImpls) & ~failed DO
        IF ~unitIsDef[i] THEN
          found := FALSE;
          j := 0;
          WHILE (j < nDefs + nImpls) & ~found DO
            IF unitIsDef[j] & Strings.Equal(unitRoots[j]^.name,
               unitRoots[i]^.name) THEN
              found := TRUE
            ELSE
              INC(j)
            END
          END;
          IF ~found THEN Fail("Incorrect source")
          ELSE
            unitRoots[j]^.left := AST.Append(unitRoots[j]^.left,
              unitRoots[i]^.left);
            unitRoots[j]^.right := unitRoots[i]^.right
          END
        END;
        INC(i)
      END
    END;
    IF NOT failed THEN
      chain := NIL;
      i := 0;
      WHILE i < nDefs + nImpls DO
        IF unitIsDef[i] THEN
          chain := AST.Append(chain, unitRoots[i])
        END;
        INC(i)
      END;
      IF chain = NIL THEN sessionRoot := progRoot
      ELSE
        sessionRoot := AST.MkModule(progName,
          AST.Append(chain, progRoot^.left), progRoot^.right)
      END;
      (* backend: emit the MC64 image (errors reach StdOut only;
         listings are already written) *)
      emitOk := MGen.EmitModule(sessionRoot);
      IF emitOk THEN MGen.DumpImage END;
      IF NOT emitOk THEN Fail("Incorrect source") END
    END;

    (* examine the outcome *)
    IF NOT failed THEN
      FileIO.WriteString(FileIO.StdOut, "Parsed correctly");
    END;
  END -->Grammar.