CocoR/CRQ.mod

(* CR   Main Module of Coco/R
   ==   =====================

   This is a compiler generator that produces a scanner and a parser
   from an attributed grammar, and optionally a complete small compiler.

   Original code in Oberon by Hanspeter Moessenboeck, ETH Zurich
   Ported at ETH to Apple Modula, and thence to JPI-2 Modula.

Usage:
          COCOR [-options] GrammarName[.atg] [$options]

Input:
  attributed grammar   input grammar
  scanner.frm          frame file
  parser.frm           frame file
  compiler.frm         frame file (optional)

(Frame files must be in the sme directory as the grammar, or may be
found on a path specified by environment variable CRFRAMES).

Output:
  <GrammarName>S.def + mod  generated scanner
  <GrammarName>P.def + mod  generated parser
  <GrammarName>.err         error numbers and corresponding error messages
  <GrammarName>.lst         source listing with error messages and trace output

Optionally

  <GrammarName>G.def + mod  generated symbolic names
  <GrammarName>.mod         generated compiler main module

Implementation restrictions
  1  too many nodes in graph (>1500)                 CRT.NewNode
  2  too many symbols (>500)                         CRT.NewSym, MovePragmas
  3  too many sets (>256 ANY-syms or SYNC syms)      CRT.NewSet,
  4  too many character classes (>250)               CRT.NewClass
  5  too many conditions in generated code (>100)    CRX.NewCondSet
  6  too many token names in "NAMES" (>100)          CRT.NewName
  7  too many states in automata (>500)              CRA.NewState

Trace output
(To activate a trace switch, write "${letter}" in the input grammar, or
invoke Coco with a second command line parameter)

  A  Prints states of automaton

  C  Generates complete compiler module

  D  Suppresses Def Mod generation

  F  Prints start symbols and followers of nonterminals.

  G  Prints the top-down graph.

  I  Trace of start symbol set computation.

  L  Forces a listing (otherwise a listing is only printed if errors are found).
  
  M  Suppresses FORWARD declarations in parser (for multipass compilers).

  N  Uses default names for symbol value constants.  This generates an
     extra module <grammar name>G, and corresponding import statements
     using constant names instead of numbers for symbols in parser and
     scanner.
     The constants are used unqualified and hence all needed constants
     have to be imported; so a complete import list for these constants
     is generated.
     There is no decision whether a constant is actually needed.

     The default conventions are (only terminals or pragmas can have names):
     single character   -->  <ASCII name (lowercase)>Sym
          eg. "+"       -->  plusSym
     character string   -->  <string>Sym
          eg. "PROGRAM" -->  PROGRAMSym
     scanner token      -->  <token name>Sym
          eg. ident     -->  identSym

  O  Trace of follow set computation (not yet implemented).

  P  Generates parser only

  S  Prints the symbol list.

  T  Suppresses generation of def and mod files (grammar tests only).

  X  Prints a cross reference list.

==========================================================================*)

MODULE CR;

  FROM CRS IMPORT lst, src, errors, directory, Error, CharAt;
  FROM CRP IMPORT Parse;
  IMPORT CRC, CRT, CRA, CRP, CRS, CRX, FIO;
  IMPORT Storage;
  IMPORT SYSTEM (* for TSIZE only *);
  IMPORT FileIO, FIO;

  CONST
    ATGExt = ".atg";
    LSTExt = ".lst";
    Version = "1.53q";
    ReleaseDate = "2025";
    EOF = 0C;            (* FileIO.Read returns EOF when eof is reached. *)
    EOL = 36C;           (* FileIO.Read maps line marks onto EOL
                            FileIO.Write maps EOL onto cr, lf, or cr/lf
                            as appropriate for filing system. *)
    ESC = 33C;           (* Standard ASCII escape. *)
    CR  = 15C;           (* Standard ASCII carriage return. *)
    LF  = 12C;           (* Standard ASCII line feed. *)
    BS  = 10C;           (* Standard ASCII backspace. *)
    DEL = 177C;          (* Standard ASCII DEL (rub-out). *)

  TYPE
    INT32 = CARDINAL;

  VAR
    Options,
    GrammarName,
    ATGFileName,
    lstFileName: ARRAY [0 .. 63] OF CHAR;
    ll1:         BOOLEAN; (* TRUE, if grammar is LL(1) *)
    IDE,
    ok:          BOOLEAN; (* TRUE, if grammar tests ok so far *)

  MODULE ListHandler;
  (* ------------------- Source Listing and Error handler -------------- *)
  IMPORT FIO, Storage, SYSTEM;
  IMPORT lst, CharAt, ATGFileName, IDE, errors, INT32;
  EXPORT StoreError, PrintListing;

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

    PROCEDURE Pointer;
      VAR
        i: INTEGER;
      BEGIN
        FIO.WriteString(lst, "*****  ");
        i := 0;
        WHILE i < col + Extra - 2 DO
          IF line[i] = tab
            THEN FIO.Write(lst, tab)
            ELSE FIO.Write(lst, ' ')
          END;
          INC(i)
        END;
        FIO.WriteString(lst, "^ ")
      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(lst, nr, 1);
      END;
      FIO.WriteLn(lst)
    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(lst, "Listing:");
        FIO.WriteLn(lst); FIO.WriteLn(lst);
      END;
      srcPos := 0; nextErr := firstErr;
      GetLine(srcPos, line, eof); lnr := 1; errC := 0;
      WHILE ~ eof DO
        IF ~ IDE THEN
          FIO.WriteInt(lst, lnr, 5); FIO.WriteString(lst, "  ");
          FIO.WriteString(lst, line); FIO.WriteLn(lst)
        END;
        WHILE (nextErr # NIL) & (nextErr^.line = lnr) DO
          IF IDE THEN
            FIO.WriteString(lst, ATGFileName);
            FIO.WriteString(lst, " (");
            FIO.WriteCard(lst, lnr, 1);
            FIO.WriteString(lst, ",");
            FIO.WriteCard(lst, nextErr^.col-1, 0);
            FIO.WriteString(lst, ") ")
          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(lst, lnr, 5); FIO.WriteLn(lst) END;
        WHILE nextErr # NIL DO
          IF IDE THEN
            FIO.WriteString(lst, ATGFileName);
            FIO.WriteString(lst, " (");
            FIO.WriteCard(lst, lnr, 1);
            FIO.WriteString(lst, ",");
            FIO.WriteCard(lst, nextErr^.col-1, 0);
            FIO.WriteString(lst, ") ")
          END;
          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
          nextErr := nextErr^.next
        END
      END;
      IF ~ IDE AND (errC > 0) THEN
        FIO.WriteLn(lst);
        FIO.WriteInt(lst, errC, 5); FIO.WriteString(lst, " error");
        IF errC # 1 THEN FIO.Write(lst, "s") END;
        FIO.WriteLn(lst); FIO.WriteLn(lst); FIO.WriteLn(lst);
      END
    END PrintListing;

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

  PROCEDURE SetOption (s: ARRAY OF CHAR);
  (* Set compiler options *)
    VAR
      i: CARDINAL;
    BEGIN
      i := 1;
      WHILE s[i] # 0C DO
        s[i] := CAP(s[i]);
        IF (s[i] >= "A") AND (s[i] <= "Z") THEN CRT.ddt[s[i]] := TRUE END;
        INC(i);
      END;
    END SetOption;

  PROCEDURE Msg (S: ARRAY OF CHAR);
    BEGIN
      FIO.WriteString(FIO.StdOut, S); FIO.WriteLn(FIO.StdOut);
    END Msg;

  (* --------------------------- Help ------------------------------- *)

  PROCEDURE Help;
    BEGIN
      Msg("Usage: COCOR [-Options] [Grammar[.atg]] [-Options]");
      Msg("Example: COCOR -mcs Test");
      Msg("");
      Msg("Options are");
      Msg("a  - Trace automaton");
      Msg("c  - Generate compiler module");
      Msg("d  - Suppress generation of Definition Modules");
      Msg("f  - Give Start and Follower sets");
      Msg("g  - Print top-down graph");
      Msg("i  - Trace start set computations");
      Msg("l  - Force listing");
      Msg("m  - (Multipass) Suppress FORWARD declarations");
      Msg("n  - Generate symbolic names");
      Msg("p  - Generate parser only");
      Msg("q  - Generate error messages to interface with editor");
      Msg("s  - Print symbol table");
      Msg("t  - Grammar tests only - no code generated");
      Msg("x  - Print cross reference list");
      Msg("COMPILER.FRM, SCANNER.FRM and PARSER.FRM must be in the working directory,");
      Msg("or on the path specified by the environment variable CRFRAMES");
    END Help;

  BEGIN (* CR *)
    FIO.WriteString(FIO.StdOut, "Coco/R (WinTel) - Compiler-Compiler V");
    FIO.WriteString(FIO.StdOut, Version);
    FIO.WriteLn(FIO.StdOut);
    FIO.WriteString(FIO.StdOut, "Released by Pat Terry ");
    FIO.WriteString(FIO.StdOut, ReleaseDate);
    FIO.WriteLn(FIO.StdOut);
    FIO.NextParameter(GrammarName);
    IF (GrammarName[0] = "?")
        OR (GrammarName[0] = "/") AND (GrammarName[1] = "?") THEN
      Help; FIO.QuitExecution
    END;
    IF GrammarName[0] = 0C THEN
      FIO.WriteString(FIO.StdOut, "(COCOR ? gives short help screen)");
      FIO.WriteLn(FIO.StdOut);
    END;
    WHILE (GrammarName[0] = "-") OR (GrammarName[0] = "/") DO
      (* accept options before filename *)
      SetOption(GrammarName); FIO.NextParameter(GrammarName)
    END;
    ok := GrammarName[0] # 0C;
    REPEAT
      IF ~ ok THEN
        FIO.WriteString(FIO.StdOut, "Grammar[.atg] ? : ");
        FIO.ReadString(FIO.StdIn, GrammarName);
        IF ~ FIO.IsNoError(FIO.StdIn) THEN FIO.QuitExecution END;
        FIO.ReadLn(FIO.StdIn);
      END;
      FIO.AppendExtension(GrammarName, ATGExt, ATGFileName);
      GrammarName := ATGFileName;
      FIO.Open(src, GrammarName, FALSE);
      ok := FIO.IsNoError(src);
      IF ~ ok THEN
        FIO.WriteString(FIO.StdOut, "File <");
        FIO.WriteString(FIO.StdOut, GrammarName);
        FIO.WriteString(FIO.StdOut, "> not found.");
        FIO.WriteLn(FIO.StdOut);
      END
    UNTIL ok;
    FIO.NextParameter(Options);
    IF Options[0] # 0C THEN SetOption(Options) END;
    IDE := CRT.ddt["Q"];
    FIO.ExtractDirectory(GrammarName, directory);
    FIO.ChangeExtension(GrammarName, LSTExt, lstFileName);
    IF IDE
      THEN
        lst := FIO.StdOut
      ELSE
        FIO.Open(lst, lstFileName, TRUE);
        FIO.WriteString(lst, "Coco/R - Compiler-Compiler V");
        FIO.WriteString(lst, Version);
        FIO.WriteLn(lst);
        FIO.WriteString(lst, "Released by Pat Terry ");
        FIO.WriteString(lst, ReleaseDate);
        FIO.WriteLn(lst);
        FIO.WriteString(lst, "Source file: ");
        FIO.WriteString(lst, GrammarName);
        FIO.WriteLn(lst); FIO.WriteLn(lst);
        FIO.WriteLn(FIO.StdOut);
        FIO.WriteString(FIO.StdOut, "parsing file ");
        FIO.WriteString(FIO.StdOut, GrammarName);
        FIO.WriteLn(FIO.StdOut);
    END;
    CRS.Error := StoreError;
    CRP.Parse;
(*
    IF ~ IDE THEN
      FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut)
    END;
*)
    IF errors = 0 THEN
      IF ~ IDE
        THEN
          Msg("testing grammar");
          FIO.WriteString(lst, "Grammar Tests:");
          FIO.WriteLn(lst); FIO.WriteLn(lst)
        ELSE
          FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) Grammar tests"); FIO.WriteLn(lst)
      END;
      CRT.CompSymbolSets;
      IF IDE THEN
        FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
        FIO.WriteString(lst, " (0, 0) Undefined tests"); FIO.WriteLn(lst)
      END;
      CRT.TestCompleteness(ok);
      IF ok
        THEN
          IF IDE THEN
            FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
            FIO.WriteString(lst, " (0, 0) Unreachable tests"); FIO.WriteLn(lst)
          END;
          CRT.TestIfAllNtReached(ok)
      END;
      IF ok THEN
        IF IDE THEN
          FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) Circular tests"); FIO.WriteLn(lst)
        END;
        CRT.FindCircularProductions(ok)
      END;
      IF ok THEN
        IF IDE THEN
          FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) Underivable tests"); FIO.WriteLn(lst)
        END;
        CRT.TestIfNtToTerm(ok)
      END;
      IF ok THEN
        IF IDE THEN
          FIO.WriteLn(lst); FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) LL(1) tests"); FIO.WriteLn(lst)
        END;
        CRT.LL1Test(ll1)
      END;
(*
      IF ~ IDE THEN
        FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut);
        FIO.WriteLn(lst)
      END;
*)
      IF ~ ok OR ~ ll1 OR CRT.ddt["L"] OR CRT.ddt["X"] THEN
        IF ~ IDE THEN Msg("listing") END;
        PrintListing; IF CRT.ddt["X"] THEN CRT.XRef; END;
(*
        IF ~ IDE THEN
          FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut)
        END;
*)
      END;
      IF CRT.ddt["N"] OR CRT.symNames THEN
        IF ~ IDE THEN Msg("symbol name assignment") END;
        CRT.AssignSymNames(CRT.ddt["N"], CRT.symNames);
      END;
      IF ok AND ~ CRT.ddt["T"] THEN
        IF ~ IDE THEN Msg("generating parser") END;
        CRX.GenCompiler;
(*
        IF ~ IDE THEN
          FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut)
        END;
*)
        IF CRT.genScanner AND ~ CRT.ddt["P"] THEN
          IF ~ IDE THEN Msg("generating scanner") END;
          CRA.WriteScanner(ok);
          IF CRT.ddt["A"] THEN CRA.PrintStates END;
(*
          IF ~ IDE THEN
            FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut)
          END;
*)
        END;
        IF CRT.ddt["C"] THEN
          IF ~ IDE THEN Msg("generating compiler") END;
          CRC.WriteDriver;
(*
          IF ~ IDE THEN
            FIO.WriteLn(FIO.StdOut); FIO.WriteElapsedTime(FIO.StdOut);
          END;
*)
        END;
        IF ~ IDE THEN CRX.WriteStatistics END;
      END;
      IF ~ ok THEN
        FIO.WriteLn(FIO.StdOut);
        IF IDE THEN
          FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) ")
        END;
        FIO.WriteString(FIO.StdOut, "Compilation ended with errors in grammar tests.");
      ELSIF ~ ll1 THEN
        FIO.WriteLn(FIO.StdOut);
        IF IDE THEN
          FIO.WriteString(lst, ATGFileName);
          FIO.WriteString(lst, " (0, 0) ")
        END;
        FIO.WriteString(FIO.StdOut, "Compilation ended with LL(1) errors.");
      ELSE
        Msg("Compilation completed. No errors detected.");
      END;
    ELSE
      IF ~ IDE THEN Msg("listing") END;
      PrintListing; IF CRT.ddt["X"] THEN CRT.XRef END;
      IF ~ IDE THEN Msg("*** errors detected ***") END;
    END;
    FIO.WriteLn(FIO.StdOut);
    IF CRT.ddt["G"] THEN CRT.PrintGraph END;
    IF CRT.ddt["S"] THEN CRT.PrintSymbolTable END;
    FIO.Close(lst); FIO.Close(src);
(*
    IF ~ IDE THEN
      FIO.WriteLn(FIO.StdOut); FIO.WriteExecutionTime(FIO.StdOut)
    END
*)
  END CR.