first commit

CR.atg

@@ -0,0 +1,481 @@
+$LSC (*$ACFGILMOSXN*)
+(* COCO/R for MS-DOS grammar used to generate COCO/R itself
+   as adapted by P.D. Terry, January 1992
+   version 1.50 last modified Sat  11-13-99 *)
+
+COMPILER CR
+
+(*---------------------- semantic declarations -----------------------*)
+
+IMPORT CRT, CRA, Sets;
+
+CONST
+  ident = 0; string = 1;  (* symbol kind *)
+TYPE
+  INT32 = FileIO.INT32;
+
+PROCEDURE FixString (VAR name: ARRAY OF CHAR; len: CARDINAL);
+  VAR
+    double, spaces: BOOLEAN;
+    i: CARDINAL;
+  BEGIN
+    IF len = 2 THEN SemError(129); RETURN END;
+    IF CRT.ignoreCase THEN (* force uppercase *)
+      FOR i := 1 TO len - 2 DO name[i] := CAP(name[i]) END
+    END;
+    double := FALSE; spaces := FALSE;
+    FOR i := 1 TO len - 2 DO (* search for interior " or spaces *)
+      IF name[i] = '"' THEN double := TRUE END;
+      IF name[i] <= ' ' THEN spaces := TRUE END;
+    END;
+    IF ~ double THEN (* force delimiters to be " quotes *)
+      name[0] := '"'; name[len-1] := '"'
+    END;
+    IF spaces THEN SemError(124) END;
+  END FixString;
+
+PROCEDURE MatchLiteral (sp: INTEGER);
+(* store string either as token or as literal *)
+  VAR
+    sn, sn1:  CRT.SymbolNode;
+    matchedSp: INTEGER;
+  BEGIN
+    CRT.GetSym(sp, sn);
+    CRA.MatchDFA(sn.name, sp, matchedSp);
+    IF matchedSp # CRT.noSym THEN
+      CRT.GetSym(matchedSp, sn1);
+      sn1.struct := CRT.classLitToken;
+      CRT.PutSym(matchedSp, sn1);
+      sn.struct := CRT.litToken
+    ELSE sn.struct := CRT.classToken;
+    END;
+    CRT.PutSym(sp, sn)
+  END MatchLiteral;
+
+PROCEDURE SetCtx (gp: INTEGER);
+(* set transition code to CRT.contextTrans *)
+  VAR
+    gn: CRT.GraphNode;
+  BEGIN
+    WHILE gp > 0 DO
+      CRT.GetNode(gp, gn);
+      IF (gn.typ = CRT.char) OR (gn.typ = CRT.class) THEN
+        gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
+      ELSIF (gn.typ = CRT.opt) OR (gn.typ = CRT.iter) THEN SetCtx(gn.p1)
+      ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
+      END;
+      gp := gn.next
+    END
+  END SetCtx;
+
+PROCEDURE SetOption (s: ARRAY OF CHAR);
+  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;
+
+(*--------------------------------------------------------------------*)
+
+CHARACTERS
+
+  letter   = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_".
+  digit    = "0123456789".
+  ctrl     = CHR(1) .. CHR(31).
+  tab      = CHR(9).
+  eol      = CHR(13).
+  lf       = CHR(10).
+  noQuote1 = ANY - '"' - ctrl.
+  noQuote2 = ANY - "'" - ctrl.
+
+IGNORE tab + eol + lf
+
+TOKENS
+
+  ident     = letter {letter | digit}.
+  string    = '"' {noQuote1} '"' | "'" {noQuote2} "'".
+  badstring = '"' {noQuote1} (eol | lf) | "'" {noQuote2} (eol | lf).
+  number    = digit {digit}.
+
+PRAGMAS
+
+  Options = "$" {letter | digit} .
+                (.CRS.GetName(CRS.nextPos, CRS.nextLen, s); SetOption(s);  .)
+
+COMMENTS FROM "(*" TO "*)" NESTED
+COMMENTS FROM "/*" TO "*/"
+
+PRODUCTIONS
+
+CR                            (. VAR
+                                   startedDFA, ok, undef, hasAttrs: BOOLEAN;
+                                   unknownSy,
+                                   eofSy, gR:       INTEGER;
+                                   gramLine, sp:    INTEGER;
+                                   name, gramName:  CRT.Name;
+                                   sn:              CRT.SymbolNode; .)
+=
+"COMPILER"
+                              (. gramLine := CRS.line;
+                                 eofSy := CRT.NewSym(CRT.t, "EOF", 0);
+                                 CRT.genScanner := TRUE; CRT.ignoreCase := FALSE;
+                                 Sets.Clear(CRT.ignored);
+                                 startedDFA := FALSE; .)
+
+Ident <gramName>              (. CRT.semDeclPos.beg := CRS.nextPos .)
+{ ANY }                       (. CRT.semDeclPos.len := FileIO.INTL(CRS.nextPos - CRT.semDeclPos.beg);
+                                 CRT.semDeclPos.col := 0 .)
+{ Declaration<startedDFA> }
+SYNC
+"PRODUCTIONS"                 (. ok := Successful();
+                                 IF ok & CRT.genScanner THEN CRA.MakeDeterministic(ok) END;
+                                 IF ~ ok THEN SemError(127) END;
+                                 CRT.nNodes := 0 .)
+{ Ident <name>                (. sp := CRT.FindSym(name); undef := sp = CRT.noSym;
+                                 IF undef THEN
+                                   sp := CRT.NewSym(CRT.nt, name, CRS.line);
+                                   CRT.GetSym(sp, sn);
+                                 ELSE
+                                   CRT.GetSym(sp, sn);
+                                   IF sn.typ = CRT.nt THEN
+                                     IF sn.struct > 0 THEN SemError(107) END
+                                   ELSE SemError(108)
+                                   END;
+                                   sn.line := CRS.line
+                                 END;
+                                 hasAttrs := sn.attrPos.beg >= FileIO.Long0 .)
+  ( Attribs <sn.attrPos>      (. IF ~ undef & ~ hasAttrs THEN SemError(105) END;
+                                 CRT.PutSym(sp, sn) .)
+  |                           (. IF ~ undef & hasAttrs THEN SemError(105) END .)
+  )
+  [ SemText <sn.semPos>]
+  WEAK "="
+  Expression <sn.struct, gR>  (. CRT.CompleteGraph(gR); CRT.PutSym(sp, sn) .)
+  WEAK "."
+  }
+"END" Ident <name>            (. sp := CRT.FindSym(gramName);
+                                 IF sp = CRT.noSym THEN SemError(111);
+                                 ELSE
+                                   CRT.GetSym(sp, sn);
+                                   IF sn.attrPos.beg >= FileIO.Long0 THEN SemError(112) END;
+                                   CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
+                                 END;
+                                 IF FileIO.Compare(name, gramName) # 0 THEN
+                                   SemError(117)
+                                 END .)
+"."                           (. unknownSy := CRT.NewSym(CRT.t, "not", 0) .)
+
+.
+
+(*----------------------------------------------------------------------------*)
+
+Declaration<VAR startedDFA: BOOLEAN>
+                              (. VAR
+                                   gL1, gR1, gL2, gR2: INTEGER;
+                                   nested:             BOOLEAN; .)
+= (
+      "CHARACTERS" { SetDecl }
+    | "TOKENS"  { TokenDecl <CRT.t> }
+    | "NAMES"   { NameDecl }
+    | "PRAGMAS" { TokenDecl <CRT.pr> }
+    | "COMMENTS"
+      "FROM" TokenExpr <gL1, gR1>
+      "TO" TokenExpr <gL2, gR2>
+      ( "NESTED"              (. nested := TRUE .)
+        |                     (. nested := FALSE .)
+      )
+                              (. CRA.NewComment(gL1, gL2, nested) .)
+    | "IGNORE"
+      ( "CASE"                (. IF startedDFA THEN SemError(130) END;
+                                 CRT.ignoreCase := TRUE .)
+      | Set <CRT.ignored>     (. IF Sets.In(CRT.ignored, 0) THEN SemError(119) END; .)
+      )
+  )                           (. startedDFA := TRUE .)
+.
+
+
+(*----------------------------------------------------------------------------*)
+
+SetDecl                       (. VAR
+                                   c:    INTEGER;
+                                   set:  CRT.Set;
+                                   name: CRT.Name; .)
+= Ident <name>                (. c := CRT.ClassWithName(name);
+                                 IF c >= 0 THEN SemError(107) END .)
+  "=" Set <set>               (. IF Sets.Empty(set) THEN SemError(101) END;
+                                 c := CRT.NewClass(name, set) .)
+  ".".
+
+(*----------------------------------------------------------------------------*)
+
+Set <VAR set: CRT.Set>        (. VAR
+                                   set2: CRT.Set; .)
+= SimSet <set>
+  { "+" SimSet <set2>         (. Sets.Unite(set, set2) .)
+  | "-" SimSet <set2>         (. Sets.Differ(set, set2) .)
+  }.
+
+(*----------------------------------------------------------------------------*)
+
+SimSet <VAR set: CRT.Set>     (. VAR
+                                   i, n1, n2: CARDINAL;
+                                   c:         INTEGER;
+                                   name:      CRT.Name;
+                                   s:         ARRAY [0 .. 127] OF CHAR; .)
+=                             (. Sets.Clear(set) .)
+  (   Ident <name>            (. c := CRT.ClassWithName(name);
+                                 IF c < 0
+                                   THEN SemError(115)
+                                   ELSE CRT.GetClass(c, set)
+                                 END .)
+    | string                  (. CRS.GetName(CRS.pos, CRS.len, s);
+                                 i := 1;
+                                 WHILE s[i] # s[0] DO
+                                   IF CRT.ignoreCase THEN s[i] := CAP(s[i]) END;
+                                   Sets.Incl(set, ORD(s[i])); INC(i)
+                                 END .)
+    | SingleChar <n1>         (. Sets.Incl(set, n1) .)
+      [ ".." SingleChar <n2>  (. FOR i := n1 TO n2 DO Sets.Incl(set, i) END .)
+      ]
+    | "ANY"                   (. FOR i := 0 TO 255 DO Sets.Incl(set, i) END .)
+  ) .
+
+(*----------------------------------------------------------------------------*)
+
+SingleChar <VAR n: CARDINAL>  (. VAR
+                                   i: CARDINAL;
+                                   s: ARRAY [0 .. 127] OF CHAR; .)
+  =
+    "CHR" "("
+    (   number                (. CRS.GetName(CRS.pos, CRS.len, s);
+                                 n := 0; i := 0;
+                                 WHILE s[i] # 0C DO
+                                   n := 10 * n + ORD(s[i]) - ORD("0"); INC(i)
+                                 END;
+                                 IF n > 255 THEN SemError(118); n := n MOD 256 END;
+                                 IF CRT.ignoreCase THEN n := ORD(CAP(CHR(n))) END .)
+      | string                (. CRS.GetName(CRS.pos, CRS.len, s);
+                                 IF CRS.len # 3 THEN SemError(118) END;
+                                 IF CRT.ignoreCase THEN s[1] := CAP(s[1]) END;
+                                 n := ORD(s[1]); .)
+     )
+     ")" .
+
+(*----------------------------------------------------------------------------*)
+
+TokenDecl <typ: INTEGER>      (. VAR
+                                   kind:       INTEGER;
+                                   name:       CRT.Name;
+                                   pos:        CRT.Position;
+                                   sp, gL, gR: INTEGER;
+                                   sn:         CRT.SymbolNode; .)
+= Symbol <name, kind>         (. IF CRT.FindSym(name) # CRT.noSym THEN SemError(107)
+                                 ELSE
+                                   sp := CRT.NewSym(typ, name, CRS.line);
+                                   CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
+                                   CRT.PutSym(sp, sn)
+                                 END .)
+  SYNC
+  ( "="
+    TokenExpr <gL, gR>        (. IF kind # ident THEN SemError(113) END;
+                                 CRT.CompleteGraph(gR);
+                                 CRA.ConvertToStates(gL, sp) .)
+    "."
+  |                           (. IF kind = ident THEN CRT.genScanner := FALSE
+                                   ELSE MatchLiteral(sp)
+                                 END .)
+  )
+  [ SemText <pos>             (. IF typ = CRT.t THEN SemError(114) END;
+                                 CRT.GetSym(sp, sn); sn.semPos := pos;
+                                 CRT.PutSym(sp, sn) .)
+  ].
+
+(*----------------------------------------------------------------------------*)
+
+Expression <VAR gL, gR: INTEGER>
+                              (. VAR
+                                   gL2, gR2: INTEGER;
+                                   first:    BOOLEAN; .)
+= Term <gL, gR>               (. first := TRUE .)
+  { WEAK "|"
+    Term <gL2, gR2>           (. IF first THEN
+                                   CRT.MakeFirstAlt(gL, gR); first := FALSE
+                                 END;
+                                 CRT.ConcatAlt(gL, gR, gL2, gR2) .)
+  }
+.
+
+(*----------------------------------------------------------------------------*)
+
+Term<VAR gL, gR: INTEGER>     (. VAR
+                                   gL2, gR2: INTEGER; .)
+=                             (. gL := 0; gR := 0 .)
+( Factor <gL, gR>
+    { Factor <gL2, gR2>       (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
+    }
+  |                           (. gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL .)
+  ).
+
+(*----------------------------------------------------------------------------*)
+
+Factor <VAR gL, gR: INTEGER>  (. VAR
+                                   sp, kind:    INTEGER;
+                                   name:        CRT.Name;
+                                   gn:          CRT.GraphNode;
+                                   sn:          CRT.SymbolNode;
+                                   set:         CRT.Set;
+                                   undef, weak: BOOLEAN;
+                                   pos:         CRT.Position; .)
+=                             (. gL :=0; gR := 0; weak := FALSE .)
+( [ "WEAK"                    (. weak := TRUE .)
+  ]
+  Symbol <name, kind>         (. sp := CRT.FindSym(name); undef := sp = CRT.noSym;
+                                 IF undef THEN
+                                   IF kind = ident THEN  (* forward nt *)
+                                     sp := CRT.NewSym(CRT.nt, name, 0)
+                                   ELSIF CRT.genScanner THEN
+                                     sp := CRT.NewSym(CRT.t, name, CRS.line);
+                                     MatchLiteral(sp)
+                                   ELSE (* undefined string in production *)
+                                     SemError(106); sp := 0
+                                   END
+                                 END;
+                                 CRT.GetSym(sp, sn);
+                                 IF (sn.typ # CRT.t) & (sn.typ # CRT.nt) THEN SemError(104) END;
+                                 IF weak THEN
+                                   IF sn.typ = CRT.t THEN sn.typ := CRT.wt
+                                   ELSE SemError(123)
+                                   END
+                                 END;
+                                 gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL .)
+  ( Attribs <pos>             (. CRT.GetNode(gL, gn); gn.pos := pos;
+                                 CRT.PutNode(gL, gn);
+                                 CRT.GetSym(sp, sn);
+                                 IF sn.typ # CRT.nt THEN SemError(103) END;
+                                 IF undef THEN
+                                   sn.attrPos := pos; CRT.PutSym(sp, sn)
+                                 ELSIF sn.attrPos.beg < FileIO.Long0 THEN SemError(105)
+                                 END .)
+  |                           (. CRT.GetSym(sp, sn);
+                                 IF sn.attrPos.beg >= FileIO.Long0 THEN SemError(105) END .)
+  )
+| "(" Expression <gL, gR> ")"
+| "[" Expression <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
+| "{" Expression <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
+
+| SemText <pos>               (. gL := CRT.NewNode(CRT.sem, 0, 0); gR := gL;
+                                 CRT.GetNode(gL, gn);
+                                 gn.pos := pos;
+                                 CRT.PutNode(gL, gn) .)
+| "ANY"                       (. Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
+                                 gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL .)
+| "SYNC"                      (. gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL .)
+).
+
+(*----------------------------------------------------------------------------*)
+
+TokenExpr <VAR gL, gR: INTEGER>
+                              (. VAR
+                                   gL2, gR2: INTEGER;
+                                   first:    BOOLEAN; .)
+= TokenTerm <gL, gR>          (. first := TRUE .)
+  { WEAK "|"
+    TokenTerm <gL2, gR2>      (. IF first THEN
+                                   CRT.MakeFirstAlt(gL, gR); first := FALSE
+                                 END;
+                                 CRT.ConcatAlt(gL, gR, gL2, gR2) .)
+  }.
+
+(*----------------------------------------------------------------------------*)
+
+TokenTerm <VAR gL, gR: INTEGER>
+                              (. VAR
+                                   gL2, gR2: INTEGER; .)
+= TokenFactor <gL, gR>
+  { TokenFactor <gL2, gR2>    (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
+  }
+  [ "CONTEXT"
+    "(" TokenExpr <gL2, gR2>  (. SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) .)
+    ")"
+  ].
+
+(*----------------------------------------------------------------------------*)
+
+TokenFactor <VAR gL, gR: INTEGER>
+                              (.VAR
+                                  kind, c: INTEGER;
+                                  set:     CRT.Set;
+                                  name:    CRT.Name; .)
+=                             (. gL :=0; gR := 0 .)
+( Symbol <name, kind>         (. IF kind = ident THEN
+                                   c := CRT.ClassWithName(name);
+                                   IF c < 0 THEN
+                                     SemError(115);
+                                     Sets.Clear(set); c := CRT.NewClass(name, set)
+                                   END;
+                                   gL := CRT.NewNode(CRT.class, c, 0); gR := gL
+                                 ELSE (* string *)
+                                   CRT.StrToGraph(name, gL, gR)
+                                 END .)
+| "(" TokenExpr <gL, gR> ")"
+| "[" TokenExpr <gL, gR> "]"  (. CRT.MakeOption(gL, gR) .)
+| "{" TokenExpr <gL, gR> "}"  (. CRT.MakeIteration(gL, gR) .)
+).
+
+(*----------------------------------------------------------------------------*)
+
+Ident <VAR name: CRT.Name> =
+  ident                       (. CRS.GetName(CRS.pos, CRS.len, name) .).
+
+(*----------------------------------------------------------------------------*)
+
+Symbol <VAR name: CRT.Name; VAR kind: INTEGER>
+  =
+  ( Ident <name>              (. kind := ident .)
+  | string                    (. CRS.GetName(CRS.pos, CRS.len, name); kind := string;
+                                 FixString(name, CRS.len) .)
+  ).
+
+(*----------------------------------------------------------------------------*)
+
+Attribs <VAR attrPos: CRT.Position> =
+    "<"                       (. attrPos.beg := CRS.pos + FileIO.Long1; attrPos.col := CRS.col + 1 .)
+    { ANY | badstring         (. SemError(102) .)
+    }
+    ">"                       (. attrPos.len := FileIO.INTL(CRS.pos - attrPos.beg) .)
+  |
+    "<."                      (. attrPos.beg := CRS.pos + FileIO.Long2; attrPos.col := CRS.col + 2 .)
+    { ANY | badstring         (. SemError(102) .)
+    }
+    ".>"                      (. attrPos.len := FileIO.INTL(CRS.pos - attrPos.beg) .).
+
+(*----------------------------------------------------------------------------*)
+
+SemText <VAR semPos: CRT.Position> =
+  "(."                        (. semPos.beg := CRS.pos + FileIO.Long2; semPos.col := CRS.col + 2 .)
+  {   ANY
+    | badstring               (. SemError(102) .)
+    | "(."                    (. SemError(109) .)
+  }
+  ".)"                        (. IF CRS.pos - semPos.beg > FileIO.INT(CRT.maxSemLen) THEN SemError(128) END;
+                                 semPos.len := FileIO.ORDL(CRS.pos - semPos.beg) .).
+
+(*----------------------------------------------------------------------------*)
+
+NameDecl                      (. VAR
+                                   name, str: CRT.Name; .)
+  = Ident <name> "="
+    ( ident                   (. CRS.GetName(CRS.pos, CRS.len, str) .)
+      | string                (. CRS.GetName(CRS.pos, CRS.len, str);
+                                 FixString(str, CRS.len) .)
+       )                      (. CRT.NewName(name, str) .)
+  ".".
+
+(*----------------------------------------------------------------------------*)
+
+END CR.

CR.frm

@@ -0,0 +1,424 @@
+(* 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.
+
+   JPI version of 27 January 1991 was then modified to make more
+   portable by Pat Terry, January - October 1992
+
+   This is the WinTel version
+
+
+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 DOS 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 -->Grammar;
+
+  FROM -->Scanner IMPORT lst, src, errors, directory, Error, CharAt;
+  FROM -->Parser IMPORT Parse;
+  IMPORT CRC, CRT, CRA, CRP, CRS, CRX, FileIO, Storage;
+  IMPORT SYSTEM (* for TSIZE only *);
+
+  CONST
+    ATGExt = ".atg";
+    LSTExt = ".lst";
+    Version = "1.53";
+    ReleaseDate = "17 September 2002";
+
+  TYPE
+    INT32 = FileIO.INT32;
+
+  VAR
+    Options,
+    GrammarName,
+    ATGFileName,
+    lstFileName: ARRAY [0 .. 63] OF CHAR;
+    ll1:         BOOLEAN; (* TRUE, if grammar is LL(1) *)
+    ok:          BOOLEAN; (* TRUE, if grammar tests ok so far *)
+
+  MODULE ListHandler;
+  (* ------------------- Source Listing and Error handler -------------- *)
+  IMPORT FileIO, Storage, SYSTEM;
+  IMPORT lst, CharAt, 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 # FileIO.CR) & (ch # FileIO.LF) & (ch # FileIO.EOF) DO
+        line[i] := ch; INC(i); ch := CharAt(pos); INC(pos);
+      END;
+      eof := (i = 0) & (ch = FileIO.EOF); line[i] := 0C;
+      IF ch = FileIO.CR THEN (* check for MsDos *)
+        ch := CharAt(pos);
+        IF ch = FileIO.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
+        FileIO.WriteString(lst, s)
+      END Msg;
+
+    PROCEDURE Pointer;
+      VAR
+        i: INTEGER;
+      BEGIN
+        FileIO.WriteString(lst, "*****  ");
+        i := 0;
+        WHILE i < col + Extra - 2 DO
+          IF line[i] = tab
+            THEN FileIO.Write(lst, tab)
+            ELSE FileIO.Write(lst, ' ')
+          END;
+          INC(i)
+        END;
+        FileIO.WriteString(lst, "^ ")
+      END Pointer;
+
+    BEGIN
+      Pointer;
+      CASE nr OF
+      -->Errors
+      | 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: "); FileIO.WriteInt(lst, nr, 1);
+      END;
+      FileIO.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
+      FileIO.WriteString(lst, "Listing:");
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+      srcPos := FileIO.Long0; nextErr := firstErr;
+      GetLine(srcPos, line, eof); lnr := 1; errC := 0;
+      WHILE ~ eof DO
+        FileIO.WriteInt(lst, lnr, 5); FileIO.WriteString(lst, "  ");
+        FileIO.WriteString(lst, line); FileIO.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
+        FileIO.WriteInt(lst, lnr, 5); FileIO.WriteLn(lst);
+        WHILE nextErr # NIL DO
+          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
+          nextErr := nextErr^.next
+        END
+      END;
+      FileIO.WriteLn(lst);
+      FileIO.WriteInt(lst, errC, 5); FileIO.WriteString(lst, " error");
+      IF errC # 1 THEN FileIO.Write(lst, "s") END;
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+    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
+      FileIO.WriteString(FileIO.StdOut, S); FileIO.WriteLn(FileIO.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("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 *)
+    FileIO.WriteString(FileIO.StdOut, "Coco/R (WinTel) - Compiler-Compiler V");
+    FileIO.WriteString(FileIO.StdOut, Version);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "Released by Pat Terry ");
+    FileIO.WriteString(FileIO.StdOut, ReleaseDate);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.NextParameter(GrammarName);
+    IF (GrammarName[0] = "?")
+        OR (GrammarName[0] = "/") AND (GrammarName[1] = "?") THEN
+      Help; FileIO.QuitExecution
+    END;
+    IF GrammarName[0] = 0C THEN
+      FileIO.WriteString(FileIO.StdOut, "(COCOR ? gives short help screen)");
+      FileIO.WriteLn(FileIO.StdOut);
+    END;
+    WHILE (GrammarName[0] = "-") OR (GrammarName[0] = "/") DO
+      (* accept options before filename *)
+      SetOption(GrammarName); FileIO.NextParameter(GrammarName)
+    END;
+    ok := GrammarName[0] # 0C;
+    REPEAT
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "Grammar[.atg] ? : ");
+        FileIO.ReadString(FileIO.StdIn, GrammarName);
+        IF ~ FileIO.Okay THEN FileIO.QuitExecution END;
+        FileIO.ReadLn(FileIO.StdIn);
+      END;
+      FileIO.AppendExtension(GrammarName, ATGExt, ATGFileName);
+      GrammarName := ATGFileName;
+      FileIO.Open(src, GrammarName, FALSE);
+      ok := FileIO.Okay;
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "File <");
+        FileIO.WriteString(FileIO.StdOut, GrammarName);
+        FileIO.WriteString(FileIO.StdOut, "> not found.");
+        FileIO.WriteLn(FileIO.StdOut);
+      END
+    UNTIL ok;
+    FileIO.NextParameter(Options);
+    IF Options[0] # 0C THEN SetOption(Options) END;
+    FileIO.ExtractDirectory(GrammarName, directory);
+    FileIO.ChangeExtension(GrammarName, LSTExt, lstFileName);
+    FileIO.Open(lst, lstFileName, TRUE);
+    FileIO.WriteString(lst, "Coco/R - Compiler-Compiler V");
+    FileIO.WriteString(lst, Version);
+    FileIO.WriteLn(lst);
+    FileIO.WriteString(lst, "Released by Pat Terry ");
+    FileIO.WriteString(lst, ReleaseDate);
+    FileIO.WriteLn(lst);
+    FileIO.WriteString(lst, "Source file: ");
+    FileIO.WriteString(lst, GrammarName);
+    FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "parsing file ");
+    FileIO.WriteString(FileIO.StdOut, GrammarName);
+    FileIO.WriteLn(FileIO.StdOut);
+    CRS.Error := StoreError;
+    CRP.Parse;
+    IF errors = 0 THEN
+      Msg("testing grammar");
+      FileIO.WriteString(lst, "Grammar Tests:");
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+      CRT.CompSymbolSets;
+      CRT.TestCompleteness(ok);
+      IF ok THEN CRT.TestIfAllNtReached(ok) END;
+      IF ok THEN CRT.FindCircularProductions(ok) END;
+      IF ok THEN CRT.TestIfNtToTerm(ok) END;
+      IF ok THEN CRT.LL1Test(ll1) END;
+      FileIO.WriteLn(lst);
+      IF ~ ok OR ~ ll1 OR CRT.ddt["L"] OR CRT.ddt["X"] THEN
+        Msg("listing");
+        PrintListing; IF CRT.ddt["X"] THEN CRT.XRef; END;
+      END;
+      IF CRT.ddt["N"] OR CRT.symNames THEN
+        Msg("symbol name assignment");
+        CRT.AssignSymNames(CRT.ddt["N"], CRT.symNames);
+      END;
+      IF ok AND ~ CRT.ddt["T"] THEN
+        Msg("generating parser");
+        CRX.GenCompiler;
+        IF CRT.genScanner AND ~ CRT.ddt["P"] THEN
+          Msg("generating scanner");
+          CRA.WriteScanner(ok);
+          IF CRT.ddt["A"] THEN CRA.PrintStates END;
+        END;
+        IF CRT.ddt["C"] THEN
+          Msg("generating compiler");
+          CRC.WriteDriver;
+        END;
+        CRX.WriteStatistics;
+      END;
+      IF ~ ok THEN Msg("Compilation ended with errors in grammar tests.");
+        ELSIF ~ ll1 THEN Msg("Compilation ended with LL(1) errors.");
+        ELSE Msg("Compilation completed. No errors detected.");
+      END;
+    ELSE
+      Msg("listing");
+      PrintListing; IF CRT.ddt["X"] THEN CRT.XRef END;
+      Msg("*** errors detected ***");
+    END;
+    IF CRT.ddt["G"] THEN CRT.PrintGraph END;
+    IF CRT.ddt["S"] THEN CRT.PrintSymbolTable END;
+    FileIO.Close(lst); FileIO.Close(src);
+  END -->Grammar.

CR.mod

@@ -0,0 +1,475 @@
+(* 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
+
+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 DOS 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, FileIO, Storage;
+  IMPORT SYSTEM (* for TSIZE only *);
+
+  CONST
+    ATGExt = ".atg";
+    LSTExt = ".lst";
+    Version = "1.53";
+    ReleaseDate = "17 September 2002";
+
+  TYPE
+    INT32 = FileIO.INT32;
+
+  VAR
+    Options,
+    GrammarName,
+    ATGFileName,
+    lstFileName: ARRAY [0 .. 63] OF CHAR;
+    ll1:         BOOLEAN; (* TRUE, if grammar is LL(1) *)
+    ok:          BOOLEAN; (* TRUE, if grammar tests ok so far *)
+
+  MODULE ListHandler;
+  (* ------------------- Source Listing and Error handler -------------- *)
+  IMPORT FileIO, Storage, SYSTEM;
+  IMPORT lst, CharAt, 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 # FileIO.CR) & (ch # FileIO.LF) & (ch # FileIO.EOF) DO
+        line[i] := ch; INC(i); ch := CharAt(pos); INC(pos);
+      END;
+      eof := (i = 0) & (ch = FileIO.EOF); line[i] := 0C;
+      IF ch = FileIO.CR THEN (* check for MsDos *)
+        ch := CharAt(pos);
+        IF ch = FileIO.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
+        FileIO.WriteString(lst, s)
+      END Msg;
+
+    PROCEDURE Pointer;
+      VAR
+        i: INTEGER;
+      BEGIN
+        FileIO.WriteString(lst, "*****  ");
+        i := 0;
+        WHILE i < col + Extra - 2 DO
+          IF line[i] = tab
+            THEN FileIO.Write(lst, tab)
+            ELSE FileIO.Write(lst, ' ')
+          END;
+          INC(i)
+        END;
+        FileIO.WriteString(lst, "^ ")
+      END Pointer;
+
+    BEGIN
+      Pointer;
+      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: "); FileIO.WriteInt(lst, nr, 1);
+      END;
+      FileIO.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
+      FileIO.WriteString(lst, "Listing:");
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+      srcPos := FileIO.Long0; nextErr := firstErr;
+      GetLine(srcPos, line, eof); lnr := 1; errC := 0;
+      WHILE ~ eof DO
+        FileIO.WriteInt(lst, lnr, 5); FileIO.WriteString(lst, "  ");
+        FileIO.WriteString(lst, line); FileIO.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
+        FileIO.WriteInt(lst, lnr, 5); FileIO.WriteLn(lst);
+        WHILE nextErr # NIL DO
+          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
+          nextErr := nextErr^.next
+        END
+      END;
+      FileIO.WriteLn(lst);
+      FileIO.WriteInt(lst, errC, 5); FileIO.WriteString(lst, " error");
+      IF errC # 1 THEN FileIO.Write(lst, "s") END;
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+    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
+      FileIO.WriteString(FileIO.StdOut, S); FileIO.WriteLn(FileIO.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("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 *)
+    FileIO.WriteString(FileIO.StdOut, "Coco/R (WinTel) - Compiler-Compiler V");
+    FileIO.WriteString(FileIO.StdOut, Version);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "Released by Pat Terry ");
+    FileIO.WriteString(FileIO.StdOut, ReleaseDate);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.NextParameter(GrammarName);
+    IF (GrammarName[0] = "?")
+        OR (GrammarName[0] = "/") AND (GrammarName[1] = "?") THEN
+      Help; FileIO.QuitExecution
+    END;
+    IF GrammarName[0] = 0C THEN
+      FileIO.WriteString(FileIO.StdOut, "(COCOR ? gives short help screen)");
+      FileIO.WriteLn(FileIO.StdOut);
+    END;
+    WHILE (GrammarName[0] = "-") OR (GrammarName[0] = "/") DO
+      (* accept options before filename *)
+      SetOption(GrammarName); FileIO.NextParameter(GrammarName)
+    END;
+    ok := GrammarName[0] # 0C;
+    REPEAT
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "Grammar[.atg] ? : ");
+        FileIO.ReadString(FileIO.StdIn, GrammarName);
+        IF ~ FileIO.Okay THEN FileIO.QuitExecution END;
+        FileIO.ReadLn(FileIO.StdIn);
+      END;
+      FileIO.AppendExtension(GrammarName, ATGExt, ATGFileName);
+      GrammarName := ATGFileName;
+      FileIO.Open(src, GrammarName, FALSE);
+      ok := FileIO.Okay;
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "File <");
+        FileIO.WriteString(FileIO.StdOut, GrammarName);
+        FileIO.WriteString(FileIO.StdOut, "> not found.");
+        FileIO.WriteLn(FileIO.StdOut);
+      END
+    UNTIL ok;
+    FileIO.NextParameter(Options);
+    IF Options[0] # 0C THEN SetOption(Options) END;
+    FileIO.ExtractDirectory(GrammarName, directory);
+    FileIO.ChangeExtension(GrammarName, LSTExt, lstFileName);
+    FileIO.Open(lst, lstFileName, TRUE);
+    FileIO.WriteString(lst, "Coco/R - Compiler-Compiler V");
+    FileIO.WriteString(lst, Version);
+    FileIO.WriteLn(lst);
+    FileIO.WriteString(lst, "Released by Pat Terry ");
+    FileIO.WriteString(lst, ReleaseDate);
+    FileIO.WriteLn(lst);
+    FileIO.WriteString(lst, "Source file: ");
+    FileIO.WriteString(lst, GrammarName);
+    FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "parsing file ");
+    FileIO.WriteString(FileIO.StdOut, GrammarName);
+    FileIO.WriteLn(FileIO.StdOut);
+    CRS.Error := StoreError;
+    CRP.Parse;
+    IF errors = 0 THEN
+      Msg("testing grammar");
+      FileIO.WriteString(lst, "Grammar Tests:");
+      FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+      CRT.CompSymbolSets;
+      CRT.TestCompleteness(ok);
+      IF ok THEN CRT.TestIfAllNtReached(ok) END;
+      IF ok THEN CRT.FindCircularProductions(ok) END;
+      IF ok THEN CRT.TestIfNtToTerm(ok) END;
+      IF ok THEN CRT.LL1Test(ll1) END;
+      FileIO.WriteLn(lst);
+      IF ~ ok OR ~ ll1 OR CRT.ddt["L"] OR CRT.ddt["X"] THEN
+        Msg("listing");
+        PrintListing; IF CRT.ddt["X"] THEN CRT.XRef; END;
+      END;
+      IF CRT.ddt["N"] OR CRT.symNames THEN
+        Msg("symbol name assignment");
+        CRT.AssignSymNames(CRT.ddt["N"], CRT.symNames);
+      END;
+      IF ok AND ~ CRT.ddt["T"] THEN
+        Msg("generating parser");
+        CRX.GenCompiler;
+        IF CRT.genScanner AND ~ CRT.ddt["P"] THEN
+          Msg("generating scanner");
+          CRA.WriteScanner(ok);
+          IF CRT.ddt["A"] THEN CRA.PrintStates END;
+        END;
+        IF CRT.ddt["C"] THEN
+          Msg("generating compiler");
+          CRC.WriteDriver;
+        END;
+        CRX.WriteStatistics;
+      END;
+      IF ~ ok THEN Msg("Compilation ended with errors in grammar tests.");
+        ELSIF ~ ll1 THEN Msg("Compilation ended with LL(1) errors.");
+        ELSE Msg("Compilation completed. No errors detected.");
+      END;
+    ELSE
+      Msg("listing");
+      PrintListing; IF CRT.ddt["X"] THEN CRT.XRef END;
+      Msg("*** errors detected ***");
+    END;
+    IF CRT.ddt["G"] THEN CRT.PrintGraph END;
+    IF CRT.ddt["S"] THEN CRT.PrintSymbolTable END;
+    FileIO.Close(lst); FileIO.Close(src);
+  END CR.

CR0.atg

@@ -0,0 +1,85 @@
+$LS (*ACFGILMOSX*)
+(* COCO/R for MS-DOS grammar stripped of semantic attributes
+   as adapted by P.D. Terry, January 1992 *)
+
+COMPILER CR
+
+CHARACTERS
+
+  letter   = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_".
+  digit    = "0123456789".
+  ctrl     = CHR(1) .. CHR(31).
+  tab      = CHR(9).
+  eol      = CHR(13).
+  lf       = CHR(10).
+  noQuote1 = ANY - '"' - ctrl.
+  noQuote2 = ANY - "'" - ctrl.
+
+IGNORE tab + eol + lf
+
+TOKENS
+
+  ident   = letter {letter | digit} .
+  string  = '"' {noQuote1} '"' | "'" {noQuote2} "'" .
+  number  = digit {digit} .
+
+PRAGMAS
+
+  Options = "$" {letter} .
+
+COMMENTS FROM "(*" TO "*)" NESTED
+COMMENTS FROM "/*" TO "*/"
+
+PRODUCTIONS
+
+CR = "COMPILER" Ident { ANY } { Declaration }
+     SYNC "PRODUCTIONS"
+     { Ident ( Attribs | ) [ SemText ] WEAK "=" Expression WEAK "." }
+     "END" Ident "." .
+
+Declaration =
+      "CHARACTERS" { SetDecl }
+    | "TOKENS"     { TokenDecl }
+    | "NAMES"      { NameDecl }
+    | "PRAGMAS"    { TokenDecl }
+    | "COMMENTS" "FROM" TokenExpr "TO" TokenExpr ( "NESTED" | )
+    | "IGNORE" ( "CASE" | Set ) .
+
+SetDecl = Ident "=" Set "." .
+
+Set = SimSet { "+" SimSet | "-" SimSet } .
+
+SimSet = Ident | string | SingleChar [ ".." SingleChar ] | "ANY" .
+
+SingleChar = "CHR" "(" number | string ")" .
+
+TokenDecl = Symbol SYNC ( "=" TokenExpr "." | ) [ SemText ] .
+
+Expression = Term { WEAK "|" Term } .
+
+Term = ( Factor { Factor } | ) .
+
+Factor = ( [ "WEAK" ] Symbol ( Attribs | )
+           | "(" Expression ")"
+           | "[" Expression "]"
+           | "{" Expression "}"
+           | SemText | "ANY" | "SYNC" ) .
+
+TokenExpr = TokenTerm { WEAK "|" TokenTerm } .
+
+TokenTerm = TokenFactor { TokenFactor } [ "CONTEXT" "(" TokenExpr ")" ] .
+
+TokenFactor = ( Symbol | "(" TokenExpr ")" | "[" TokenExpr "]"
+                | "{" TokenExpr "}" ) .
+
+Ident = ident .
+
+Symbol = ( Ident | string ) .
+
+Attribs = "<" { ANY } ">" .
+
+SemText = "(." { ANY } ".)" .
+
+NameDecl = Ident  "=" ( ident | string ) "." .
+
+END CR.

CRA.def

@@ -0,0 +1,43 @@
+DEFINITION MODULE CRA;
+(* Automaton and Scanner Generation *)
+
+IMPORT FileIO;
+
+CONST
+  MaxSourceLineLength = 78;
+
+TYPE
+  PutSProc = PROCEDURE (ARRAY OF CHAR);
+
+PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR; VAR leftMarg: CARDINAL;
+                         VAR framIn, framOut: FileIO.File);
+(* "stopStr" must not contain "FileIO.EOL".
+   "leftMarg" is in/out-parameter  --  it has to be set once by the
+   calling program.    *)
+
+PROCEDURE ImportSymConsts (putS: PutSProc);
+(* Generates the import list for the eventually existing named constants. *)
+
+PROCEDURE ConvertToStates (gp, sp: INTEGER);
+(* Converts top-down graph with root gp into a subautomaton that
+   recognizes token sp *)
+
+PROCEDURE MatchDFA (s: ARRAY OF CHAR; sp: INTEGER; VAR matchedSp: INTEGER);
+(* Returns TRUE, if string s can be recognized by the current DFA.
+   matchedSp is the token as that s can be recognized. *)
+
+PROCEDURE MakeDeterministic (VAR ok: BOOLEAN);
+(* Converts the NFA into a DFA. ok indicates if an error occurred. *)
+
+PROCEDURE NewComment (from, to: INTEGER; nested: BOOLEAN);
+(* Defines a new comment for the scanner. The comment brackets are
+   represented by the mini top-down graphs with the roots from and to. *)
+
+PROCEDURE WriteScanner (VAR ok: BOOLEAN);
+(* Emits the source code of the generated scanner using the frame file
+   scanner.frm *)
+
+PROCEDURE PrintStates;
+(* List the automaton for tracing *)
+
+END CRA.

CRA.mod

@@ -0,0 +1,1347 @@
+IMPLEMENTATION MODULE CRA;
+
+(* CRA     Automaton and Scanner Generation
+   ===     ================================
+
+  (1) ConvertToStates translates a top-down graph into a NFA.
+      MatchDFA tries to match literal strings against the DFA
+  (2) MakeDeterministic converts the NFA into a DFA
+  (3) WriteScanner generates the scanner source file
+
+  ----------------------------------------------------------------*)
+
+(* IMPORT ProgArgs; for gpm version *)
+
+IMPORT CRS, CRT, FileIO, Sets, Storage;
+IMPORT SYSTEM (* for TSIZE only *);
+
+CONST
+  maxStates = 500;
+  cr = 15C;
+
+TYPE
+  Action     = POINTER TO ActionNode;
+  Target     = POINTER TO TargetNode;
+
+  State = RECORD          (* state of finite automaton *)
+    firstAction: Action;  (* to first action of this state *)
+    endOf:       INTEGER; (* nr. of recognized token if state is final *)
+    ctx:         BOOLEAN; (* TRUE: state reached by contextTrans *)
+  END;
+  ActionNode = RECORD     (* action of finite automaton *)
+    typ:    INTEGER;      (* type of action symbol: char, class *)
+    sym:    INTEGER;      (* action symbol *)
+    tc:     INTEGER;      (* transition code: normTrans, contextTrans *)
+    target: Target;       (* states after transition with input symbol *)
+    next:   Action;
+  END;
+  TargetNode = RECORD     (* state after transition with input symbol *)
+    state:  INTEGER;      (* target state *)
+    next:   Target;
+  END;
+
+  Comment    = POINTER TO CommentNode;
+  CommentNode = RECORD    (* info about a comment syntax *)
+    start,stop: ARRAY [0 .. 1] OF CHAR;
+    nested:     BOOLEAN;
+    next:       Comment;
+  END;
+
+  Melted     = POINTER TO MeltedNode;
+  MeltedNode = RECORD     (* info about melted states *)
+    set:   CRT.Set;       (* set of old states *)
+    state: INTEGER;       (* new state *)
+    next:  Melted;
+  END;
+
+VAR
+  state:         ARRAY [0 .. maxStates] OF State;
+  lastSimState:  INTEGER;     (* last non melted state *)
+  lastState:     INTEGER;     (* last allocated state  *)
+  rootState:     INTEGER;     (* start state of DFA    *)
+  firstMelted:   Melted;      (* list of melted states *)
+  firstComment:  Comment;     (* list of comments      *)
+  scanner,                    (* generated scanner *)
+  out:           FileIO.File; (* current output file   *)
+  fram:          FileIO.File; (* scanner frame         *)
+  dirtyDFA,                   (* DFA may become non-deterministic *)
+  NewLine:       BOOLEAN;
+
+PROCEDURE SemErr (nr: INTEGER);
+  BEGIN
+    CRS.Error(nr + 100, CRS.line, CRS.col, CRS.pos)
+  END SemErr;
+
+PROCEDURE Put (ch: CHAR);
+  BEGIN
+    FileIO.Write(out, ch)
+  END Put;
+
+PROCEDURE PutLn;
+  BEGIN
+    FileIO.WriteLn(out)
+  END PutLn;
+
+PROCEDURE PutB (n: INTEGER);
+  BEGIN
+    FileIO.WriteText(out, "", n);
+  END PutB;
+
+PROCEDURE Indent (n: INTEGER);
+  BEGIN
+    IF NewLine THEN PutB(n) ELSE NewLine := TRUE END;
+  END Indent;
+
+PROCEDURE PutS (s: ARRAY OF CHAR);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE (i <= HIGH(s)) & (s[i] # 0C) DO
+      IF s[i] = "$"
+        THEN FileIO.WriteLn(out)
+        ELSE FileIO.Write(out, s[i])
+      END;
+      INC(i)
+    END
+  END PutS;
+
+PROCEDURE PutI (i: INTEGER);
+  BEGIN
+    FileIO.WriteInt(out, i, 1)
+  END PutI;
+
+PROCEDURE PutI2 (i, n: INTEGER);
+  BEGIN
+    FileIO.WriteInt(out, i, n)
+  END PutI2;
+
+PROCEDURE PutC (ch: CHAR);
+  BEGIN
+    CASE ch OF
+      0C .. 37C, 177C .. 377C :
+         PutS("CHR("); PutI(ORD(ch)); Put(")")
+    | '"' :
+         Put("'"); Put(ch); Put("'")
+    ELSE Put('"'); Put(ch); Put('"')
+    END
+  END PutC;
+
+PROCEDURE PutSN (i: INTEGER);
+  VAR
+    sn: CRT.SymbolNode;
+  BEGIN
+    CRT.GetSym(i, sn);
+    IF FileIO.SLENGTH(sn.constant) > 0 THEN
+      PutS(sn.constant);
+    ELSE
+      PutI(i);
+    END;
+  END PutSN;
+
+PROCEDURE PutSE (i: INTEGER);
+  BEGIN
+    PutS("sym := "); PutSN(i); PutS("; ");
+  END PutSE;
+
+PROCEDURE PutRange (s: CRT.Set; indent:CARDINAL);
+  VAR
+    lo, hi: ARRAY [0 .. 31] OF CHAR;
+    top, i: INTEGER;
+    s1: CRT.Set;
+  BEGIN
+    (*----- fill lo and hi *)
+    top := -1; i := 0;
+    WHILE i < 256 (*PDT*) DO
+      IF Sets.In(s, i) THEN
+        INC(top); lo[top] := CHR(i); INC(i);
+        WHILE (i < 256 (*PDT*) ) & Sets.In(s, i) DO INC(i) END;
+        hi[top] := CHR(i - 1)
+      ELSE INC(i)
+      END
+    END;
+    (*----- print ranges *)
+    IF (top = 1) & (lo[0] = 0C) & (hi[1] = 377C (*PDT*))
+        & (CHR(ORD(hi[0]) + 2) = lo[1]) THEN
+      Sets.Fill(s1); Sets.Differ(s1, s);
+      PutS("~ "); PutRange(s1, indent);
+    ELSE
+      PutS("(");
+      i := 0;
+      WHILE i <= top DO
+        IF hi[i] = lo[i] THEN   PutS("(ch = "); PutC(lo[i])
+          ELSIF lo[i] = 0C THEN PutS("(ch <= "); PutC(hi[i])
+          ELSIF hi[i] = 377C (*PDT*) THEN PutS("(ch >= "); PutC(lo[i])
+          ELSE PutS("(ch >= "); PutC(lo[i]); PutS(") & (ch <= ");
+               PutC(hi[i])
+        END;
+        Put(")");
+        IF i < top THEN PutS(" OR$"); PutB(indent) END;
+        INC(i)
+      END;
+      PutS(")");
+    END
+  END PutRange;
+
+PROCEDURE PutChCond (ch: CHAR);
+  BEGIN
+    PutS("(ch = "); PutC(ch); Put(")")
+  END PutChCond;
+
+(* PrintSymbol          Print a symbol for tracing
+-------------------------------------------------------------------------*)
+PROCEDURE PrintSymbol (typ, val, width: INTEGER);
+  VAR
+    name: CRT.Name;
+    len: INTEGER;
+  BEGIN
+    IF typ = CRT.class THEN
+      CRT.GetClassName(val, name); PutS(name);
+      len := FileIO.SLENGTH(name)
+    ELSIF (val >= VAL(INTEGER, ORD(" "))) & (val < 127) & (val # 34) THEN
+      Put('"'); Put(CHR(val)); Put('"'); len := 3
+    ELSE
+      PutS("CHR("); PutI2(val, 2); Put(")"); len := 7
+    END;
+    WHILE len < width DO Put(" "); INC(len) END
+  END PrintSymbol;
+
+(* PrintStates          List the automaton for tracing
+-------------------------------------------------------------------------*)
+PROCEDURE PrintStates;
+  VAR
+    action: Action;
+    first: BOOLEAN;
+    s, i: INTEGER;
+    targ: Target;
+    set: CRT.Set;
+    name: CRT.Name;
+  BEGIN
+    out := CRS.lst;
+    PutS("$-------- states ---------$");
+    s := rootState;
+    WHILE s <= lastState DO
+      action := state[s].firstAction; first := TRUE;
+      IF state[s].endOf = CRT.noSym THEN PutS("     ")
+      ELSE PutS("E("); PutI2(state[s].endOf, 2); Put(")")
+      END;
+      PutI2(s, 3); Put(":"); IF action = NIL THEN PutS(" $") END;
+      WHILE action # NIL DO
+        IF first
+          THEN Put(" "); first := FALSE
+          ELSE PutS("          ")
+        END;
+        PrintSymbol(action^.typ, action^.sym, 0); Put(" ");
+        targ := action^.target;
+        WHILE targ # NIL DO
+          PutI(targ^.state); Put(" "); targ := targ^.next;
+        END;
+        IF action^.tc = CRT.contextTrans
+          THEN PutS(" context$")
+          ELSE PutS(" $")
+        END;
+        action := action^.next
+      END;
+      INC(s)
+    END;
+    PutS("$-------- character classes ---------$");
+    i := 0;
+    WHILE i <= CRT.maxC DO
+      CRT.GetClass(i, set); CRT.GetClassName(i, name);
+      FileIO.WriteText(out, name, 10);
+      FileIO.WriteString(out, ": "); Sets.Print(out, set, 80, 13);
+      FileIO.WriteLn(out);
+      INC(i)
+    END
+  END PrintStates;
+
+(* AddAction            Add a action to the action list of a state
+------------------------------------------------------------------------*)
+PROCEDURE AddAction (act: Action; VAR head: Action);
+  VAR
+    a,lasta: Action;
+  BEGIN
+    a := head; lasta := NIL;
+    LOOP
+      IF (a = NIL) OR (act^.typ < a^.typ) THEN
+        (*collecting classes at the front improves performance*)
+        act^.next := a;
+        IF lasta = NIL THEN head := act ELSE lasta^.next := act END;
+        EXIT;
+      END;
+      lasta := a; a := a^.next;
+    END;
+  END AddAction;
+
+(* DetachAction         Detach action a from list L
+------------------------------------------------------------------------*)
+PROCEDURE DetachAction (a: Action; VAR L: Action);
+  BEGIN
+    IF L = a THEN L := a^.next
+      ELSIF L # NIL THEN DetachAction(a, L^.next)
+    END
+  END DetachAction;
+
+PROCEDURE TheAction (state: State; ch: CHAR): Action;
+  VAR
+    a: Action;
+    set: CRT.Set;
+  BEGIN
+    a := state.firstAction;
+    WHILE a # NIL DO
+      IF a^.typ = CRT.char THEN
+        IF VAL(INTEGER, ORD(ch)) = a^.sym THEN RETURN a END
+      ELSIF a^.typ = CRT.class THEN
+        CRT.GetClass(a^.sym, set);
+        IF Sets.In(set, ORD(ch)) THEN RETURN a END
+      END;
+      a := a^.next
+    END;
+    RETURN NIL
+  END TheAction;
+
+PROCEDURE AddTargetList (VAR lista, listb: Target);
+  VAR
+    p,t: Target;
+
+  PROCEDURE AddTarget (t: Target; VAR list: Target);
+    VAR
+      p,lastp: Target;
+    BEGIN
+      p := list; lastp := NIL;
+      LOOP
+        IF (p = NIL) OR (t^.state < p^.state) THEN EXIT END;
+        IF p^.state = t^.state THEN
+          Storage.DEALLOCATE(t, SYSTEM.TSIZE(TargetNode)); RETURN
+        END;
+        lastp := p; p := p^.next
+      END;
+      t^.next := p;
+      IF lastp=NIL THEN list := t ELSE lastp^.next := t END
+    END AddTarget;
+
+  BEGIN
+    p := lista;
+    WHILE p # NIL DO
+      Storage.ALLOCATE(t, SYSTEM.TSIZE(TargetNode));
+      t^.state := p^.state; AddTarget(t, listb);
+      p := p^.next
+    END
+  END AddTargetList;
+
+(* NewMelted            Generate new info about a melted state
+------------------------------------------------------------------------*)
+PROCEDURE NewMelted (set: CRT.Set; s: INTEGER): Melted;
+  VAR
+    melt: Melted;
+  BEGIN
+    Storage.ALLOCATE(melt, SYSTEM.TSIZE(MeltedNode));
+    melt^.set := set; melt^.state := s;
+    melt^.next := firstMelted; firstMelted := melt;
+    RETURN melt
+  END NewMelted;
+
+(* NewState             Return a new state node
+------------------------------------------------------------------------*)
+PROCEDURE NewState (): INTEGER;
+  BEGIN
+    INC(lastState);
+    IF lastState > maxStates THEN CRT.Restriction(7, maxStates) END;
+    state[lastState].firstAction := NIL;
+    state[lastState].endOf := CRT.noSym;
+    state[lastState].ctx := FALSE;
+    RETURN lastState
+  END NewState;
+
+(* NewTransition        Generate transition (gn.state, gn.p1) --> toState
+------------------------------------------------------------------------*)
+PROCEDURE NewTransition (from: INTEGER; gn: CRT.GraphNode;
+                         toState: INTEGER);
+  VAR
+    a: Action;
+    t: Target;
+  BEGIN
+    IF toState = rootState THEN SemErr(21) END;
+    Storage.ALLOCATE(t, SYSTEM.TSIZE(TargetNode));
+    t^.state := toState; t^.next := NIL;
+    Storage.ALLOCATE(a, SYSTEM.TSIZE(ActionNode));
+    a^.typ := gn.typ; a^.sym := gn.p1; a^.tc := gn.p2;
+    a^.target := t;
+    AddAction(a, state[from].firstAction)
+  END NewTransition;
+
+(* NewComment           Define new comment
+-------------------------------------------------------------------------*)
+PROCEDURE NewComment (from, to: INTEGER; nested: BOOLEAN);
+  VAR
+    com: Comment;
+
+  PROCEDURE MakeStr (gp: INTEGER; VAR s: ARRAY OF CHAR);
+    VAR
+      i, n: INTEGER;
+      gn: CRT.GraphNode;
+      set: CRT.Set;
+    BEGIN
+      i := 0;
+      WHILE gp # 0 DO
+        CRT.GetNode(gp, gn);
+        IF gn.typ = CRT.char THEN
+          IF i < 2 THEN s[i] := CHR(gn.p1) END; INC(i)
+        ELSIF gn.typ = CRT.class THEN
+          CRT.GetClass(gn.p1, set);
+          IF Sets.Elements(set, n) # 1 THEN SemErr(26) END;
+          IF i < 2 THEN s[i] := CHR(n) END; INC(i)
+        ELSE SemErr(22)
+        END;
+        gp := gn.next
+      END;
+      IF (i = 0) OR (i > 2) THEN SemErr(25) ELSIF i < 2 THEN s[i] := 0C END
+    END MakeStr;
+
+  BEGIN
+    Storage.ALLOCATE(com, SYSTEM.TSIZE(CommentNode));
+    MakeStr(from, com^.start); MakeStr(to, com^.stop);
+    com^.nested := nested;
+    com^.next := firstComment; firstComment := com
+  END NewComment;
+
+(* DeleteTargetList     Delete a target list
+-------------------------------------------------------------------------*)
+PROCEDURE DeleteTargetList (list: Target);
+  BEGIN
+    IF list # NIL THEN
+      DeleteTargetList(list^.next);
+      Storage.DEALLOCATE(list, SYSTEM.TSIZE(TargetNode))
+    END;
+  END DeleteTargetList;
+
+(* DeleteActionList     Delete an action list
+-------------------------------------------------------------------------*)
+PROCEDURE DeleteActionList (action: Action);
+  BEGIN
+    IF action # NIL THEN
+      DeleteActionList(action^.next);
+      DeleteTargetList(action^.target);
+      Storage.DEALLOCATE(action, SYSTEM.TSIZE(ActionNode))
+    END
+  END DeleteActionList;
+
+(* MakeSet              Expand action symbol into symbol set
+-------------------------------------------------------------------------*)
+PROCEDURE MakeSet (p: Action; VAR set: CRT.Set);
+  BEGIN
+    IF p^.typ = CRT.class THEN
+    CRT.GetClass(p^.sym, set)
+    ELSE Sets.Clear(set); Sets.Incl(set, p^.sym)
+    END
+  END MakeSet;
+
+(* ChangeAction         Change the action symbol to set
+-------------------------------------------------------------------------*)
+PROCEDURE ChangeAction (a: Action; set: CRT.Set);
+  VAR
+    nr: INTEGER;
+  BEGIN
+    IF Sets.Elements(set, nr) = 1 THEN a^.typ := CRT.char; a^.sym := nr
+    ELSE
+      nr := CRT.ClassWithSet(set);
+      IF nr < 0 THEN nr := CRT.NewClass("##", set) END;
+      a^.typ := CRT.class; a^.sym := nr
+    END
+  END ChangeAction;
+
+(* CombineShifts     Combine shifts with different symbols into same state
+-------------------------------------------------------------------------*)
+PROCEDURE CombineShifts;
+  VAR
+    s: INTEGER;
+    a, b, c: Action;
+    seta, setb: CRT.Set;
+  BEGIN
+    s := rootState;
+    WHILE s <= lastState DO
+      a := state[s].firstAction;
+      WHILE a # NIL DO
+        b := a^.next;
+        WHILE b # NIL DO
+          IF (a^.target^.state = b^.target^.state) & (a^.tc = b^.tc) THEN
+            MakeSet(a, seta); MakeSet(b, setb); Sets.Unite(seta, setb);
+            ChangeAction(a, seta);
+            c := b; b := b^.next; DetachAction(c, a)
+          ELSE b := b^.next
+          END
+        END;
+        a := a^.next
+      END;
+      INC(s)
+    END
+  END CombineShifts;
+
+(* DeleteRedundantStates   Delete unused and equal states
+-------------------------------------------------------------------------*)
+PROCEDURE DeleteRedundantStates;
+  VAR
+    action: Action;
+    s, s2, next: INTEGER;
+    used: ARRAY [0 .. maxStates DIV Sets.size] OF BITSET (*KJG*);
+    newStateNr: ARRAY [0 .. maxStates] OF INTEGER;
+
+  PROCEDURE FindUsedStates (s: INTEGER);
+    VAR
+      action: Action;
+    BEGIN
+      IF Sets.In(used, s) THEN RETURN END;
+      Sets.Incl(used, s);
+      action := state[s].firstAction;
+      WHILE action # NIL DO
+        FindUsedStates(action^.target^.state);
+        action := action^.next
+      END
+    END FindUsedStates;
+
+  BEGIN
+    Sets.Clear(used); FindUsedStates(rootState);
+    (*---------- combine equal final states ------------*)
+    s := rootState + 1; (*root state cannot be final*)
+    WHILE s <= lastState DO
+      IF Sets.In(used, s) & (state[s].endOf # CRT.noSym) THEN
+        IF (state[s].firstAction = NIL) & ~ state[s].ctx THEN
+          s2 := s + 1;
+          WHILE s2 <= lastState DO
+            IF Sets.In(used, s2) & (state[s].endOf = state[s2].endOf) THEN
+              IF (state[s2].firstAction = NIL) AND ~ state[s2].ctx THEN
+                Sets.Excl(used, s2); newStateNr[s2] := s
+              END
+            END;
+            INC(s2)
+          END
+        END
+      END;
+      INC(s)
+    END;
+    s := rootState;
+    (* + 1 ?  PDT - was rootState, but Oberon had .next ie +1
+                    seems to work both ways?? *);
+    WHILE s <= lastState DO
+      IF Sets.In(used, s) THEN
+        action := state[s].firstAction;
+        WHILE action # NIL DO
+          IF ~ Sets.In(used, action^.target^.state) THEN
+            action^.target^.state := newStateNr[action^.target^.state]
+          END;
+          action := action^.next
+        END
+      END;
+      INC(s)
+    END;
+    (*-------- delete unused states --------*)
+    s := rootState + 1; next := s;
+    WHILE s <= lastState DO
+      IF Sets.In(used, s) THEN
+        IF next < s THEN state[next] := state[s] END;
+        newStateNr[s] := next; INC(next)
+      ELSE
+        DeleteActionList(state[s].firstAction)
+      END;
+      INC(s)
+    END;
+    lastState := next - 1;
+    s := rootState;
+    WHILE s <= lastState DO
+      action := state[s].firstAction;
+      WHILE action # NIL DO
+        action^.target^.state := newStateNr[action^.target^.state];
+        action := action^.next
+      END;
+      INC(s)
+    END
+  END DeleteRedundantStates;
+
+(* ConvertToStates    Convert the TDG in gp into a subautomaton of the DFA
+------------------------------------------------------------------------*)
+PROCEDURE ConvertToStates (gp0, sp: INTEGER);
+(*note: gn.line is abused as a state number!*)
+
+  VAR
+    stepped, visited: CRT.MarkList;
+
+  PROCEDURE NumberNodes (gp, snr: INTEGER);
+    VAR
+      gn: CRT.GraphNode;
+    BEGIN
+      IF gp = 0 THEN RETURN END; (*end of graph*)
+      CRT.GetNode(gp, gn);
+      IF gn.line >= 0 THEN RETURN END;  (*already visited*)
+      IF snr < rootState THEN snr := NewState() END;
+      gn.line := snr; CRT.PutNode(gp, gn);
+      IF CRT.DelGraph(gp) THEN state[snr].endOf := sp END;
+      (*snr is end state*)
+      CASE gn.typ OF
+        CRT.class, CRT.char:
+          NumberNodes(ABS(gn.next), rootState - 1);
+      | CRT.opt:
+          NumberNodes(ABS(gn.next), rootState - 1); NumberNodes(gn.p1, snr)
+      | CRT.iter:
+          NumberNodes(ABS(gn.next), snr); NumberNodes(gn.p1, snr)
+      | CRT.alt:
+          NumberNodes(gn.p1, snr); NumberNodes(gn.p2, snr)
+      END;
+    END NumberNodes;
+
+  PROCEDURE TheState (gp: INTEGER): INTEGER;
+    VAR
+      s: INTEGER;
+      gn: CRT.GraphNode;
+    BEGIN
+      IF gp = 0 THEN s := NewState(); state[s].endOf := sp; RETURN s
+      ELSE CRT.GetNode(gp, gn); RETURN gn.line
+      END
+    END TheState;
+
+  PROCEDURE Step (from, gp: INTEGER);
+    VAR
+      gn: CRT.GraphNode;
+      next : INTEGER;
+    BEGIN
+      IF gp = 0 THEN RETURN END;
+      Sets.Incl(stepped, gp);
+      CRT.GetNode(gp, gn);
+      CASE gn.typ OF
+        CRT.class, CRT.char:
+          NewTransition(from, gn, TheState(ABS(gn.next)))
+      | CRT.alt:
+          Step(from, gn.p1); Step(from, gn.p2)
+      | CRT.opt, CRT.iter:
+          next := ABS(gn.next);
+          IF NOT Sets.In(stepped, next) THEN Step(from, next) END;
+          Step(from, gn.p1)
+      END
+    END Step;
+
+  PROCEDURE FindTrans (gp: INTEGER; start: BOOLEAN);
+    VAR
+      gn: CRT.GraphNode;
+    BEGIN
+      IF (gp = 0) OR Sets.In(visited, gp) THEN RETURN END;
+      Sets.Incl(visited, gp); CRT.GetNode(gp, gn);
+      IF start THEN (* start of group of equally numbered nodes *)
+        CRT.ClearMarkList(stepped);
+        Step(gn.line, gp)
+      END; 
+      CASE gn.typ OF
+        CRT.class, CRT.char:
+          FindTrans(ABS(gn.next), TRUE);
+      | CRT.opt:
+          FindTrans(ABS(gn.next), TRUE); FindTrans(gn.p1, FALSE)
+      | CRT.iter:
+          FindTrans(ABS(gn.next), FALSE); FindTrans(gn.p1, FALSE)
+      | CRT.alt:
+          FindTrans(gn.p1, FALSE); FindTrans(gn.p2, FALSE)
+      END;
+    END FindTrans;
+
+  VAR
+    gn: CRT.GraphNode;
+    i: INTEGER;
+  BEGIN
+    IF CRT.DelGraph(gp0) THEN SemErr(20) END;
+    FOR i := 0 TO CRT.nNodes DO
+      CRT.GetNode(i, gn); gn.line := -1; CRT.PutNode(i, gn)
+    END;
+    NumberNodes(gp0, rootState);
+    CRT.ClearMarkList(visited);
+    FindTrans(gp0, TRUE)
+  END ConvertToStates;
+
+  PROCEDURE MatchDFA (str: ARRAY OF CHAR; sp: INTEGER;
+                      VAR matchedSp: INTEGER);
+    VAR
+      s, to: INTEGER (* State *);
+      a: Action;
+      gn: CRT.GraphNode;
+      i, len: INTEGER;
+      weakMatch: BOOLEAN;
+    BEGIN (* s with quotes *)
+      s := rootState; i := 1; len := FileIO.SLENGTH(str) - 1;
+      weakMatch := FALSE;
+      LOOP (* try to match str against existing DFA *)
+        IF i = len THEN EXIT END;
+        a := TheAction(state[s], str[i]);
+        IF a = NIL THEN EXIT END;
+        IF a^.typ = CRT.class THEN weakMatch := TRUE END;
+        s := a^.target^.state; INC(i)
+      END;
+      IF weakMatch & ((i # len) OR (state[s].endOf = CRT.noSym)) THEN
+        s := rootState; i := 1; dirtyDFA := TRUE
+      END;
+      WHILE i < len DO (* make new DFA for str[i..len-1] *)
+        to := NewState();
+        gn.typ := CRT.char; gn.p1 := ORD(str[i]); gn.p2 := CRT.normTrans;
+        NewTransition(s, gn, to); (* PDT Tue  01-11-94 *)
+        s := to; INC(i)
+      END;
+      matchedSp := state[s].endOf;
+      IF state[s].endOf = CRT.noSym THEN state[s].endOf := sp END
+    END MatchDFA;
+
+(* SplitActions     Generate unique actions from two overlapping actions
+-----------------------------------------------------------------------*)
+PROCEDURE SplitActions (a, b: Action);
+  VAR
+    c: Action;
+    seta, setb, setc: CRT.Set;
+
+  PROCEDURE CombineTransCodes (t1, t2: INTEGER; VAR result: INTEGER);
+    BEGIN
+      IF t1 = CRT.contextTrans THEN result := t1 ELSE result := t2 END
+    END CombineTransCodes;
+
+  BEGIN
+    MakeSet(a, seta); MakeSet(b, setb);
+    IF Sets.Equal(seta, setb) THEN
+      AddTargetList(b^.target, a^.target);
+      DeleteTargetList(b^.target);
+      CombineTransCodes(a^.tc, b^.tc, a^.tc);
+      DetachAction(b, a);
+      Storage.DEALLOCATE(b, SYSTEM.TSIZE(ActionNode))
+    ELSIF Sets.Includes(seta, setb) THEN
+      setc := seta; Sets.Differ(setc, setb);
+      AddTargetList(a^.target, b^.target);
+      CombineTransCodes(a^.tc, b^.tc, b^.tc);
+      ChangeAction(a, setc)
+    ELSIF Sets.Includes(setb, seta) THEN
+      setc := setb; Sets.Differ(setc, seta);
+      AddTargetList(b^.target, a^.target);
+      CombineTransCodes(a^.tc, b^.tc, a^.tc);
+      ChangeAction(b, setc)
+    ELSE
+      Sets.Intersect(seta, setb, setc);
+      Sets.Differ(seta, setc);
+      Sets.Differ(setb, setc);
+      ChangeAction(a, seta);
+      ChangeAction(b, setb);
+      Storage.ALLOCATE(c, SYSTEM.TSIZE(ActionNode));
+      c^.target := NIL;
+      CombineTransCodes(a^.tc, b^.tc, c^.tc);
+      AddTargetList(a^.target, c^.target);
+      AddTargetList(b^.target, c^.target);
+      ChangeAction(c, setc);
+      AddAction(c, a)
+    END
+  END SplitActions;
+
+(* MakeUnique           Make all actions in this state unique
+-------------------------------------------------------------------------*)
+PROCEDURE MakeUnique (s: INTEGER; VAR changed: BOOLEAN);
+  VAR
+    a, b: Action;
+
+  PROCEDURE Overlap (a, b: Action): BOOLEAN;
+    VAR
+      seta, setb: CRT.Set;
+    BEGIN
+      IF a^.typ = CRT.char THEN
+        IF b^.typ = CRT.char
+          THEN RETURN a^.sym = b^.sym
+          ELSE CRT.GetClass(b^.sym, setb); RETURN Sets.In(setb, a^.sym)
+        END
+      ELSE
+        CRT.GetClass(a^.sym, seta);
+        IF b^.typ = CRT.char
+          THEN RETURN Sets.In(seta, b^.sym)
+          ELSE CRT.GetClass(b^.sym, setb);
+               RETURN ~ Sets.Different(seta, setb)
+        END
+      END
+    END Overlap;
+
+  BEGIN
+    a := state[s].firstAction; changed := FALSE;
+    WHILE a # NIL DO
+      b := a^.next;
+      WHILE b # NIL DO
+        IF Overlap(a, b) THEN
+          SplitActions(a, b); changed := TRUE; RETURN
+          (* originally no RETURN.  FST blows up if we leave RETURN out.
+             Somewhere there is a field that is not properly set, but I
+             have not chased this down completely Fri  08-20-1993 *)
+        END;
+        b := b^.next;
+      END;
+      a := a^.next
+    END;
+  END MakeUnique;
+
+(* MeltStates       Melt states appearing with a shift of the same symbol
+-----------------------------------------------------------------------*)
+PROCEDURE MeltStates (s: INTEGER; VAR correct: BOOLEAN);
+  VAR
+    action: Action;
+    ctx: BOOLEAN;
+    endOf: INTEGER;
+    melt: Melted;
+    set: CRT.Set;
+    s1: INTEGER;
+    changed: BOOLEAN;
+
+  PROCEDURE AddMeltedSet (nr: INTEGER; VAR set: CRT.Set);
+    VAR
+      m: Melted;
+    BEGIN
+      m := firstMelted;
+      WHILE (m # NIL) & (m^.state # nr) DO m := m^.next END;
+      IF m = NIL THEN CRT.Restriction(-1, 0) (* compiler error *) END;
+      Sets.Unite(set, m^.set);
+    END AddMeltedSet;
+
+  PROCEDURE GetStateSet (t: Target; VAR set: CRT.Set; VAR endOf: INTEGER;
+                         VAR ctx: BOOLEAN);
+  (* Modified back to match Oberon version Fri  08-20-1993
+     This seemed to cause problems with some larger automata *)
+     (* new bug fix Wed  11-24-1993  from ETHZ incorporated *)
+    VAR
+      lastS: INTEGER;
+    BEGIN
+      Sets.Clear(set); endOf := CRT.noSym; ctx := FALSE;
+      lastS := lastState; (* Fri  08-20-1993 *)
+      WHILE t # NIL DO
+        IF t^.state <= lastSimState THEN Sets.Incl(set, t^.state);
+        ELSE AddMeltedSet(t^.state, set);
+        END;
+        IF state[t^.state].endOf # CRT.noSym THEN
+          IF (endOf = CRT.noSym) OR (endOf = state[t^.state].endOf) THEN
+             endOf := state[t^.state].endOf; lastS := t^.state
+          ELSE
+            PutS("$Tokens "); PutI(endOf); PutS(" and ");
+            PutI(state[t^.state].endOf);
+            PutS(" cannot be distinguished.$");
+            correct := FALSE;
+          END;
+        END;
+        IF state[t^.state].ctx THEN
+          ctx := TRUE;
+(* removed this test Fri  08-30-02
+          IF state[t^.state].endOf # CRT.noSym THEN
+            PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
+          END
+*)
+        END;
+        t := t^.next
+      END
+    END GetStateSet;
+
+  PROCEDURE FillWithActions (s: INTEGER; targ: Target);
+    VAR
+      action, a: Action;
+    BEGIN
+      WHILE targ # NIL DO
+        action := state[targ^.state].firstAction;
+        WHILE action # NIL DO
+          Storage.ALLOCATE(a, SYSTEM.TSIZE(ActionNode));
+          a^ := action^; a^.target := NIL;
+          AddTargetList(action^.target, a^.target);
+          AddAction(a, state[s].firstAction);
+          action := action^.next
+        END;
+        targ := targ^.next
+      END;
+    END FillWithActions;
+
+  PROCEDURE KnownMelted (set: CRT.Set; VAR melt: Melted): BOOLEAN;
+    BEGIN
+      melt := firstMelted;
+      WHILE melt # NIL DO
+        IF Sets.Equal(set, melt^.set) THEN RETURN TRUE END;
+        melt := melt^.next
+      END;
+      RETURN FALSE
+    END KnownMelted;
+
+  BEGIN
+    action := state[s].firstAction;
+    WHILE action # NIL DO
+      IF action^.target^.next # NIL THEN
+        GetStateSet(action^.target, set, endOf, ctx);
+        IF ~ KnownMelted(set, melt) THEN
+          s1 := NewState();
+          state[s1].endOf := endOf; state[s1].ctx := ctx;
+          FillWithActions(s1, action^.target);
+          REPEAT MakeUnique(s1, changed) UNTIL ~ changed;
+          melt := NewMelted(set, s1);
+        END;
+        DeleteTargetList(action^.target^.next);
+        action^.target^.next := NIL;
+        action^.target^.state := melt^.state
+      END;
+      action := action^.next
+    END
+  END MeltStates;
+
+(* MakeDeterministic     Make NDFA --> DFA
+------------------------------------------------------------------------*)
+PROCEDURE MakeDeterministic (VAR correct: BOOLEAN);
+  VAR
+    s: INTEGER;
+    changed: BOOLEAN;
+
+  PROCEDURE FindCtxStates;
+  (* Find states reached by a context transition *)
+    VAR
+      a: Action;
+      s: INTEGER;
+    BEGIN
+      s := rootState;
+      WHILE s <= lastState DO
+        a := state[s].firstAction;
+        WHILE a # NIL DO
+          IF a^.tc = CRT.contextTrans THEN
+            state[a^.target^.state].ctx := TRUE
+          END;
+          a := a^.next
+        END;
+        INC(s)
+      END;
+    END FindCtxStates;
+
+  BEGIN
+    out := CRS.lst;
+    lastSimState := lastState;
+    FindCtxStates;
+    s := rootState;
+    WHILE s <= lastState DO
+      REPEAT MakeUnique(s, changed) UNTIL ~ changed;
+      INC(s)
+    END;
+    correct := TRUE;
+    s := rootState;
+    WHILE s <= lastState DO MeltStates(s, correct); INC(s) END;
+    DeleteRedundantStates;
+    CombineShifts;
+(* ====    IF CRT.ddt["A"] THEN PrintStates END ==== *)
+  END MakeDeterministic;
+
+
+
+(* GenComment            Generate a procedure to scan comments
+-------------------------------------------------------------------------*)
+PROCEDURE GenComment (leftMarg: CARDINAL; com: Comment);
+
+  PROCEDURE GenBody (leftMarg: CARDINAL);
+    BEGIN
+      PutB(leftMarg); PutS("LOOP$");
+      PutB(leftMarg + 2); PutS("IF ");
+      PutChCond(com^.stop[0]); PutS(" THEN$");
+      IF FileIO.SLENGTH(com^.stop) = 1 THEN
+        PutB(leftMarg + 4);
+        PutS("DEC(level); oldEols := curLine - startLine; NextCh;$");
+        PutB(leftMarg + 4); PutS("IF level = 0 THEN RETURN TRUE END;$");
+      ELSE
+        PutB(leftMarg + 4); PutS("NextCh;$");
+        PutB(leftMarg + 4); PutS("IF ");
+        PutChCond(com^.stop[1]); PutS(" THEN$");
+        PutB(leftMarg + 6); PutS("DEC(level); NextCh;$");
+        PutB(leftMarg + 6); PutS("IF level = 0 THEN RETURN TRUE END$");
+        PutB(leftMarg + 4); PutS("END;$");
+      END;
+      IF com^.nested THEN
+        PutB(leftMarg + 2); PutS("ELSIF "); PutChCond(com^.start[0]);
+        PutS(" THEN$");
+        IF FileIO.SLENGTH(com^.start) = 1 THEN
+          PutB(leftMarg + 4); PutS("INC(level); NextCh;$");
+        ELSE
+          PutB(leftMarg + 4); PutS("NextCh;$");
+          PutB(leftMarg + 4); PutS("IF "); PutChCond(com^.start[1]);
+          PutS(" THEN "); PutS("INC(level); NextCh "); PutS("END;$");
+        END;
+      END;
+      PutB(leftMarg + 2); PutS("ELSIF ch = EOF THEN RETURN FALSE$");
+      PutB(leftMarg + 2); PutS("ELSE NextCh END;$");
+      PutB(leftMarg); PutS("END; (* LOOP *)$");
+    END GenBody;
+
+  BEGIN
+    PutS("IF "); PutChCond(com^.start[0]); PutS(" THEN$");
+    IF FileIO.SLENGTH(com^.start) = 1 THEN
+      PutB(leftMarg + 2); PutS("NextCh;$");
+      GenBody(leftMarg + 2);
+    ELSE
+      PutB(leftMarg + 2); PutS("NextCh;$");
+      PutB(leftMarg + 2); PutS("IF ");
+      PutChCond(com^.start[1]); PutS(" THEN$");
+      PutB(leftMarg + 4); PutS("NextCh;$");
+      GenBody(leftMarg + 4);
+      PutB(leftMarg + 2); PutS("ELSE$");
+      PutB(leftMarg + 4);
+      PutS("IF (ch = CR) OR (ch = LF) THEN$");
+      PutB(leftMarg + 6);
+      PutS("DEC(curLine); lineStart := oldLineStart$");
+      PutB(leftMarg + 4); PutS("END;$");
+      PutB(leftMarg + 4);
+      PutS("DEC(bp); ch := lastCh;$");
+      PutB(leftMarg + 2); PutS("END;$");
+    END;
+    PutB(leftMarg); PutS("END;$"); PutB(leftMarg);
+  END GenComment;
+
+(* CopyFramePart   Copy from file <fram> to file <framOut> until <stopStr>
+-------------------------------------------------------------------------*)
+PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR; VAR leftMarg: CARDINAL;
+                         VAR framIn, framOut:FileIO.File);
+  VAR
+    ch, startCh: CHAR;
+    slen, i: CARDINAL;
+    temp: ARRAY [0 .. 63] OF CHAR;
+  BEGIN
+    startCh := stopStr[0]; FileIO.Read(framIn, ch);
+    slen := FileIO.SLENGTH(stopStr);
+    WHILE FileIO.Okay DO
+      IF (ch = FileIO.EOL) OR (ch = FileIO.CR) OR (ch = FileIO.LF)
+        THEN leftMarg := 0
+        ELSE INC(leftMarg)
+      END;
+(* ProgArgs.Assert(leftMarg <= 100); for gpm version *)
+      IF ch = startCh
+        THEN (* check if stopString occurs *)
+          i := 0;
+          WHILE (i + 1 < slen) & (ch = stopStr[i]) & FileIO.Okay DO
+            temp[i] := ch; INC(i); FileIO.Read(framIn, ch)
+          END;
+          IF ch = stopStr[i] THEN DEC(leftMarg); RETURN END;
+          (* found ==> exit , else continue *)
+          FileIO.WriteText(framOut, temp, i);
+          FileIO.Write(framOut, ch);
+          INC(leftMarg, i);
+        ELSE FileIO.Write(framOut, ch)
+      END;
+      FileIO.Read(framIn, ch)
+    END;
+  END CopyFramePart;
+
+(* ImportSymConsts      Generates the import of the named symbol constants
+-------------------------------------------------------------------------*)
+PROCEDURE ImportSymConsts (putS: PutSProc);
+  VAR
+    i, len,
+    oldLen, pos: INTEGER;
+    cname: CRT.Name;
+    gn: CRT.GraphNode;
+    sn: CRT.SymbolNode;
+    gramName: ARRAY [0 .. 31] OF CHAR;
+
+  PROCEDURE PutImportSym;
+    BEGIN
+      IF pos + oldLen > MaxSourceLineLength THEN putS("$  "); pos := 2 END;
+      putS(cname); INC(pos, oldLen + 1);
+      (* This is not strictly correct, as the increase of 2 should be
+         lower. I omitted it, because to separate it would be too
+         complicated, and no unexpected side effects are likely, since it
+         is only called again outside the loop - after which "pos" is not
+         used again
+      *)
+    END PutImportSym;
+
+  BEGIN
+    (* ----- Import list of the generated Symbol Constants Module ----- *)
+    putS(";$$FROM  ");
+    CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
+    FileIO.Extract(sn.name, 0, 7, gramName);
+    putS(gramName); putS("G  IMPORT ");
+    i := 0; pos := MaxSourceLineLength + 1; oldLen := 0;
+    LOOP
+      CRT.GetSym(i, sn); len := FileIO.SLENGTH(sn.constant);
+      IF len > 0 THEN
+        IF oldLen > 0 THEN PutImportSym; putS(", ") END;
+        oldLen := len + 1; cname := sn.constant;
+      END;
+      IF i = CRT.maxP THEN EXIT END;
+      INC(i);
+    END; (* LOOP *)
+    PutImportSym;
+  END ImportSymConsts;
+
+(* GenLiterals           Generate CASE for the recognition of literals
+-------------------------------------------------------------------------*)
+PROCEDURE GenLiterals (leftMarg: CARDINAL);
+  VAR
+    FirstLine: BOOLEAN;
+    i, j, k: INTEGER;
+    key: ARRAY [0 .. CRT.maxLiterals] OF CRT.Name;
+    knr: ARRAY [0 .. CRT.maxLiterals] OF INTEGER;
+    ch: CHAR;
+    sn: CRT.SymbolNode;
+  BEGIN
+    (*-- sort literal list*)
+    i := 0; k := 0;
+    WHILE i <= CRT.maxT DO
+      CRT.GetSym(i, sn);
+      IF sn.struct = CRT.litToken THEN
+        j := k-1;
+        WHILE (j >= 0) & (FileIO.Compare(sn.name, key[j]) < 0) DO
+          key[j + 1] := key[j]; knr[j + 1] := knr[j]; DEC(j)
+        END;
+        key[j + 1] := sn.name; knr[j + 1] := i;
+        INC(k); IF k > CRT.maxLiterals THEN CRT.Restriction(10, CRT.maxLiterals) END;
+      END;
+      INC(i)
+    END;
+    (*-- print CASE statement*)
+    IF k # 0 THEN
+      PutS("CASE CurrentCh(bp0) OF$"); PutB(leftMarg);
+      i := 0; FirstLine := TRUE;
+      WHILE i < k DO
+        ch := key[i, 1]; (*key[i, 0] = quote*)
+        IF i # 0 THEN PutLn; PutB(leftMarg) END;
+        IF FirstLine THEN
+          FirstLine := FALSE; PutS("  ") ELSE PutS("| ")
+        END;
+        PutC(ch); j := i;
+        REPEAT
+          IF i = j THEN
+            PutS(": IF") ELSE PutB(leftMarg + 6); PutS(" ELSIF")
+          END;
+          PutS(" Equal("); PutS(key[i]); PutS(") THEN ");
+          PutSE(knr[i]); PutLn;
+          INC(i);
+        UNTIL (i = k) OR (key[i, 1] # ch);
+        PutB(leftMarg + 6); PutS(" END");
+      END;
+      PutLn; PutB(leftMarg); PutS("ELSE$");
+      PutB(leftMarg); PutS("END")
+    END;
+  END GenLiterals;
+
+(* WriteState           Write the source text of a scanner state
+-------------------------------------------------------------------------*)
+PROCEDURE WriteState (leftMarg, s: INTEGER; VAR FirstState: BOOLEAN);
+  VAR
+    action: Action;
+    ind: INTEGER;
+    first, ctxEnd: BOOLEAN;
+    sn: CRT.SymbolNode;
+    endOf: INTEGER;
+    set: CRT.Set;
+  BEGIN
+    endOf := state[s].endOf;
+    IF (endOf > CRT.maxT) & (endOf # CRT.noSym) THEN
+      (*pragmas have been moved*)
+      endOf := CRT.maxT + CRT.maxSymbols - endOf
+    END;
+(* ProgArgs.Assert(leftMarg <= 100); for gpm version *)
+    Indent(leftMarg);
+    IF FirstState THEN FirstState := FALSE; PutS("  ") ELSE PutS("| ") END;
+    PutI2(s, 2); PutS(": ");
+    first := TRUE; ctxEnd := state[s].ctx;
+    action := state[s].firstAction;
+    WHILE action # NIL DO
+      IF first
+        THEN PutS("IF "); first := FALSE; ind := leftMarg + 3;
+        ELSE PutB(leftMarg + 6); PutS("ELSIF "); ind := leftMarg + 6;
+      END;
+      IF action^.typ = CRT.char THEN PutChCond(CHR(action^.sym))
+      ELSE CRT.GetClass(action^.sym, set); PutRange(set,leftMarg + ind)
+      END;
+      PutS(" THEN");
+      IF action^.target^.state # s THEN
+        PutS(" state := "); PutI(action^.target^.state); Put(";")
+      END;
+      IF action^.tc = CRT.contextTrans
+        THEN PutS(" INC(apx)"); ctxEnd := FALSE
+        ELSIF state[s].ctx THEN PutS(" apx := Long0")
+      END;
+      PutS(" $");
+      action := action^.next
+    END;
+    IF state[s].firstAction # NIL THEN
+      PutB(leftMarg + 6); PutS("ELSE ")
+    END;
+    IF endOf = CRT.noSym THEN PutS("sym := noSYMB; ");
+    ELSE (*final state*)
+      CRT.GetSym(endOf, sn);
+      IF ctxEnd THEN (*cut appendix*)
+        PutS("bp := bp - apx - Long1;");
+        PutS(" DEC(nextLen, ORDL(apx)); NextCh; ")
+      END;
+      PutSE(endOf);
+      IF sn.struct = CRT.classLitToken THEN PutS("CheckLiteral; ") END
+    END;
+    PutS("RETURN$");
+    IF state[s].firstAction # NIL THEN
+      PutB(leftMarg + 6); PutS("END;$")
+    END
+  END WriteState;
+
+(* WriteScanner         Write the scanner source file
+-------------------------------------------------------------------------*)
+PROCEDURE WriteScanner (VAR ok : BOOLEAN);
+  CONST
+    ListingWidth = 78;
+  VAR
+    gramName: ARRAY [0 .. 31] OF CHAR;
+    fGramName, fn: ARRAY [0 .. 63] OF CHAR;
+    startTab: ARRAY [0 .. 255] OF INTEGER;
+    com: Comment;
+    i, j, s: INTEGER;
+    gn: CRT.GraphNode;
+    sn: CRT.SymbolNode;
+
+  PROCEDURE FillStartTab;
+    VAR
+      action: Action;
+      i, targetState, undefState: INTEGER;
+      class: CRT.Set;
+    BEGIN
+      undefState := lastState + 2;
+      startTab[0] := lastState + 1; (*eof*)
+      i := 1;
+      WHILE i < 256 (*PDT*) DO startTab[i] := undefState; INC(i) END;
+      action := state[rootState].firstAction;
+      WHILE action # NIL DO
+        targetState := action^.target^.state;
+        IF action^.typ = CRT.char THEN
+          startTab[action^.sym] := targetState
+        ELSE
+          CRT.GetClass(action^.sym, class); i := 0;
+          WHILE i < 256 (*PDT*) DO
+            IF Sets.In(class, i) THEN startTab[i] := targetState END;
+            INC(i)
+          END
+        END;
+        action := action^.next
+      END
+    END FillStartTab;
+
+  VAR
+    LeftMargin : CARDINAL;
+    FirstState: BOOLEAN;
+    ScannerFrame: ARRAY [0 .. 63] OF CHAR;
+
+  BEGIN
+    IF dirtyDFA THEN MakeDeterministic(ok) END;
+    FillStartTab;
+    FileIO.Concat(CRS.directory, "scanner.frm", ScannerFrame);
+    FileIO.Open(fram, ScannerFrame, FALSE);
+    IF ~ FileIO.Okay THEN
+      FileIO.SearchFile(fram, "CRFRAMES", "scanner.frm", FALSE);
+      IF ~ FileIO.Okay THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "'scanner.frm' not found.");
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "Aborted.");
+        FileIO.QuitExecution
+      END
+    END;
+    LeftMargin := 0;
+
+    CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
+    FileIO.Extract(sn.name, 0, 7, gramName);
+    FileIO.Concat(CRS.directory, gramName, fGramName);
+
+    (*------- *S.MOD -------*)
+    FileIO.Concat(fGramName, "S", fn);
+    FileIO.Concat(fn, FileIO.ModExt, fn);
+(* ++
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "  ");
+    FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+    FileIO.Open(scanner, fn, TRUE);
+    out := scanner;
+    CopyFramePart("-->modulename", LeftMargin, fram, out);
+    PutS(gramName); Put("S");
+    IF CRT.ddt["N"] OR CRT.symNames THEN ImportSymConsts(PutS) END;
+
+    CopyFramePart("-->unknownsym", LeftMargin, fram, out);
+    IF CRT.ddt["N"] OR CRT.symNames
+      THEN PutSN(CRT.maxT)
+      ELSE PutI(CRT.maxT)
+    END;
+    CopyFramePart("-->comment", LeftMargin, fram, out);
+    com := firstComment;
+    WHILE com # NIL DO GenComment(LeftMargin, com); com := com^.next END;
+
+    CopyFramePart("-->literals", LeftMargin, fram, out);
+    GenLiterals(LeftMargin);
+
+    CopyFramePart("-->GetSy1", LeftMargin, fram, out);
+    NewLine := FALSE;
+    IF ~ Sets.In(CRT.ignored, ORD(cr)) THEN
+      Indent(LeftMargin);
+      PutS("IF oldEols > 0 THEN DEC(bp);");
+      PutS(" DEC(oldEols); ch := CR END;$")
+    END;
+    Indent(LeftMargin); PutS("WHILE (ch = ' ')");
+    IF ~ Sets.Empty(CRT.ignored) THEN
+      PutS(" OR$"); Indent(LeftMargin + 6);
+      PutRange(CRT.ignored, LeftMargin + 6);
+    END;  (* PDT *)
+    PutS(" DO NextCh END;");
+    IF firstComment # NIL THEN
+      PutLn; PutB(LeftMargin); PutS("IF ("); com := firstComment;
+      WHILE com # NIL DO
+        PutChCond(com^.start[0]);
+        IF com^.next # NIL THEN PutS(" OR ") END;
+        com := com^.next
+      END;
+      PutS(") & Comment() THEN Get(sym); RETURN END;");
+    END;
+
+    CopyFramePart("-->GetSy2", LeftMargin, fram, out);
+    NewLine := FALSE; s := rootState + 1; FirstState := TRUE;
+(* ProgArgs.Assert(leftMarg <= 100); for gpm version *)
+    WHILE s <= lastState DO
+      WriteState(LeftMargin, s, FirstState); INC(s)
+    END;
+    PutB(LeftMargin); PutS("| "); PutI2(lastState + 1, 2);
+    PutS(": "); PutSE(0); PutS("ch := 0C; DEC(bp); RETURN");
+
+    CopyFramePart("-->initializations", LeftMargin, fram, out);
+    IF CRT.ignoreCase
+      THEN PutS("CurrentCh := CapChAt;$")
+      ELSE PutS("CurrentCh := CharAt;$")
+    END;
+    PutB(LeftMargin);
+    i := 0;
+    WHILE i < 64 (*PDT*) DO
+      IF i # 0 THEN PutLn; PutB(LeftMargin); END;
+      j := 0;
+      WHILE j < 4 DO
+        PutS("start["); PutI2(4*i + j,3); PutS("] := ");
+        PutI2(startTab[4*i + j],2); PutS("; "); INC(j);
+      END;
+      INC(i);
+    END;
+
+    CopyFramePart("-->modulename", LeftMargin, fram, out);
+    PutS(gramName); Put("S");
+    CopyFramePart("-->definition", LeftMargin, fram, out);
+    FileIO.Close(scanner);
+
+    (*------- *S.DEF -------*)
+    IF ~ CRT.ddt["D"] THEN
+      FileIO.Concat(fGramName, "S", fn);
+      FileIO.Concat(fn, FileIO.DefExt, fn);
+(* ++
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "  ");
+      FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+      FileIO.Open(scanner, fn, TRUE);
+      out := scanner;
+      CopyFramePart("-->modulename", LeftMargin, fram, out);
+      PutS(gramName); Put("S");
+
+      CopyFramePart("-->modulename", LeftMargin, fram, out);
+      PutS(gramName); Put("S");
+
+      CopyFramePart("-->implementation", LeftMargin, fram, out);
+      FileIO.Close(scanner);
+    END;
+    FileIO.Close(fram);
+  END WriteScanner;
+
+BEGIN (* CRA *)
+  lastState := -1; rootState := NewState();
+  firstMelted := NIL; firstComment := NIL;
+  NewLine := TRUE;
+  dirtyDFA := FALSE;
+END CRA.

CRC.def

@@ -0,0 +1,8 @@
+DEFINITION MODULE CRC;
+(* Main driver program generation *)
+
+PROCEDURE WriteDriver;
+(* Emits the source code of a generated driver program using the frame file
+   compiler.frm *)
+
+END CRC.

CRC.mod

@@ -0,0 +1,121 @@
+IMPLEMENTATION MODULE CRC;
+
+(* CRC   Compiler driver Generation *)
+
+  IMPORT CRA, CRS, CRT, FileIO;
+
+  VAR
+    err:  FileIO.File; (* output: error message texts *)
+    fram: FileIO.File; (* input:  parser frame parser.frm *)
+    com:  FileIO.File; (* output: generated parser *)
+
+  PROCEDURE Put (ch: CHAR);
+    BEGIN
+      FileIO.Write(com, ch)
+    END Put;
+
+  PROCEDURE PutS (s: ARRAY OF CHAR);
+    VAR
+      i: CARDINAL;
+    BEGIN
+      i := 0;
+      WHILE (i <= HIGH(s)) AND (s[i] # 0C) DO
+        IF s[i] = "$"
+          THEN FileIO.WriteLn(com)
+          ELSE FileIO.Write(com, s[i])
+        END;
+        INC(i)
+      END
+    END PutS;
+
+  PROCEDURE WriteDriver;
+    VAR
+      I, LeftMargin: CARDINAL;
+      gn: CRT.GraphNode;
+      sn: CRT.SymbolNode;
+      gramName: ARRAY [0 .. 31] OF CHAR;
+      fGramName, fn, errName, CompilerFrame: ARRAY [0 .. 63] OF CHAR;
+      ErrMsg: ARRAY [0 .. 127] OF CHAR;
+    BEGIN
+      CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
+      FileIO.Extract(sn.name, 0, 8, fn);
+      FileIO.Concat(CRS.directory, fn, CompilerFrame);
+      FileIO.Concat(CompilerFrame, FileIO.FrmExt, CompilerFrame);
+      FileIO.Open(fram, CompilerFrame, FALSE);
+      IF ~ FileIO.Okay THEN
+        FileIO.Concat(fn, FileIO.FrmExt, CompilerFrame);
+        FOR I := 0 TO FileIO.SLENGTH(CompilerFrame) DO
+          IF (CompilerFrame[I] >= 'A') & (CompilerFrame[I] <= 'Z')
+            THEN CompilerFrame[I] := CHR(ORD(CompilerFrame[I]) + 32) 
+          END
+        END;
+        FileIO.Concat(CRS.directory, CompilerFrame, CompilerFrame);
+        FileIO.Open(fram, CompilerFrame, FALSE);
+      END;
+      IF ~ FileIO.Okay THEN
+        FileIO.Concat(CRS.directory, "compiler.frm", CompilerFrame);
+        FileIO.Open(fram, CompilerFrame, FALSE);
+        IF ~ FileIO.Okay THEN
+          FileIO.SearchFile(fram, "CRFRAMES", "compiler.frm", FALSE);
+          IF ~ FileIO.Okay THEN
+            FileIO.WriteLn(FileIO.StdOut);
+            FileIO.WriteString(FileIO.StdOut, "'compiler.frm' not found.");
+            FileIO.WriteString(FileIO.StdOut, "- Aborted.");
+            FileIO.QuitExecution
+          END
+        END;
+      END;
+      LeftMargin := 0;
+
+      FileIO.Extract(sn.name, 0, 7, gramName);
+      FileIO.Concat(CRS.directory, gramName, fGramName);
+      FileIO.Concat(fGramName, FileIO.ErrExt, errName);
+      FileIO.Open(err, errName, FALSE);
+      IF ~ FileIO.Okay THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "Cannot find ");
+        FileIO.WriteString(FileIO.StdOut,  errName);
+        FileIO.WriteString(FileIO.StdOut, " - Aborted.");
+        FileIO.QuitExecution
+      END;
+      FileIO.Concat(fGramName, FileIO.ModExt, fn);
+      FileIO.Open(com, fn, TRUE);
+      IF ~ FileIO.Okay THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "Cannot open ");
+        FileIO.WriteString(FileIO.StdOut,  fn);
+        FileIO.WriteString(FileIO.StdOut, " - Aborted.");
+        FileIO.QuitExecution
+      END;
+(* ++
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "  ");
+      FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+      CRA.CopyFramePart("-->Grammar", LeftMargin, fram, com);
+      PutS(gramName);
+
+      CRA.CopyFramePart("-->Scanner", LeftMargin, fram, com);
+      PutS(gramName); Put("S");
+
+      CRA.CopyFramePart("-->Parser", LeftMargin, fram, com);
+      PutS(gramName); Put("P");
+
+      CRA.CopyFramePart("-->Errors", LeftMargin, fram, com);
+      FileIO.ReadLine(err, ErrMsg);
+      WHILE ~ FileIO.EndOfFile(err) DO
+        FileIO.WriteString(com, ErrMsg); FileIO.WriteLn(com);
+        FileIO.WriteText(com, "", LeftMargin);
+        FileIO.ReadLn(err); FileIO.ReadLine(err, ErrMsg)
+      END;
+
+      CRA.CopyFramePart("-->Grammar", LeftMargin, fram, com);
+      PutS(gramName);
+
+      CRA.CopyFramePart("-->$$$", LeftMargin, fram, com);
+      FileIO.Close(com);
+      FileIO.Close(err);
+      FileIO.Close(fram);
+    END WriteDriver;
+
+END CRC.

CRG.def

@@ -0,0 +1,15 @@
+DEFINITION MODULE CRG;
+
+CONST
+  EOFSYM = 0;  identSym = 1;  stringSym = 2;  badstringSym = 3;  numberSym = 4;
+  COMPILERSym = 5;  PRODUCTIONSSym = 6;  equalSym = 7;  pointSym = 8;
+  ENDSym = 9;  CHARACTERSSym = 10;  TOKENSSym = 11;  NAMESSym = 12;
+  PRAGMASSym = 13;  COMMENTSSym = 14;  FROMSym = 15;  TOSym = 16;
+  NESTEDSym = 17;  IGNORESym = 18;  CASESym = 19;  plusSym = 20;  minusSym = 21;
+  pointpointSym = 22;  ANYSym = 23;  CHRSym = 24;  lparenSym = 25;
+  rparenSym = 26;  barSym = 27;  WEAKSym = 28;  lbrackSym = 29;  rbrackSym = 30;
+  lbraceSym = 31;  rbraceSym = 32;  SYNCSym = 33;  CONTEXTSym = 34;
+  lessSym = 35;  greaterSym = 36;  lesspointSym = 37;  pointgreaterSym = 38;
+  lparenpointSym = 39;  pointrparenSym = 40;  NOSYM = 41;  OptionsSym = 42;
+
+END CRG.

CRG.mod

@@ -0,0 +1,2 @@
+IMPLEMENTATION MODULE CRG;
+END CRG.

CRP.def

@@ -0,0 +1,28 @@
+DEFINITION MODULE CRP;
+
+(* Parser generated by Coco/R *)
+
+PROCEDURE Parse;
+
+PROCEDURE Successful (): BOOLEAN;
+(* Returns TRUE if no errors have been recorded while parsing *)
+
+PROCEDURE SynError (errNo: INTEGER);
+(* Report syntax error errNo *)
+
+PROCEDURE SemError (errNo: INTEGER);
+(* Report semantic error errNo *)
+
+PROCEDURE LexString (VAR Lex: ARRAY OF CHAR);
+(* Retrieves Lex as exact spelling of current token *)
+
+PROCEDURE LexName (VAR Lex: ARRAY OF CHAR);
+(* Retrieves Lex as name of current token (capitalized if IGNORE CASE) *)
+
+PROCEDURE LookAheadName (VAR Lex: ARRAY OF CHAR);
+(* Retrieves Lex as exact spelling of lookahead token *)
+
+PROCEDURE LookAheadString (VAR Lex: ARRAY OF CHAR);
+(* Retrieves Lex as name of lookahead token (capitalized if IGNORE CASE) *)
+
+END CRP.

CRP.mod

@@ -0,0 +1,834 @@
+IMPLEMENTATION MODULE CRP;
+
+(* Parser generated by Coco/R - assuming FileIO library will be available. *)
+
+IMPORT FileIO, CRS;
+
+IMPORT CRT, CRA, Sets;
+
+CONST
+  ident = 0; string = 1;  (* symbol kind *)
+TYPE
+  INT32 = FileIO.INT32;
+
+PROCEDURE FixString (VAR name: ARRAY OF CHAR; len: CARDINAL);
+  VAR
+    double, spaces: BOOLEAN;
+    i: CARDINAL;
+  BEGIN
+    IF len = 2 THEN SemError(129); RETURN END;
+    IF CRT.ignoreCase THEN (* force uppercase *)
+      FOR i := 1 TO len - 2 DO name[i] := CAP(name[i]) END
+    END;
+    double := FALSE; spaces := FALSE;
+    FOR i := 1 TO len - 2 DO (* search for interior " or spaces *)
+      IF name[i] = '"' THEN double := TRUE END;
+      IF name[i] <= ' ' THEN spaces := TRUE END;
+    END;
+    IF ~ double THEN (* force delimiters to be " quotes *)
+      name[0] := '"'; name[len-1] := '"'
+    END;
+    IF spaces THEN SemError(124) END;
+  END FixString;
+
+PROCEDURE MatchLiteral (sp: INTEGER);
+(* store string either as token or as literal *)
+  VAR
+    sn, sn1:  CRT.SymbolNode;
+    matchedSp: INTEGER;
+  BEGIN
+    CRT.GetSym(sp, sn);
+    CRA.MatchDFA(sn.name, sp, matchedSp);
+    IF matchedSp # CRT.noSym THEN
+      CRT.GetSym(matchedSp, sn1);
+      sn1.struct := CRT.classLitToken;
+      CRT.PutSym(matchedSp, sn1);
+      sn.struct := CRT.litToken
+    ELSE sn.struct := CRT.classToken;
+    END;
+    CRT.PutSym(sp, sn)
+  END MatchLiteral;
+
+PROCEDURE SetCtx (gp: INTEGER);
+(* set transition code to CRT.contextTrans *)
+  VAR
+    gn: CRT.GraphNode;
+  BEGIN
+    WHILE gp > 0 DO
+      CRT.GetNode(gp, gn);
+      IF (gn.typ = CRT.char) OR (gn.typ = CRT.class) THEN
+        gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
+      ELSIF (gn.typ = CRT.opt) OR (gn.typ = CRT.iter) THEN SetCtx(gn.p1)
+      ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
+      END;
+      gp := gn.next
+    END
+  END SetCtx;
+
+PROCEDURE SetOption (s: ARRAY OF CHAR);
+  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;
+
+(*--------------------------------------------------------------------*)
+
+
+
+CONST 
+  maxT = 41;
+  maxP = 42;
+  minErrDist  =  2;  (* minimal distance (good tokens) between two errors *)
+  setsize     = 16;  (* sets are stored in 16 bits *)
+
+TYPE
+  SymbolSet = ARRAY [0 .. maxT DIV setsize] OF BITSET;
+
+VAR
+  symSet:  ARRAY [0 ..  18] OF SymbolSet; (*symSet[0] = allSyncSyms*)
+  errDist: CARDINAL;   (* number of symbols recognized since last error *)
+  sym:     CARDINAL;   (* current input symbol *)
+
+PROCEDURE SemError (errNo: INTEGER);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      CRS.Error(errNo, CRS.line, CRS.col, CRS.pos);
+    END;
+    errDist := 0;
+  END SemError;
+
+PROCEDURE SynError (errNo: INTEGER);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      CRS.Error(errNo, CRS.nextLine, CRS.nextCol, CRS.nextPos);
+    END;
+    errDist := 0;
+  END SynError;
+
+PROCEDURE Get;
+  VAR
+    s: ARRAY [0 .. 31] OF CHAR;
+  BEGIN
+    REPEAT
+      CRS.Get(sym);
+      IF sym <= maxT THEN
+        INC(errDist);
+      ELSE
+        CASE sym OF
+          42: CRS.GetName(CRS.nextPos, CRS.nextLen, s); SetOption(s);
+        END;
+        CRS.nextPos := CRS.pos;
+        CRS.nextCol := CRS.col;
+        CRS.nextLine := CRS.line;
+        CRS.nextLen := CRS.len;
+      END;
+    UNTIL sym <= maxT
+  END Get;
+
+PROCEDURE In (VAR s: SymbolSet; x: CARDINAL): BOOLEAN;
+  BEGIN
+    RETURN x MOD setsize IN s[x DIV setsize];
+  END In;
+
+PROCEDURE Expect (n: CARDINAL);
+  BEGIN
+    IF sym = n THEN Get ELSE SynError(n) END
+  END Expect;
+
+PROCEDURE ExpectWeak (n, follow: CARDINAL);
+  BEGIN
+    IF sym = n
+      THEN Get
+      ELSE SynError(n); WHILE ~ In(symSet[follow], sym) DO Get END
+    END
+  END ExpectWeak;
+
+PROCEDURE WeakSeparator (n, syFol, repFol: CARDINAL): BOOLEAN;
+  VAR
+    s: SymbolSet;
+    i: CARDINAL;
+  BEGIN
+    IF sym = n
+      THEN Get; RETURN TRUE
+      ELSIF In(symSet[repFol], sym) THEN RETURN FALSE
+      ELSE
+        i := 0;
+        WHILE i <= maxT DIV setsize DO
+          s[i] := symSet[0, i] + symSet[syFol, i] + symSet[repFol, i]; INC(i)
+        END;
+        SynError(n); WHILE ~ In(s, sym) DO Get END;
+        RETURN In(symSet[syFol], sym)
+    END
+  END WeakSeparator;
+
+PROCEDURE LexName (VAR Lex: ARRAY OF CHAR);
+  BEGIN
+    CRS.GetName(CRS.pos, CRS.len, Lex)
+  END LexName;
+
+PROCEDURE LexString (VAR Lex: ARRAY OF CHAR);
+  BEGIN
+    CRS.GetString(CRS.pos, CRS.len, Lex)
+  END LexString;
+
+PROCEDURE LookAheadName (VAR Lex: ARRAY OF CHAR);
+  BEGIN
+    CRS.GetName(CRS.nextPos, CRS.nextLen, Lex)
+  END LookAheadName;
+
+PROCEDURE LookAheadString (VAR Lex: ARRAY OF CHAR);
+  BEGIN
+    CRS.GetString(CRS.nextPos, CRS.nextLen, Lex)
+  END LookAheadString;
+
+PROCEDURE Successful (): BOOLEAN;
+  BEGIN
+    RETURN CRS.errors = 0
+  END Successful;
+
+(* ----- FORWARD not needed in multipass compilers
+
+PROCEDURE TokenFactor (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE TokenTerm (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE Factor (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE Term (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE Symbol (VAR name: CRT.Name; VAR kind: INTEGER); FORWARD;
+PROCEDURE SingleChar (VAR n: CARDINAL); FORWARD;
+PROCEDURE SimSet (VAR set: CRT.Set); FORWARD;
+PROCEDURE Set (VAR set: CRT.Set); FORWARD;
+PROCEDURE TokenExpr (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE NameDecl; FORWARD;
+PROCEDURE TokenDecl (typ: INTEGER); FORWARD;
+PROCEDURE SetDecl; FORWARD;
+PROCEDURE Expression (VAR gL, gR: INTEGER); FORWARD;
+PROCEDURE SemText (VAR semPos: CRT.Position); FORWARD;
+PROCEDURE Attribs (VAR attrPos: CRT.Position); FORWARD;
+PROCEDURE Declaration (VAR startedDFA: BOOLEAN); FORWARD;
+PROCEDURE Ident (VAR name: CRT.Name); FORWARD;
+PROCEDURE CR; FORWARD;
+
+----- *)
+
+PROCEDURE TokenFactor (VAR gL, gR: INTEGER);
+  VAR
+    kind, c: INTEGER;
+    set:     CRT.Set;
+    name:    CRT.Name;
+  BEGIN
+    gL :=0; gR := 0;
+    IF (sym = 1) OR (sym = 2) THEN
+      Symbol(name, kind);
+      IF kind = ident THEN
+        c := CRT.ClassWithName(name);
+        IF c < 0 THEN
+          SemError(115);
+          Sets.Clear(set); c := CRT.NewClass(name, set)
+        END;
+        gL := CRT.NewNode(CRT.class, c, 0); gR := gL
+      ELSE (* string *)
+        CRT.StrToGraph(name, gL, gR)
+      END;
+    ELSIF (sym = 25) THEN
+      Get;
+      TokenExpr(gL, gR);
+      Expect(26);
+    ELSIF (sym = 29) THEN
+      Get;
+      TokenExpr(gL, gR);
+      Expect(30);
+      CRT.MakeOption(gL, gR);
+    ELSIF (sym = 31) THEN
+      Get;
+      TokenExpr(gL, gR);
+      Expect(32);
+      CRT.MakeIteration(gL, gR);
+    ELSE SynError(42);
+    END;
+  END TokenFactor;
+
+PROCEDURE TokenTerm (VAR gL, gR: INTEGER);
+  VAR
+    gL2, gR2: INTEGER;
+  BEGIN
+    TokenFactor(gL, gR);
+    WHILE (sym = 1) OR (sym = 2) OR (sym = 25) OR (sym = 29) OR (sym = 31) DO
+      TokenFactor(gL2, gR2);
+      CRT.ConcatSeq(gL, gR, gL2, gR2);
+    END;
+    IF (sym = 34) THEN
+      Get;
+      Expect(25);
+      TokenExpr(gL2, gR2);
+      SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2);
+      Expect(26);
+    END;
+  END TokenTerm;
+
+PROCEDURE Factor (VAR gL, gR: INTEGER);
+  VAR
+    sp, kind:    INTEGER;
+    name:        CRT.Name;
+    gn:          CRT.GraphNode;
+    sn:          CRT.SymbolNode;
+    set:         CRT.Set;
+    undef, weak: BOOLEAN;
+    pos:         CRT.Position;
+  BEGIN
+    gL :=0; gR := 0; weak := FALSE;
+    CASE sym OF
+      1, 2, 28 :
+        IF (sym = 28) THEN
+          Get;
+          weak := TRUE;
+        END;
+        Symbol(name, kind);
+        sp := CRT.FindSym(name); undef := sp = CRT.noSym;
+        IF undef THEN
+          IF kind = ident THEN  (* forward nt *)
+            sp := CRT.NewSym(CRT.nt, name, 0)
+          ELSIF CRT.genScanner THEN
+            sp := CRT.NewSym(CRT.t, name, CRS.line);
+            MatchLiteral(sp)
+          ELSE (* undefined string in production *)
+            SemError(106); sp := 0
+          END
+        END;
+        CRT.GetSym(sp, sn);
+        IF (sn.typ # CRT.t) & (sn.typ # CRT.nt) THEN SemError(104) END;
+        IF weak THEN
+          IF sn.typ = CRT.t THEN sn.typ := CRT.wt
+          ELSE SemError(123)
+          END
+        END;
+        gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL;
+        IF (sym = 35) OR (sym = 37) THEN
+          Attribs(pos);
+          CRT.GetNode(gL, gn); gn.pos := pos;
+          CRT.PutNode(gL, gn);
+          CRT.GetSym(sp, sn);
+          IF sn.typ # CRT.nt THEN SemError(103) END;
+          IF undef THEN
+            sn.attrPos := pos; CRT.PutSym(sp, sn)
+          ELSIF sn.attrPos.beg < FileIO.Long0 THEN SemError(105)
+          END;
+        ELSIF In(symSet[1], sym) THEN
+          CRT.GetSym(sp, sn);
+          IF sn.attrPos.beg >= FileIO.Long0 THEN SemError(105) END;
+        ELSE SynError(43);
+        END;
+    | 25 :
+        Get;
+        Expression(gL, gR);
+        Expect(26);
+    | 29 :
+        Get;
+        Expression(gL, gR);
+        Expect(30);
+        CRT.MakeOption(gL, gR);
+    | 31 :
+        Get;
+        Expression(gL, gR);
+        Expect(32);
+        CRT.MakeIteration(gL, gR);
+    | 39 :
+        SemText(pos);
+        gL := CRT.NewNode(CRT.sem, 0, 0); gR := gL;
+        CRT.GetNode(gL, gn);
+        gn.pos := pos;
+        CRT.PutNode(gL, gn);
+    | 23 :
+        Get;
+        Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
+        gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL;
+    | 33 :
+        Get;
+        gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL;
+    ELSE SynError(44);
+    END;
+  END Factor;
+
+PROCEDURE Term (VAR gL, gR: INTEGER);
+  VAR
+    gL2, gR2: INTEGER;
+  BEGIN
+    gL := 0; gR := 0;
+    IF In(symSet[2], sym) THEN
+      Factor(gL, gR);
+      WHILE In(symSet[2], sym) DO
+        Factor(gL2, gR2);
+        CRT.ConcatSeq(gL, gR, gL2, gR2);
+      END;
+    ELSIF (sym = 8) OR (sym = 26) OR (sym = 27) OR (sym = 30) OR (sym = 32) THEN
+      gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL;
+    ELSE SynError(45);
+    END;
+  END Term;
+
+PROCEDURE Symbol (VAR name: CRT.Name; VAR kind: INTEGER);
+  BEGIN
+    IF (sym = 1) THEN
+      Ident(name);
+      kind := ident;
+    ELSIF (sym = 2) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, name); kind := string;
+      FixString(name, CRS.len);
+    ELSE SynError(46);
+    END;
+  END Symbol;
+
+PROCEDURE SingleChar (VAR n: CARDINAL);
+  VAR
+    i: CARDINAL;
+    s: ARRAY [0 .. 127] OF CHAR;
+  BEGIN
+    Expect(24);
+    Expect(25);
+    IF (sym = 4) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, s);
+      n := 0; i := 0;
+      WHILE s[i] # 0C DO
+        n := 10 * n + ORD(s[i]) - ORD("0"); INC(i)
+      END;
+      IF n > 255 THEN SemError(118); n := n MOD 256 END;
+      IF CRT.ignoreCase THEN n := ORD(CAP(CHR(n))) END;
+    ELSIF (sym = 2) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, s);
+      IF CRS.len # 3 THEN SemError(118) END;
+      IF CRT.ignoreCase THEN s[1] := CAP(s[1]) END;
+      n := ORD(s[1]);;
+    ELSE SynError(47);
+    END;
+    Expect(26);
+  END SingleChar;
+
+PROCEDURE SimSet (VAR set: CRT.Set);
+  VAR
+    i, n1, n2: CARDINAL;
+    c:         INTEGER;
+    name:      CRT.Name;
+    s:         ARRAY [0 .. 127] OF CHAR;
+  BEGIN
+    Sets.Clear(set);
+    IF (sym = 1) THEN
+      Ident(name);
+      c := CRT.ClassWithName(name);
+      IF c < 0
+        THEN SemError(115)
+        ELSE CRT.GetClass(c, set)
+      END;
+    ELSIF (sym = 2) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, s);
+      i := 1;
+      WHILE s[i] # s[0] DO
+        IF CRT.ignoreCase THEN s[i] := CAP(s[i]) END;
+        Sets.Incl(set, ORD(s[i])); INC(i)
+      END;
+    ELSIF (sym = 24) THEN
+      SingleChar(n1);
+      Sets.Incl(set, n1);
+      IF (sym = 22) THEN
+        Get;
+        SingleChar(n2);
+        FOR i := n1 TO n2 DO Sets.Incl(set, i) END;
+      END;
+    ELSIF (sym = 23) THEN
+      Get;
+      FOR i := 0 TO 255 DO Sets.Incl(set, i) END;
+    ELSE SynError(48);
+    END;
+  END SimSet;
+
+PROCEDURE Set (VAR set: CRT.Set);
+  VAR
+    set2: CRT.Set;
+  BEGIN
+    SimSet(set);
+    WHILE (sym = 20) OR (sym = 21) DO
+      IF (sym = 20) THEN
+        Get;
+        SimSet(set2);
+        Sets.Unite(set, set2);
+      ELSE
+        Get;
+        SimSet(set2);
+        Sets.Differ(set, set2);
+      END;
+    END;
+  END Set;
+
+PROCEDURE TokenExpr (VAR gL, gR: INTEGER);
+  VAR
+    gL2, gR2: INTEGER;
+    first:    BOOLEAN;
+  BEGIN
+    TokenTerm(gL, gR);
+    first := TRUE;
+    WHILE WeakSeparator(27, 3, 4) DO
+      TokenTerm(gL2, gR2);
+      IF first THEN
+        CRT.MakeFirstAlt(gL, gR); first := FALSE
+      END;
+      CRT.ConcatAlt(gL, gR, gL2, gR2);
+    END;
+  END TokenExpr;
+
+PROCEDURE NameDecl;
+  VAR
+    name, str: CRT.Name;
+  BEGIN
+    Ident(name);
+    Expect(7);
+    IF (sym = 1) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, str);
+    ELSIF (sym = 2) THEN
+      Get;
+      CRS.GetName(CRS.pos, CRS.len, str);
+      FixString(str, CRS.len);
+    ELSE SynError(49);
+    END;
+    CRT.NewName(name, str);
+    Expect(8);
+  END NameDecl;
+
+PROCEDURE TokenDecl (typ: INTEGER);
+  VAR
+    kind:       INTEGER;
+    name:       CRT.Name;
+    pos:        CRT.Position;
+    sp, gL, gR: INTEGER;
+    sn:         CRT.SymbolNode;
+  BEGIN
+    Symbol(name, kind);
+    IF CRT.FindSym(name) # CRT.noSym THEN SemError(107)
+    ELSE
+      sp := CRT.NewSym(typ, name, CRS.line);
+      CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
+      CRT.PutSym(sp, sn)
+    END;
+    WHILE ~ ( In(symSet[5], sym)) DO SynError(50); Get END;
+    IF (sym = 7) THEN
+      Get;
+      TokenExpr(gL, gR);
+      IF kind # ident THEN SemError(113) END;
+      CRT.CompleteGraph(gR);
+      CRA.ConvertToStates(gL, sp);
+      Expect(8);
+    ELSIF In(symSet[6], sym) THEN
+      IF kind = ident THEN CRT.genScanner := FALSE
+        ELSE MatchLiteral(sp)
+      END;
+    ELSE SynError(51);
+    END;
+    IF (sym = 39) THEN
+      SemText(pos);
+      IF typ = CRT.t THEN SemError(114) END;
+      CRT.GetSym(sp, sn); sn.semPos := pos;
+      CRT.PutSym(sp, sn);
+    END;
+  END TokenDecl;
+
+PROCEDURE SetDecl;
+  VAR
+    c:    INTEGER;
+    set:  CRT.Set;
+    name: CRT.Name;
+  BEGIN
+    Ident(name);
+    c := CRT.ClassWithName(name);
+    IF c >= 0 THEN SemError(107) END;
+    Expect(7);
+    Set(set);
+    IF Sets.Empty(set) THEN SemError(101) END;
+    c := CRT.NewClass(name, set);
+    Expect(8);
+  END SetDecl;
+
+PROCEDURE Expression (VAR gL, gR: INTEGER);
+  VAR
+    gL2, gR2: INTEGER;
+    first:    BOOLEAN;
+  BEGIN
+    Term(gL, gR);
+    first := TRUE;
+    WHILE WeakSeparator(27, 1, 7) DO
+      Term(gL2, gR2);
+      IF first THEN
+        CRT.MakeFirstAlt(gL, gR); first := FALSE
+      END;
+      CRT.ConcatAlt(gL, gR, gL2, gR2);
+    END;
+  END Expression;
+
+PROCEDURE SemText (VAR semPos: CRT.Position);
+  BEGIN
+    Expect(39);
+    semPos.beg := CRS.pos + FileIO.Long2; semPos.col := CRS.col + 2;
+    WHILE In(symSet[8], sym) DO
+      IF In(symSet[9], sym) THEN
+        Get;
+      ELSIF (sym = 3) THEN
+        Get;
+        SemError(102);
+      ELSE
+        Get;
+        SemError(109);
+      END;
+    END;
+    Expect(40);
+    IF CRS.pos - semPos.beg > FileIO.INT(CRT.maxSemLen) THEN SemError(128) END;
+    semPos.len := FileIO.ORDL(CRS.pos - semPos.beg);
+  END SemText;
+
+PROCEDURE Attribs (VAR attrPos: CRT.Position);
+  BEGIN
+    IF (sym = 35) THEN
+      Get;
+      attrPos.beg := CRS.pos + FileIO.Long1; attrPos.col := CRS.col + 1;
+      WHILE In(symSet[10], sym) DO
+        IF In(symSet[11], sym) THEN
+          Get;
+        ELSE
+          Get;
+          SemError(102);
+        END;
+      END;
+      Expect(36);
+      attrPos.len := FileIO.INTL(CRS.pos - attrPos.beg);
+    ELSIF (sym = 37) THEN
+      Get;
+      attrPos.beg := CRS.pos + FileIO.Long2; attrPos.col := CRS.col + 2;
+      WHILE In(symSet[12], sym) DO
+        IF In(symSet[13], sym) THEN
+          Get;
+        ELSE
+          Get;
+          SemError(102);
+        END;
+      END;
+      Expect(38);
+      attrPos.len := FileIO.INTL(CRS.pos - attrPos.beg);
+    ELSE SynError(52);
+    END;
+  END Attribs;
+
+PROCEDURE Declaration (VAR startedDFA: BOOLEAN);
+  VAR
+    gL1, gR1, gL2, gR2: INTEGER;
+    nested:             BOOLEAN;
+  BEGIN
+    CASE sym OF
+      10 :
+        Get;
+        WHILE (sym = 1) DO
+          SetDecl;
+        END;
+    | 11 :
+        Get;
+        WHILE (sym = 1) OR (sym = 2) DO
+          TokenDecl(CRT.t);
+        END;
+    | 12 :
+        Get;
+        WHILE (sym = 1) DO
+          NameDecl;
+        END;
+    | 13 :
+        Get;
+        WHILE (sym = 1) OR (sym = 2) DO
+          TokenDecl(CRT.pr);
+        END;
+    | 14 :
+        Get;
+        Expect(15);
+        TokenExpr(gL1, gR1);
+        Expect(16);
+        TokenExpr(gL2, gR2);
+        IF (sym = 17) THEN
+          Get;
+          nested := TRUE;
+        ELSIF In(symSet[14], sym) THEN
+          nested := FALSE;
+        ELSE SynError(53);
+        END;
+        CRA.NewComment(gL1, gL2, nested);
+    | 18 :
+        Get;
+        IF (sym = 19) THEN
+          Get;
+          IF startedDFA THEN SemError(130) END;
+          CRT.ignoreCase := TRUE;
+        ELSIF (sym = 1) OR (sym = 2) OR (sym = 23) OR (sym = 24) THEN
+          Set(CRT.ignored);
+          IF Sets.In(CRT.ignored, 0) THEN SemError(119) END;;
+        ELSE SynError(54);
+        END;
+    ELSE SynError(55);
+    END;
+    startedDFA := TRUE;
+  END Declaration;
+
+PROCEDURE Ident (VAR name: CRT.Name);
+  BEGIN
+    Expect(1);
+    CRS.GetName(CRS.pos, CRS.len, name);
+  END Ident;
+
+PROCEDURE CR;
+  VAR
+    startedDFA, ok, undef, hasAttrs: BOOLEAN;
+    unknownSy,
+    eofSy, gR:       INTEGER;
+    gramLine, sp:    INTEGER;
+    name, gramName:  CRT.Name;
+    sn:              CRT.SymbolNode;
+  BEGIN
+    Expect(5);
+    gramLine := CRS.line;
+    eofSy := CRT.NewSym(CRT.t, "EOF", 0);
+    CRT.genScanner := TRUE; CRT.ignoreCase := FALSE;
+    Sets.Clear(CRT.ignored);
+    startedDFA := FALSE;;
+    Ident(gramName);
+    CRT.semDeclPos.beg := CRS.nextPos;
+    WHILE In(symSet[15], sym) DO
+      Get;
+    END;
+    CRT.semDeclPos.len := FileIO.INTL(CRS.nextPos - CRT.semDeclPos.beg);
+    CRT.semDeclPos.col := 0;
+    WHILE In(symSet[16], sym) DO
+      Declaration(startedDFA);
+    END;
+    WHILE ~ ( (sym = 0) OR (sym = 6)) DO SynError(56); Get END;
+    Expect(6);
+    ok := Successful();
+    IF ok & CRT.genScanner THEN CRA.MakeDeterministic(ok) END;
+    IF ~ ok THEN SemError(127) END;
+    CRT.nNodes := 0;
+    WHILE (sym = 1) DO
+      Ident(name);
+      sp := CRT.FindSym(name); undef := sp = CRT.noSym;
+      IF undef THEN
+        sp := CRT.NewSym(CRT.nt, name, CRS.line);
+        CRT.GetSym(sp, sn);
+      ELSE
+        CRT.GetSym(sp, sn);
+        IF sn.typ = CRT.nt THEN
+          IF sn.struct > 0 THEN SemError(107) END
+        ELSE SemError(108)
+        END;
+        sn.line := CRS.line
+      END;
+      hasAttrs := sn.attrPos.beg >= FileIO.Long0;
+      IF (sym = 35) OR (sym = 37) THEN
+        Attribs(sn.attrPos);
+        IF ~ undef & ~ hasAttrs THEN SemError(105) END;
+        CRT.PutSym(sp, sn);
+      ELSIF (sym = 7) OR (sym = 39) THEN
+        IF ~ undef & hasAttrs THEN SemError(105) END;
+      ELSE SynError(57);
+      END;
+      IF (sym = 39) THEN
+        SemText(sn.semPos);
+      END;
+      ExpectWeak(7, 17);
+      Expression(sn.struct, gR);
+      CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
+      ExpectWeak(8, 18);
+    END;
+    Expect(9);
+    Ident(name);
+    sp := CRT.FindSym(gramName);
+    IF sp = CRT.noSym THEN SemError(111);
+    ELSE
+      CRT.GetSym(sp, sn);
+      IF sn.attrPos.beg >= FileIO.Long0 THEN SemError(112) END;
+      CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
+    END;
+    IF FileIO.Compare(name, gramName) # 0 THEN
+      SemError(117)
+    END;
+    Expect(8);
+    unknownSy := CRT.NewSym(CRT.t, "not", 0);
+  END CR;
+
+
+
+PROCEDURE Parse;
+  BEGIN
+    CRS.Reset; Get;
+    CR;
+
+  END Parse;
+
+BEGIN
+  errDist := minErrDist;
+  symSet[ 0, 0] := BITSET{0, 1, 2, 6, 7, 10, 11, 12, 13, 14};
+  symSet[ 0, 1] := BITSET{2};
+  symSet[ 0, 2] := BITSET{7};
+  symSet[ 1, 0] := BITSET{1, 2, 8};
+  symSet[ 1, 1] := BITSET{7, 9, 10, 11, 12, 13, 14, 15};
+  symSet[ 1, 2] := BITSET{0, 1, 7};
+  symSet[ 2, 0] := BITSET{1, 2};
+  symSet[ 2, 1] := BITSET{7, 9, 12, 13, 15};
+  symSet[ 2, 2] := BITSET{1, 7};
+  symSet[ 3, 0] := BITSET{1, 2};
+  symSet[ 3, 1] := BITSET{9, 13, 15};
+  symSet[ 3, 2] := BITSET{};
+  symSet[ 4, 0] := BITSET{6, 8, 10, 11, 12, 13, 14};
+  symSet[ 4, 1] := BITSET{0, 1, 2, 10, 14};
+  symSet[ 4, 2] := BITSET{0};
+  symSet[ 5, 0] := BITSET{0, 1, 2, 6, 7, 10, 11, 12, 13, 14};
+  symSet[ 5, 1] := BITSET{2};
+  symSet[ 5, 2] := BITSET{7};
+  symSet[ 6, 0] := BITSET{1, 2, 6, 10, 11, 12, 13, 14};
+  symSet[ 6, 1] := BITSET{2};
+  symSet[ 6, 2] := BITSET{7};
+  symSet[ 7, 0] := BITSET{8};
+  symSet[ 7, 1] := BITSET{10, 14};
+  symSet[ 7, 2] := BITSET{0};
+  symSet[ 8, 0] := BITSET{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[ 8, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[ 8, 2] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 9};
+  symSet[ 9, 0] := BITSET{1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[ 9, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[ 9, 2] := BITSET{0, 1, 2, 3, 4, 5, 6, 9};
+  symSet[10, 0] := BITSET{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[10, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[10, 2] := BITSET{0, 1, 2, 3, 5, 6, 7, 8, 9};
+  symSet[11, 0] := BITSET{1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[11, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[11, 2] := BITSET{0, 1, 2, 3, 5, 6, 7, 8, 9};
+  symSet[12, 0] := BITSET{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[12, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[12, 2] := BITSET{0, 1, 2, 3, 4, 5, 7, 8, 9};
+  symSet[13, 0] := BITSET{1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[13, 1] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[13, 2] := BITSET{0, 1, 2, 3, 4, 5, 7, 8, 9};
+  symSet[14, 0] := BITSET{6, 10, 11, 12, 13, 14};
+  symSet[14, 1] := BITSET{2};
+  symSet[14, 2] := BITSET{};
+  symSet[15, 0] := BITSET{1, 2, 3, 4, 5, 7, 8, 9, 15};
+  symSet[15, 1] := BITSET{0, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15};
+  symSet[15, 2] := BITSET{0, 1, 2, 3, 4, 5, 6, 7, 8, 9};
+  symSet[16, 0] := BITSET{10, 11, 12, 13, 14};
+  symSet[16, 1] := BITSET{2};
+  symSet[16, 2] := BITSET{};
+  symSet[17, 0] := BITSET{0, 1, 2, 6, 7, 8, 10, 11, 12, 13, 14};
+  symSet[17, 1] := BITSET{2, 7, 9, 11, 12, 13, 15};
+  symSet[17, 2] := BITSET{1, 7};
+  symSet[18, 0] := BITSET{0, 1, 2, 6, 7, 9, 10, 11, 12, 13, 14};
+  symSet[18, 1] := BITSET{2};
+  symSet[18, 2] := BITSET{7};
+END CRP.
+

CRQ.frm

@@ -0,0 +1,538 @@
+(* 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.
+
+   JPI version of 27 January 1991 was then modified to make more
+   portable by Pat Terry, January - October 1992
+
+   This is the WinTel version
+   This version outputs error messages in "standard" form for use with editors
+
+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 DOS 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 -->Grammar;
+
+  FROM -->Scanner IMPORT lst, src, errors, directory, Error, CharAt;
+  FROM -->Parser IMPORT Parse;
+  IMPORT CRC, CRT, CRA, CRP, CRS, CRX, FileIO, Storage;
+  IMPORT SYSTEM (* for TSIZE only *);
+
+  CONST
+    ATGExt = ".atg";
+    LSTExt = ".lst";
+    Version = "1.53q";
+    ReleaseDate = "17 September 2002";
+
+  TYPE
+    INT32 = FileIO.INT32;
+
+  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 FileIO, 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 # FileIO.CR) & (ch # FileIO.LF) & (ch # FileIO.EOF) DO
+        line[i] := ch; INC(i); ch := CharAt(pos); INC(pos);
+      END;
+      eof := (i = 0) & (ch = FileIO.EOF); line[i] := 0C;
+      IF ch = FileIO.CR THEN (* check for MsDos *)
+        ch := CharAt(pos);
+        IF ch = FileIO.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
+        FileIO.WriteString(lst, s)
+      END Msg;
+
+    PROCEDURE Pointer;
+      VAR
+        i: INTEGER;
+      BEGIN
+        FileIO.WriteString(lst, "*****  ");
+        i := 0;
+        WHILE i < col + Extra - 2 DO
+          IF line[i] = tab
+            THEN FileIO.Write(lst, tab)
+            ELSE FileIO.Write(lst, ' ')
+          END;
+          INC(i)
+        END;
+        FileIO.WriteString(lst, "^ ")
+      END Pointer;
+
+    BEGIN
+      IF ~ IDE THEN Pointer END;
+      CASE nr OF
+      -->Errors
+      | 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: "); FileIO.WriteInt(lst, nr, 1);
+      END;
+      FileIO.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
+        FileIO.WriteString(lst, "Listing:");
+        FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+      END;
+      srcPos := FileIO.Long0; nextErr := firstErr;
+      GetLine(srcPos, line, eof); lnr := 1; errC := 0;
+      WHILE ~ eof DO
+        IF ~ IDE THEN
+          FileIO.WriteInt(lst, lnr, 5); FileIO.WriteString(lst, "  ");
+          FileIO.WriteString(lst, line); FileIO.WriteLn(lst)
+        END;
+        WHILE (nextErr # NIL) & (nextErr^.line = lnr) DO
+          IF IDE THEN
+            FileIO.WriteString(lst, ATGFileName);
+            FileIO.WriteString(lst, " (");
+            FileIO.WriteCard(lst, lnr, 1);
+            FileIO.WriteString(lst, ",");
+            FileIO.WriteCard(lst, nextErr^.col-1, 0);
+            FileIO.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 FileIO.WriteInt(lst, lnr, 5); FileIO.WriteLn(lst) END;
+        WHILE nextErr # NIL DO
+          IF IDE THEN
+            FileIO.WriteString(lst, ATGFileName);
+            FileIO.WriteString(lst, " (");
+            FileIO.WriteCard(lst, lnr, 1);
+            FileIO.WriteString(lst, ",");
+            FileIO.WriteCard(lst, nextErr^.col-1, 0);
+            FileIO.WriteString(lst, ") ")
+          END;
+          PrintErr(line, nextErr^.nr, nextErr^.col); INC(errC);
+          nextErr := nextErr^.next
+        END
+      END;
+      IF ~ IDE AND (errC > 0) THEN
+        FileIO.WriteLn(lst);
+        FileIO.WriteInt(lst, errC, 5); FileIO.WriteString(lst, " error");
+        IF errC # 1 THEN FileIO.Write(lst, "s") END;
+        FileIO.WriteLn(lst); FileIO.WriteLn(lst); FileIO.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
+      FileIO.WriteString(FileIO.StdOut, S); FileIO.WriteLn(FileIO.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 *)
+    FileIO.WriteString(FileIO.StdOut, "Coco/R (WinTel) - Compiler-Compiler V");
+    FileIO.WriteString(FileIO.StdOut, Version);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "Released by Pat Terry ");
+    FileIO.WriteString(FileIO.StdOut, ReleaseDate);
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.NextParameter(GrammarName);
+    IF (GrammarName[0] = "?")
+        OR (GrammarName[0] = "/") AND (GrammarName[1] = "?") THEN
+      Help; FileIO.QuitExecution
+    END;
+    IF GrammarName[0] = 0C THEN
+      FileIO.WriteString(FileIO.StdOut, "(COCOR ? gives short help screen)");
+      FileIO.WriteLn(FileIO.StdOut);
+    END;
+    WHILE (GrammarName[0] = "-") OR (GrammarName[0] = "/") DO
+      (* accept options before filename *)
+      SetOption(GrammarName); FileIO.NextParameter(GrammarName)
+    END;
+    ok := GrammarName[0] # 0C;
+    REPEAT
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "Grammar[.atg] ? : ");
+        FileIO.ReadString(FileIO.StdIn, GrammarName);
+        IF ~ FileIO.Okay THEN FileIO.QuitExecution END;
+        FileIO.ReadLn(FileIO.StdIn);
+      END;
+      FileIO.AppendExtension(GrammarName, ATGExt, ATGFileName);
+      GrammarName := ATGFileName;
+      FileIO.Open(src, GrammarName, FALSE);
+      ok := FileIO.Okay;
+      IF ~ ok THEN
+        FileIO.WriteString(FileIO.StdOut, "File <");
+        FileIO.WriteString(FileIO.StdOut, GrammarName);
+        FileIO.WriteString(FileIO.StdOut, "> not found.");
+        FileIO.WriteLn(FileIO.StdOut);
+      END
+    UNTIL ok;
+    FileIO.NextParameter(Options);
+    IF Options[0] # 0C THEN SetOption(Options) END;
+    IDE := CRT.ddt["Q"];
+    FileIO.ExtractDirectory(GrammarName, directory);
+    FileIO.ChangeExtension(GrammarName, LSTExt, lstFileName);
+    IF IDE
+      THEN
+        lst := FileIO.StdOut
+      ELSE
+        FileIO.Open(lst, lstFileName, TRUE);
+        FileIO.WriteString(lst, "Coco/R - Compiler-Compiler V");
+        FileIO.WriteString(lst, Version);
+        FileIO.WriteLn(lst);
+        FileIO.WriteString(lst, "Released by Pat Terry ");
+        FileIO.WriteString(lst, ReleaseDate);
+        FileIO.WriteLn(lst);
+        FileIO.WriteString(lst, "Source file: ");
+        FileIO.WriteString(lst, GrammarName);
+        FileIO.WriteLn(lst); FileIO.WriteLn(lst);
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "parsing file ");
+        FileIO.WriteString(FileIO.StdOut, GrammarName);
+        FileIO.WriteLn(FileIO.StdOut);
+    END;
+    CRS.Error := StoreError;
+    CRP.Parse;
+(*
+    IF ~ IDE THEN
+      FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.StdOut)
+    END;
+*)
+    IF errors = 0 THEN
+      IF ~ IDE
+        THEN
+          Msg("testing grammar");
+          FileIO.WriteString(lst, "Grammar Tests:");
+          FileIO.WriteLn(lst); FileIO.WriteLn(lst)
+        ELSE
+          FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) Grammar tests"); FileIO.WriteLn(lst)
+      END;
+      CRT.CompSymbolSets;
+      IF IDE THEN
+        FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+        FileIO.WriteString(lst, " (0, 0) Undefined tests"); FileIO.WriteLn(lst)
+      END;
+      CRT.TestCompleteness(ok);
+      IF ok
+        THEN
+          IF IDE THEN
+            FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+            FileIO.WriteString(lst, " (0, 0) Unreachable tests"); FileIO.WriteLn(lst)
+          END;
+          CRT.TestIfAllNtReached(ok)
+      END;
+      IF ok THEN
+        IF IDE THEN
+          FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) Circular tests"); FileIO.WriteLn(lst)
+        END;
+        CRT.FindCircularProductions(ok)
+      END;
+      IF ok THEN
+        IF IDE THEN
+          FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) Underivable tests"); FileIO.WriteLn(lst)
+        END;
+        CRT.TestIfNtToTerm(ok)
+      END;
+      IF ok THEN
+        IF IDE THEN
+          FileIO.WriteLn(lst); FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) LL(1) tests"); FileIO.WriteLn(lst)
+        END;
+        CRT.LL1Test(ll1)
+      END;
+(*
+      IF ~ IDE THEN
+        FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.StdOut);
+        FileIO.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
+          FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.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
+          FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.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
+            FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.StdOut)
+          END;
+*)
+        END;
+        IF CRT.ddt["C"] THEN
+          IF ~ IDE THEN Msg("generating compiler") END;
+          CRC.WriteDriver;
+(*
+          IF ~ IDE THEN
+            FileIO.WriteLn(FileIO.StdOut); FileIO.WriteElapsedTime(FileIO.StdOut);
+          END;
+*)
+        END;
+        IF ~ IDE THEN CRX.WriteStatistics END;
+      END;
+      IF ~ ok THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        IF IDE THEN
+          FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) ")
+        END;
+        FileIO.WriteString(FileIO.StdOut, "Compilation ended with errors in grammar tests.");
+      ELSIF ~ ll1 THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        IF IDE THEN
+          FileIO.WriteString(lst, ATGFileName);
+          FileIO.WriteString(lst, " (0, 0) ")
+        END;
+        FileIO.WriteString(FileIO.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;
+    FileIO.WriteLn(FileIO.StdOut);
+    IF CRT.ddt["G"] THEN CRT.PrintGraph END;
+    IF CRT.ddt["S"] THEN CRT.PrintSymbolTable END;
+    FileIO.Close(lst); FileIO.Close(src);
+(*
+    IF ~ IDE THEN
+      FileIO.WriteLn(FileIO.StdOut); FileIO.WriteExecutionTime(FileIO.StdOut)
+    END
+*)
+  END -->Grammar.

CRQ.mod

@@ -0,0 +1,601 @@
+(* 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.

CRS.def

@@ -0,0 +1,39 @@
+DEFINITION MODULE CRS;
+
+(* Scanner generated by Coco/R - assuming FileIO library will be available. *)
+
+IMPORT FileIO;
+
+TYPE
+  INT32 = FileIO.INT32;
+
+VAR
+  src, lst:    FileIO.File;  (*source/list files. To be opened by the main pgm*)
+  directory:   ARRAY [0 .. 255] OF CHAR (*of source file*);
+  line, col:   INTEGER;      (*line and column of current symbol*)
+  len:         CARDINAL;     (*length of current symbol*)
+  pos:         INT32;        (*file position of current symbol*)
+  nextLine:    INTEGER;      (*line of lookahead symbol*)
+  nextCol:     INTEGER;      (*column of lookahead symbol*)
+  nextLen:     CARDINAL;     (*length of lookahead symbol*)
+  nextPos:     INT32;        (*file position of lookahead symbol*)
+  errors:      INTEGER;      (*number of detected errors*)
+  Error:       PROCEDURE ((*nr*)INTEGER, (*line*)INTEGER, (*col*)INTEGER,
+                          (*pos*)INT32);
+
+PROCEDURE Get (VAR sym: CARDINAL);
+(* Gets next symbol from source file *)
+
+PROCEDURE GetString (pos: INT32; len: CARDINAL; VAR name: ARRAY OF CHAR);
+(* Retrieves exact string of max length len from position pos in source file *)
+
+PROCEDURE GetName (pos: INT32; len: CARDINAL; VAR name: ARRAY OF CHAR);
+(* Retrieves name of symbol of length len at position pos in source file *)
+
+PROCEDURE CharAt (pos: INT32): CHAR;
+(* Returns exact character at position pos in source file *)
+
+PROCEDURE Reset;
+(* Reads and stores source file internally *)
+
+END CRS.

CRS.mod

@@ -0,0 +1,372 @@
+IMPLEMENTATION MODULE CRS;
+
+(* Scanner generated by Coco/R - assuming FileIO library will be available. *)
+
+IMPORT FileIO, Storage;
+
+CONST
+  noSYMB  = 41; (*error token code*)
+  (* not only for errors but also for not finished states of scanner analysis *)
+  eof     = 32C (* MS-DOS Keyboard eof char *);
+  EOF     = FileIO.EOF;
+  EOL     = FileIO.CR;
+  CR      = FileIO.CR;
+  LF      = FileIO.LF;
+  Long0   = FileIO.Long0;
+  Long1   = FileIO.Long1;
+  BlkSize = 16384;
+TYPE
+  BufBlock   = ARRAY [0 .. BlkSize-1] OF CHAR;
+  Buffer     = ARRAY [0 .. 31] OF POINTER TO BufBlock;
+  StartTable = ARRAY [0 .. 255] OF INTEGER;
+  GetCH      = PROCEDURE (INT32): CHAR;
+VAR
+  lastCh,
+  ch:        CHAR;       (*current input character*)
+  curLine:   INTEGER;    (*current input line (may be higher than line)*)
+  lineStart: INT32;      (*start position of current line*)
+  apx:       INT32;      (*length of appendix (CONTEXT phrase)*)
+  oldEols:   INTEGER;    (*number of EOLs in a comment*)
+  bp, bp0:   INT32;      (*current position in buf
+                           (bp0: position of current token)*)
+  LBlkSize:  INT32;      (*BlkSize*)
+  inputLen:  INT32;      (*source file size*)
+  buf:       Buffer;     (*source buffer for low-level access*)
+  start:     StartTable; (*start state for every character*)
+  CurrentCh: GetCH;
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+ BEGIN
+   RETURN FileIO.ORDL(n)
+ END ORDL;
+
+PROCEDURE Err (nr, line, col: INTEGER; pos: INT32);
+  BEGIN
+    INC(errors)
+  END Err;
+
+PROCEDURE NextCh;
+(* Return global variable ch *)
+  BEGIN
+    lastCh := ch; INC(bp); ch := CurrentCh(bp);
+    IF (ch = EOL) OR (ch = FileIO.LF) AND (lastCh # EOL) THEN
+      INC(curLine); lineStart := bp
+    END
+  END NextCh;
+
+PROCEDURE Comment (): BOOLEAN;
+  VAR
+    level, startLine: INTEGER;
+    oldLineStart: INT32;
+  BEGIN
+    level := 1; startLine := curLine; oldLineStart := lineStart;
+    IF (ch = "/") THEN
+      NextCh;
+      IF (ch = "*") THEN
+        NextCh;
+        LOOP
+          IF (ch = "*") THEN
+            NextCh;
+            IF (ch = "/") THEN
+              DEC(level); NextCh;
+              IF level = 0 THEN RETURN TRUE END
+            END;
+          ELSIF ch = EOF THEN RETURN FALSE
+          ELSE NextCh END;
+        END; (* LOOP *)
+      ELSE
+        IF (ch = CR) OR (ch = LF) THEN
+          DEC(curLine); lineStart := oldLineStart
+        END;
+        DEC(bp); ch := lastCh;
+      END;
+    END;
+    IF (ch = "(") THEN
+      NextCh;
+      IF (ch = "*") THEN
+        NextCh;
+        LOOP
+          IF (ch = "*") THEN
+            NextCh;
+            IF (ch = ")") THEN
+              DEC(level); NextCh;
+              IF level = 0 THEN RETURN TRUE END
+            END;
+          ELSIF (ch = "(") THEN
+            NextCh;
+            IF (ch = "*") THEN INC(level); NextCh END;
+          ELSIF ch = EOF THEN RETURN FALSE
+          ELSE NextCh END;
+        END; (* LOOP *)
+      ELSE
+        IF (ch = CR) OR (ch = LF) THEN
+          DEC(curLine); lineStart := oldLineStart
+        END;
+        DEC(bp); ch := lastCh;
+      END;
+    END;
+    RETURN FALSE;
+  END Comment;
+
+PROCEDURE Get (VAR sym: CARDINAL);
+  VAR
+    state: CARDINAL;
+
+  PROCEDURE Equal (s: ARRAY OF CHAR): BOOLEAN;
+    VAR
+      i: CARDINAL;
+      q: INT32;
+    BEGIN
+      IF nextLen # FileIO.SLENGTH(s) THEN RETURN FALSE END;
+      i := 1; q := bp0; INC(q);
+      WHILE i < nextLen DO
+        IF CurrentCh(q) # s[i] THEN RETURN FALSE END;
+        INC(i); INC(q)
+      END;
+      RETURN TRUE
+    END Equal;
+
+  PROCEDURE CheckLiteral;
+    BEGIN
+      CASE CurrentCh(bp0) OF
+        "A": IF Equal("ANY") THEN sym := 23; 
+             END
+      | "C": IF Equal("CASE") THEN sym := 19; 
+             ELSIF Equal("CHARACTERS") THEN sym := 10; 
+             ELSIF Equal("CHR") THEN sym := 24; 
+             ELSIF Equal("COMMENTS") THEN sym := 14; 
+             ELSIF Equal("COMPILER") THEN sym := 5; 
+             ELSIF Equal("CONTEXT") THEN sym := 34; 
+             END
+      | "E": IF Equal("END") THEN sym := 9; 
+             END
+      | "F": IF Equal("FROM") THEN sym := 15; 
+             END
+      | "I": IF Equal("IGNORE") THEN sym := 18; 
+             END
+      | "N": IF Equal("NAMES") THEN sym := 12; 
+             ELSIF Equal("NESTED") THEN sym := 17; 
+             END
+      | "P": IF Equal("PRAGMAS") THEN sym := 13; 
+             ELSIF Equal("PRODUCTIONS") THEN sym := 6; 
+             END
+      | "S": IF Equal("SYNC") THEN sym := 33; 
+             END
+      | "T": IF Equal("TO") THEN sym := 16; 
+             ELSIF Equal("TOKENS") THEN sym := 11; 
+             END
+      | "W": IF Equal("WEAK") THEN sym := 28; 
+             END
+      ELSE
+      END
+    END CheckLiteral;
+
+  BEGIN (*Get*)
+    WHILE (ch = ' ') OR
+          ((ch >= CHR(9)) & (ch <= CHR(10)) OR
+          (ch = CHR(13))) DO NextCh END;
+    IF ((ch = "/") OR (ch = "(")) & Comment() THEN Get(sym); RETURN END;
+    pos := nextPos;   nextPos := bp;
+    col := nextCol;   nextCol := FileIO.INTL(bp - lineStart);
+    line := nextLine; nextLine := curLine;
+    len := nextLen;   nextLen := 0;
+    apx := FileIO.Long0; state := start[ORD(ch)]; bp0 := bp;
+    LOOP
+      NextCh; INC(nextLen);
+      CASE state OF
+         1: IF ((ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch = "_") OR
+               (ch >= "a") & (ch <= "z")) THEN 
+            ELSE sym := 1; CheckLiteral; RETURN
+            END;
+      |  2: sym := 2; RETURN
+      |  3: sym := 3; RETURN
+      |  4: IF ((ch >= "0") & (ch <= "9")) THEN 
+            ELSE sym := 4; RETURN
+            END;
+      |  5: IF ((ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch = "_") OR
+               (ch >= "a") & (ch <= "z")) THEN 
+            ELSE sym := 42; RETURN
+            END;
+      |  6: IF ((ch = CHR(0)) OR
+               (ch >= " ") & (ch <= "!") OR
+               (ch >= "#")) THEN 
+            ELSIF ((ch = CHR(10)) OR
+                  (ch = CHR(13))) THEN state := 3; 
+            ELSIF (ch = '"') THEN state := 2; 
+            ELSE sym := noSYMB; RETURN
+            END;
+      |  7: IF ((ch = CHR(0)) OR
+               (ch >= " ") & (ch <= "&") OR
+               (ch >= "(")) THEN 
+            ELSIF ((ch = CHR(10)) OR
+                  (ch = CHR(13))) THEN state := 3; 
+            ELSIF (ch = "'") THEN state := 2; 
+            ELSE sym := noSYMB; RETURN
+            END;
+      |  8: sym := 7; RETURN
+      |  9: IF (ch = ".") THEN state := 12; 
+            ELSIF (ch = ">") THEN state := 23; 
+            ELSIF (ch = ")") THEN state := 25; 
+            ELSE sym := 8; RETURN
+            END;
+      | 10: sym := 20; RETURN
+      | 11: sym := 21; RETURN
+      | 12: sym := 22; RETURN
+      | 13: IF (ch = ".") THEN state := 24; 
+            ELSE sym := 25; RETURN
+            END;
+      | 14: sym := 26; RETURN
+      | 15: sym := 27; RETURN
+      | 16: sym := 29; RETURN
+      | 17: sym := 30; RETURN
+      | 18: sym := 31; RETURN
+      | 19: sym := 32; RETURN
+      | 20: IF (ch = ".") THEN state := 22; 
+            ELSE sym := 35; RETURN
+            END;
+      | 21: sym := 36; RETURN
+      | 22: sym := 37; RETURN
+      | 23: sym := 38; RETURN
+      | 24: sym := 39; RETURN
+      | 25: sym := 40; RETURN
+      | 26: sym := 0; ch := 0C; DEC(bp); RETURN
+      ELSE sym := noSYMB; RETURN (*NextCh already done*)
+      END
+    END
+  END Get;
+
+PROCEDURE GetString (pos: INT32; len: CARDINAL; VAR s: ARRAY OF CHAR);
+  VAR
+    i: CARDINAL;
+    p: INT32;
+  BEGIN
+    IF len > HIGH(s) THEN len := HIGH(s) END;
+    p := pos; i := 0;
+    WHILE i < len DO
+      s[i] := CharAt(p); INC(i); INC(p)
+    END;
+    s[len] := 0C;
+  END GetString;
+
+PROCEDURE GetName (pos: INT32; len: CARDINAL; VAR s: ARRAY OF CHAR);
+  VAR
+    i: CARDINAL;
+    p: INT32;
+  BEGIN
+    IF len > HIGH(s) THEN len := HIGH(s) END;
+    p := pos; i := 0;
+    WHILE i < len DO
+      s[i] := CurrentCh(p); INC(i); INC(p)
+    END;
+    s[len] := 0C;
+  END GetName;
+
+PROCEDURE CharAt (pos: INT32): CHAR;
+  VAR
+    ch: CHAR;
+  BEGIN
+    IF pos >= inputLen THEN RETURN FileIO.EOF END;
+    ch := buf[FileIO.ORDL(pos DIV LBlkSize)]^[FileIO.ORDL(pos MOD LBlkSize)];
+    IF ch # eof THEN RETURN ch ELSE RETURN FileIO.EOF END
+  END CharAt;
+
+PROCEDURE CapChAt (pos: INT32): CHAR;
+  VAR
+    ch: CHAR;
+  BEGIN
+    IF pos >= inputLen THEN RETURN FileIO.EOF END;
+    ch := CAP(buf[FileIO.ORDL(pos DIV LBlkSize)]^[FileIO.ORDL(pos MOD LBlkSize)]);
+    IF ch # eof THEN RETURN ch ELSE RETURN FileIO.EOF END
+  END CapChAt;
+
+PROCEDURE Reset;
+  VAR
+    len: INT32;
+    i, read: CARDINAL;
+  BEGIN (*assert: src has been opened*)
+    len := FileIO.Length(src); i := 0; inputLen := len;
+    WHILE len > LBlkSize DO
+      Storage.ALLOCATE(buf[i], BlkSize);
+      read := BlkSize; FileIO.ReadBytes(src, buf[i]^, read);
+      len := len - FileIO.INT(read); INC(i)
+    END;
+    Storage.ALLOCATE(buf[i], FileIO.ORDL(len) + 1);
+    read := FileIO.ORDL(len); FileIO.ReadBytes(src, buf[i]^, read);
+    buf[i]^[read] := EOF;
+    curLine := 1; lineStart := -FileIO.Long2; bp := -FileIO.Long1;
+    oldEols := 0; apx := FileIO.Long0; errors := 0;
+    NextCh;
+  END Reset;
+
+BEGIN
+  CurrentCh := CharAt;
+  start[  0] := 26; start[  1] := 27; start[  2] := 27; start[  3] := 27; 
+  start[  4] := 27; start[  5] := 27; start[  6] := 27; start[  7] := 27; 
+  start[  8] := 27; start[  9] := 27; start[ 10] := 27; start[ 11] := 27; 
+  start[ 12] := 27; start[ 13] := 27; start[ 14] := 27; start[ 15] := 27; 
+  start[ 16] := 27; start[ 17] := 27; start[ 18] := 27; start[ 19] := 27; 
+  start[ 20] := 27; start[ 21] := 27; start[ 22] := 27; start[ 23] := 27; 
+  start[ 24] := 27; start[ 25] := 27; start[ 26] := 27; start[ 27] := 27; 
+  start[ 28] := 27; start[ 29] := 27; start[ 30] := 27; start[ 31] := 27; 
+  start[ 32] := 27; start[ 33] := 27; start[ 34] :=  6; start[ 35] := 27; 
+  start[ 36] :=  5; start[ 37] := 27; start[ 38] := 27; start[ 39] :=  7; 
+  start[ 40] := 13; start[ 41] := 14; start[ 42] := 27; start[ 43] := 10; 
+  start[ 44] := 27; start[ 45] := 11; start[ 46] :=  9; start[ 47] := 27; 
+  start[ 48] :=  4; start[ 49] :=  4; start[ 50] :=  4; start[ 51] :=  4; 
+  start[ 52] :=  4; start[ 53] :=  4; start[ 54] :=  4; start[ 55] :=  4; 
+  start[ 56] :=  4; start[ 57] :=  4; start[ 58] := 27; start[ 59] := 27; 
+  start[ 60] := 20; start[ 61] :=  8; start[ 62] := 21; start[ 63] := 27; 
+  start[ 64] := 27; start[ 65] :=  1; start[ 66] :=  1; start[ 67] :=  1; 
+  start[ 68] :=  1; start[ 69] :=  1; start[ 70] :=  1; start[ 71] :=  1; 
+  start[ 72] :=  1; start[ 73] :=  1; start[ 74] :=  1; start[ 75] :=  1; 
+  start[ 76] :=  1; start[ 77] :=  1; start[ 78] :=  1; start[ 79] :=  1; 
+  start[ 80] :=  1; start[ 81] :=  1; start[ 82] :=  1; start[ 83] :=  1; 
+  start[ 84] :=  1; start[ 85] :=  1; start[ 86] :=  1; start[ 87] :=  1; 
+  start[ 88] :=  1; start[ 89] :=  1; start[ 90] :=  1; start[ 91] := 16; 
+  start[ 92] := 27; start[ 93] := 17; start[ 94] := 27; start[ 95] :=  1; 
+  start[ 96] := 27; start[ 97] :=  1; start[ 98] :=  1; start[ 99] :=  1; 
+  start[100] :=  1; start[101] :=  1; start[102] :=  1; start[103] :=  1; 
+  start[104] :=  1; start[105] :=  1; start[106] :=  1; start[107] :=  1; 
+  start[108] :=  1; start[109] :=  1; start[110] :=  1; start[111] :=  1; 
+  start[112] :=  1; start[113] :=  1; start[114] :=  1; start[115] :=  1; 
+  start[116] :=  1; start[117] :=  1; start[118] :=  1; start[119] :=  1; 
+  start[120] :=  1; start[121] :=  1; start[122] :=  1; start[123] := 18; 
+  start[124] := 15; start[125] := 19; start[126] := 27; start[127] := 27; 
+  start[128] := 27; start[129] := 27; start[130] := 27; start[131] := 27; 
+  start[132] := 27; start[133] := 27; start[134] := 27; start[135] := 27; 
+  start[136] := 27; start[137] := 27; start[138] := 27; start[139] := 27; 
+  start[140] := 27; start[141] := 27; start[142] := 27; start[143] := 27; 
+  start[144] := 27; start[145] := 27; start[146] := 27; start[147] := 27; 
+  start[148] := 27; start[149] := 27; start[150] := 27; start[151] := 27; 
+  start[152] := 27; start[153] := 27; start[154] := 27; start[155] := 27; 
+  start[156] := 27; start[157] := 27; start[158] := 27; start[159] := 27; 
+  start[160] := 27; start[161] := 27; start[162] := 27; start[163] := 27; 
+  start[164] := 27; start[165] := 27; start[166] := 27; start[167] := 27; 
+  start[168] := 27; start[169] := 27; start[170] := 27; start[171] := 27; 
+  start[172] := 27; start[173] := 27; start[174] := 27; start[175] := 27; 
+  start[176] := 27; start[177] := 27; start[178] := 27; start[179] := 27; 
+  start[180] := 27; start[181] := 27; start[182] := 27; start[183] := 27; 
+  start[184] := 27; start[185] := 27; start[186] := 27; start[187] := 27; 
+  start[188] := 27; start[189] := 27; start[190] := 27; start[191] := 27; 
+  start[192] := 27; start[193] := 27; start[194] := 27; start[195] := 27; 
+  start[196] := 27; start[197] := 27; start[198] := 27; start[199] := 27; 
+  start[200] := 27; start[201] := 27; start[202] := 27; start[203] := 27; 
+  start[204] := 27; start[205] := 27; start[206] := 27; start[207] := 27; 
+  start[208] := 27; start[209] := 27; start[210] := 27; start[211] := 27; 
+  start[212] := 27; start[213] := 27; start[214] := 27; start[215] := 27; 
+  start[216] := 27; start[217] := 27; start[218] := 27; start[219] := 27; 
+  start[220] := 27; start[221] := 27; start[222] := 27; start[223] := 27; 
+  start[224] := 27; start[225] := 27; start[226] := 27; start[227] := 27; 
+  start[228] := 27; start[229] := 27; start[230] := 27; start[231] := 27; 
+  start[232] := 27; start[233] := 27; start[234] := 27; start[235] := 27; 
+  start[236] := 27; start[237] := 27; start[238] := 27; start[239] := 27; 
+  start[240] := 27; start[241] := 27; start[242] := 27; start[243] := 27; 
+  start[244] := 27; start[245] := 27; start[246] := 27; start[247] := 27; 
+  start[248] := 27; start[249] := 27; start[250] := 27; start[251] := 27; 
+  start[252] := 27; start[253] := 27; start[254] := 27; start[255] := 27; 
+  Error := Err; LBlkSize := FileIO.INT(BlkSize); lastCh := EOF;
+END CRS.

CRT.def

@@ -0,0 +1,237 @@
+DEFINITION MODULE CRT;
+(* Symbol Table and Top-Down Graph *)
+
+IMPORT FileIO, Sets;
+
+TYPE
+  INT32 = FileIO.INT32;
+
+CONST
+(* The following are chosen to ensure that data segments remain within the
+   64K limit imposed by Dos 16 bit systems.  Manipulate them at your peril
+   if you need to handle large grammars! *)
+  maxSymbols   =   500; (* max number of symbols
+                           (terminals+nonterminals+pragmas) *)
+  maxTerminals =   400; (* max number of terminals *)
+  maxNt        =   210; (* max number of nonterminals *)
+  maxNodes     =  1500; (* max number of top-down graph nodes *)
+  maxClasses   =   250; (* max number of character classes *)
+  maxSemLen    = 64000; (* max length of a semantic text *)
+  normTrans    =     0; (* DFA transition during normal scanning *)
+  contextTrans =     1; (* DFA transition during scanning of right context *)
+  maxList      =   150; (* max array size in FindCircularProductions *)
+  maxLiterals  =   127; (* max number of literal terminals *)
+
+  (* node types *)
+  unknown =  0;
+  t     =  1; (* terminal symbol *)
+  pr    =  2; (* pragma *)
+  nt    =  3; (* nonterminal symbol *)
+  class =  4; (* character class *)
+  char  =  5; (* single character *)
+  wt    =  6; (* weak terminal symbol *)
+  any   =  7; (* symbol ANY *)
+  eps   =  8; (* empty alternative *)
+  sync  =  9; (* symbol SYNC *)
+  sem   = 10; (* semantic action *)
+  alt   = 11; (* alternative *)
+  iter  = 12; (* iteration *)
+  opt   = 13; (* option *)
+
+  noSym = -1;
+  eofSy =  0;
+
+  (* token kinds *)
+  classToken    = 0;  (* token class *)
+  litToken      = 1;  (* literal (e.g. keyword) not recognized by DFA *)
+  classLitToken = 2;  (* token class that can also match a literal *)
+
+TYPE
+  Name       = ARRAY [0..39] OF CHAR;
+  Position   = RECORD  (* position of stretch of source text *)
+    beg:       INT32;    (* start relative to beginning of file *)
+    len:       CARDINAL; (* length *)
+    col:       INTEGER;  (* column number of start position *)
+  END;
+
+  SymbolNode = RECORD    (* node of symbol table *)
+    typ:       INTEGER;  (* nt, t, pr, unknown *)
+    name,                (* symbol name *)
+    constant:  Name;     (* named constant of symbol *)
+    struct:    INTEGER;  (* typ = nt: index of first node of syntax graph *)
+                         (* typ = t: token kind: literal, class, ... *)
+    deletable: BOOLEAN;  (* typ = nt: TRUE, if nonterminal is deletable *)
+    attrPos:   Position; (* position of attributes in source text *)
+    semPos:    Position; (* typ = pr: pos of sem action in source text *)
+                         (* typ = nt: pos of local decls in source text *)
+    line:      INTEGER;  (* source text line number of symbol in this node *)
+  END;
+
+  GraphNode = RECORD     (* node of top-down graph *)
+    typ: INTEGER;        (* nt,sts,wts,char,class,any,eps,sem,sync,alt,
+                            iter,opt*)
+    next: INTEGER;       (* to successor node *)
+                         (* next < 0: to successor of enclosing structure *)
+    p1: INTEGER;         (* typ IN {nt, t, wt}: index to symbol table *)
+                         (* typ = any: index to anyset *)
+                         (* typ = sync: index to syncset *)
+                         (* typ = alt:
+                                  index of first node of first alternative *)
+                         (* typ IN {iter, opt}: first node in subexpression *)
+                         (* typ = char: ordinal character value *)
+                         (* typ = class: index of character class *)
+    p2: INTEGER;         (* typ = alt:
+                                  index of first node of second alternative *)
+                         (* typ IN {char, class}: transition code *)
+    pos: Position;       (* typ IN {nt, t, wt}:
+                                  source pos of actual attributes *)
+                         (* typ = sem: source pos of sem action *)
+    line: INTEGER;       (* source text line number of item in this node *)
+  END;
+
+  Set  = ARRAY [0 .. maxTerminals DIV Sets.size] OF BITSET;
+  MarkList = ARRAY [0 .. maxNodes DIV Sets.size] OF BITSET;
+
+VAR
+  maxT:        INTEGER;  (* terminals stored from 0 .. maxT in symbol table *)
+  maxP:        INTEGER;  (* pragmas stored from maxT+1..maxP in symbol table *)
+  firstNt:     INTEGER;  (* index of first nt: available after CompSymbolSets *)
+  lastNt:      INTEGER;  (* index of last nt: available after CompSymbolSets *)
+  maxC:        INTEGER;  (* index of last character class *)
+  nNodes:      INTEGER;  (* index of last top-down graph node *)
+  root:        INTEGER;  (* index of root node, filled by ATG *)
+
+  semDeclPos:  Position; (* position of global semantic declarations *)
+  genScanner:  BOOLEAN;  (* TRUE: a scanner shall be generated *)
+  ignoreCase:  BOOLEAN;  (* TRUE: scanner treats lower case as upper case *)
+  symNames:    BOOLEAN;  (* TRUE: symbol names have to be assigned *)
+  ignored:     Set;      (* characters ignored by the scanner *)
+  ddt:         ARRAY ["A" .. "Z"] OF BOOLEAN;
+                         (* parameter, debug and test switches *)
+
+
+PROCEDURE NewName (n: Name; s: ARRAY OF CHAR);
+(* Inserts the pair (n, s) in the token symbol name table *)
+
+PROCEDURE NewSym (t: INTEGER; n: Name; line: INTEGER): INTEGER;
+(* Generates a new symbol with type t and name n and returns its index *)
+
+PROCEDURE GetSym (sp: INTEGER; VAR sn: SymbolNode);
+(* Gets symbol node with index sp in sn. *)
+
+PROCEDURE PutSym (sp: INTEGER; sn: SymbolNode);
+(* Replaces symbol node with index sp by sn. *)
+
+PROCEDURE FindSym (n: Name): INTEGER;
+(* Gets symbol index for identifier with name n. *)
+
+PROCEDURE NewSet (s: Set): INTEGER;
+(* Stores s as a new set and returns its index. *)
+
+PROCEDURE CompFirstSet (gp: INTEGER; VAR first: Set);
+(* Computes start symbols of graph gp. *)
+
+PROCEDURE CompExpected (gp, sp: INTEGER; VAR exp: Set);
+(* Computes all symbols expected at location gp in graph of symbol sp. *)
+
+PROCEDURE CompDeletableSymbols;
+(* Marks deletable nonterminals and prints them. *)
+
+PROCEDURE CompSymbolSets;
+(* Collects first-sets, follow-sets, any-sets, and sync-sets. *)
+
+PROCEDURE PrintSymbolTable;
+(* Prints the symbol table (for tracing). *)
+
+PROCEDURE XRef;
+(* Produces a cross reference listing of all symbols. *)
+
+PROCEDURE NewClass (name: Name; set: Set): INTEGER;
+(* Defines a new character class and returns its index *)
+
+PROCEDURE ClassWithName (name: Name): INTEGER;
+(* Searches for a class with the given name.  Returns its index or -1 *)
+
+PROCEDURE ClassWithSet (set: Set): INTEGER;
+(* Searches for a class with the given set. Returns its index or -1 *)
+
+PROCEDURE GetClass (n: INTEGER; VAR set: Set);
+(* Returns character class n *)
+
+PROCEDURE GetClassName (n: INTEGER; VAR name: Name);
+(* Returns the name of class n *)
+
+PROCEDURE GetSet (nr: INTEGER; VAR set: Set);
+(* Gives access to precomputed symbol sets *)
+
+PROCEDURE NewNode (typ, p1, line: INTEGER): INTEGER;
+(* Generates a new graph node with typ, p1, and source line number
+   line and returns its index. *)
+
+PROCEDURE ClearMarkList (VAR m: MarkList);
+(* Clears all elements of m *)
+
+PROCEDURE GetNode (gp: INTEGER; VAR n: GraphNode);
+(* Gets graph node with index gp in n. *)
+
+PROCEDURE PutNode (gp: INTEGER; n: GraphNode);
+(* Replaces graph node with index gp by n. *)
+
+PROCEDURE ConcatAlt (VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
+(* Makes (gL2, gR2) an alternative of the graph (gL1, gR1).
+   The resulting graph is identified by (gL1, gR1). *)
+
+PROCEDURE ConcatSeq (VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
+(* Concatenates graph (gL1, gR1) with graph (gL2, gR2) via next-chain.
+   The resulting graph is identified by (gL1, gR1). *)
+
+PROCEDURE MakeFirstAlt (VAR gL, gR: INTEGER);
+(* Generates an alt-node with (gL, gR) as its first and only alternative *)
+
+PROCEDURE MakeIteration (VAR gL, gR: INTEGER);
+(* Encloses the graph (gL, gR) into an iteration construct.
+   The resulting graph is identified by (gL, gR). *)
+
+PROCEDURE MakeOption (VAR gL, gR: INTEGER);
+(* Encloses the graph (gL, gR) into an option construct.
+   The resulting graph is identified by (gL, gR). *)
+
+PROCEDURE CompleteGraph (gp: INTEGER);
+(* Lets right ends of graph gp be 0 *)
+
+PROCEDURE StrToGraph (s: ARRAY OF CHAR; VAR gL, gR: INTEGER);
+(* Generates linear graph from characters in s *)
+
+PROCEDURE DelGraph (gp: INTEGER): BOOLEAN;
+(* TRUE, if (sub) graph with root gp is deletable. *)
+
+PROCEDURE DelNode (gn: GraphNode): BOOLEAN;
+(* TRUE, if graph node gn is deletable, i.e. can be derived into the
+   empty string. *)
+
+PROCEDURE PrintGraph;
+(* Prints the graph (for tracing). *)
+
+PROCEDURE FindCircularProductions (VAR ok: BOOLEAN);
+(* Finds and prints the circular part of the grammar.
+   ok = TRUE means no circular part. *)
+
+PROCEDURE LL1Test (VAR ll1: BOOLEAN);
+(* Checks if the grammar satisfies the LL(1) conditions.
+   ll1 = TRUE means no LL(1)-conflicts. *)
+
+PROCEDURE TestCompleteness (VAR ok: BOOLEAN);
+(* ok = TRUE, if all nonterminals have productions. *)
+
+PROCEDURE TestIfAllNtReached (VAR ok: BOOLEAN);
+(* ok = TRUE, if all nonterminals can be reached from the start symbol. *)
+
+PROCEDURE TestIfNtToTerm (VAR ok: BOOLEAN);
+(* ok = TRUE, if all nonterminals can be reduced to terminals. *)
+
+PROCEDURE AssignSymNames (default: BOOLEAN; VAR thereExists: BOOLEAN);
+
+PROCEDURE Restriction (n, limit: INTEGER);
+(* Signal compiler restriction and abort program *)
+
+END CRT.

CRT.mod

@@ -0,0 +1,1435 @@
+IMPLEMENTATION MODULE CRT;
+
+(* CRT   Table Handler
+   ===   =============
+
+  (1) handles a symbol table for terminals, pragmas and nonterminals
+  (2) handles a table for character classes (for scanner generation)
+  (3) handles a top-down graph for productions
+  (4) computes various sets (start symbols, followers, any sets)
+  (5) contains procedures for grammar tests
+
+  --------------------------------------------------------------------*)
+
+IMPORT CRS, FileIO, Sets, Storage;
+IMPORT SYSTEM (* for TSIZE only *);
+
+CONST
+  maxSetNr   = 256;  (* max. number of symbol sets *)
+(* moved next declaration to def module Fri  08-20-1993, and was 150
+  maxClasses = 250;  (* max. number of character classes *) *)
+  maxNames   = 100;  (* max. number of declared token names *)
+
+TYPE
+  FirstSets   = ARRAY [0 .. maxNt] OF RECORD
+    ts:    Set;      (* terminal symbols *)
+    ready: BOOLEAN;  (* TRUE = ts is complete *)
+  END;
+  FollowSets  = ARRAY [0 .. maxNt] OF RECORD
+    ts:  Set;        (* terminal symbols *)
+    nts: Set;        (* nts whose start set is to be included in ts *)
+  END;
+  CharClass   = RECORD
+    name: Name;      (* class name *)
+    set:  INTEGER    (* ptr to set representing the class *)
+  END;
+  SymbolTable = ARRAY [0 .. maxSymbols] OF SymbolNode;
+  ClassTable  = ARRAY [0 .. maxClasses] OF CharClass;
+  GraphList   = ARRAY [0 .. maxNodes] OF GraphNode;
+  SymbolSet   = ARRAY [0 .. maxSetNr] OF Set;
+  NameTable   = ARRAY [1 .. maxNames] OF RECORD name, definition: Name END;
+
+VAR
+  (* moved symbol table to the heap Fri  08-20-1993 to allow larger one *)
+  st:        POINTER TO SymbolTable; (* symbol table for terminals,
+                                         pragmas, and nonterminals *)
+  gn:        POINTER TO GraphList; (* top-down graph *)
+  tt:        NameTable;   (* table of token name declarations *)
+  first:     FirstSets;   (* first[i]  = first symbols of st[i+firstNt] *)
+  follow:    FollowSets;  (* follow[i] = followers of st[i+firstNt] *)
+  chClass:   ClassTable;  (* character classes *)
+  set:       SymbolSet;   (* set[0] = all SYNC symbols *)
+  maxSet:    INTEGER;     (* index of last symbol set *)
+  lastName,
+  dummyName: CARDINAL;    (* for unnamed character classes *)
+  ch:        CHAR;
+
+
+(* Restriction          Implementation restriction
+----------------------------------------------------------------------*)
+PROCEDURE Restriction (n, limit: INTEGER);
+(* Fri  08-20-1993 extended *)
+  BEGIN
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "Restriction  ");
+    FileIO.WriteInt(FileIO.StdOut, n, 1); FileIO.WriteLn(FileIO.StdOut);
+    CASE n OF
+      1  : FileIO.WriteString(FileIO.StdOut, "Too many graph nodes")
+    | 2  : FileIO.WriteString(FileIO.StdOut, "Too many symbols")
+    | 3  : FileIO.WriteString(FileIO.StdOut, "Too many sets")
+    | 4  : FileIO.WriteString(FileIO.StdOut, "Too many character classes")
+    | 5  : FileIO.WriteString(FileIO.StdOut, "Too many symbol sets")
+    | 6  : FileIO.WriteString(FileIO.StdOut, "Too many token names")
+    | 7  : FileIO.WriteString(FileIO.StdOut, "Too many states")
+    | 8  : FileIO.WriteString(FileIO.StdOut, "Semantic text buffer overflow")
+    | 9  : FileIO.WriteString(FileIO.StdOut, "Circular check buffer overflow")
+    | 10 : FileIO.WriteString(FileIO.StdOut, "Too many literal terminals")
+    | 11 : FileIO.WriteString(FileIO.StdOut, "Too many non-terminals")
+    | -1 : FileIO.WriteString(FileIO.StdOut, "Compiler error")
+    END;
+    IF n > 0 THEN
+      FileIO.WriteString(FileIO.StdOut, " (limited to ");
+      FileIO.WriteInt(FileIO.StdOut, limit, 1);
+      FileIO.Write(FileIO.StdOut, ")");
+    END;
+(* maybe we want CRX.WriteStatistics; *)
+    FileIO.QuitExecution
+  END Restriction;
+
+(* MovePragmas          Move pragmas after terminals
+----------------------------------------------------------------------*)
+PROCEDURE MovePragmas;
+  VAR
+    i: INTEGER;
+  BEGIN
+    IF maxP > firstNt THEN
+      i := maxSymbols - 1; maxP := maxT;
+      WHILE i > lastNt DO
+        INC(maxP); IF maxP >= firstNt THEN Restriction(2, maxSymbols) END;
+        st^[maxP] := st^[i]; DEC(i)
+      END;
+    END
+  END MovePragmas;
+
+(* ClearMarkList        Clear mark list m
+----------------------------------------------------------------------*)
+PROCEDURE ClearMarkList (VAR m: MarkList);
+  VAR
+    i: INTEGER;
+  BEGIN
+    i := 0;
+    WHILE i < maxNodes DIV Sets.size DO m[i] := BITSET{}; INC(i) END;
+  END ClearMarkList;
+
+(* GetNode              Get node with index gp in n
+----------------------------------------------------------------------*)
+PROCEDURE GetNode (gp: INTEGER; VAR n: GraphNode);
+  BEGIN
+    n := gn^[gp]
+  END GetNode;
+
+(* PutNode              Replace node with index gp by n
+----------------------------------------------------------------------*)
+PROCEDURE PutNode (gp: INTEGER; n: GraphNode);
+  BEGIN
+    gn^[gp] := n
+  END PutNode;
+
+(* NewName              Collects a user defined token name
+----------------------------------------------------------------------*)
+PROCEDURE NewName (n: Name; s: ARRAY OF CHAR);
+  BEGIN
+    IF lastName = maxNames THEN Restriction(6, maxNames)
+    ELSE
+      INC(lastName); symNames := TRUE;
+      tt[lastName].name := n; FileIO.Assign(s, tt[lastName].definition);
+    END;
+  END NewName;
+
+(* NewSym               Generate a new symbol and return its index
+----------------------------------------------------------------------*)
+PROCEDURE NewSym (typ: INTEGER; name: Name; line: INTEGER): INTEGER;
+  VAR
+    i: INTEGER;
+  BEGIN
+    IF maxT + 1 = firstNt THEN Restriction(2, maxSymbols)
+    ELSE
+      CASE typ OF
+        t:  INC(maxT); i := maxT;
+      | pr: DEC(maxP); DEC(firstNt); DEC(lastNt); i := maxP;
+      | nt, unknown: DEC(firstNt); i := firstNt;
+      END;
+      IF maxT + 1 >= firstNt THEN Restriction(2, maxSymbols) END;
+      st^[i].typ := typ; st^[i].name := name;
+      st^[i].constant := ""; (* Bug fix - PDT *)
+      st^[i].struct := 0;  st^[i].deletable := FALSE;
+      st^[i].attrPos.beg := - FileIO.Long1;
+      st^[i].semPos.beg  := - FileIO.Long1;
+      st^[i].line := line;
+    END;
+    RETURN i;
+  END NewSym;
+
+(* GetSym               Get symbol sp in sn
+----------------------------------------------------------------------*)
+PROCEDURE GetSym (sp: INTEGER; VAR sn: SymbolNode);
+  BEGIN
+    sn := st^[sp]
+  END GetSym;
+
+(* PutSym               Replace symbol with index snix by sn
+----------------------------------------------------------------------*)
+PROCEDURE PutSym (sp: INTEGER; sn: SymbolNode);
+  BEGIN
+    st^[sp] := sn
+  END PutSym;
+
+(* FindSym              Find index of symbol with name n
+----------------------------------------------------------------------*)
+PROCEDURE FindSym (n: Name): INTEGER;
+  VAR
+    i: INTEGER;
+  BEGIN
+    i := 0; (*search in terminal list*)
+    WHILE (i <= maxT) & (FileIO.Compare(st^[i].name, n) # 0) DO
+      INC(i)
+    END;
+    IF i <= maxT THEN RETURN i END;
+    i := firstNt; (*search in nonterminal/pragma list*)
+    WHILE (i < maxSymbols) & (FileIO.Compare(st^[i].name, n) # 0) DO
+      INC(i)
+    END;
+    IF i < maxSymbols THEN RETURN i ELSE RETURN noSym END
+  END FindSym;
+
+(* PrintSet             Print set s
+----------------------------------------------------------------------*)
+PROCEDURE PrintSet (f: FileIO.File; s: ARRAY OF BITSET; indent: INTEGER);
+  CONST
+    maxLineLen = 80;
+  VAR
+    col, i, len: INTEGER;
+    empty: BOOLEAN;
+    sn: SymbolNode;
+  BEGIN
+    i := 0; col := indent; empty := TRUE;
+    WHILE i <= maxT DO
+      IF Sets.In(s, i) THEN
+        empty := FALSE; GetSym(i, sn); len := FileIO.SLENGTH(sn.name);
+        IF col + len + 2 > maxLineLen THEN
+          FileIO.WriteLn(f); col := 1;
+          WHILE col < indent DO FileIO.Write(f, " "); INC(col) END
+        END;
+        FileIO.WriteString(f, sn.name);
+        FileIO.WriteString(f, "  ");
+        INC(col, len + 2)
+      END;
+      INC(i)
+    END;
+    IF empty THEN FileIO.WriteString(f, "-- empty set --") END;
+    FileIO.WriteLn(f)
+  END PrintSet;
+
+(* NewSet               Stores s as a new set and return its index
+----------------------------------------------------------------------*)
+PROCEDURE NewSet (s: Set): INTEGER;
+(*any-set computation requires not to search if s is already in set*)
+  BEGIN
+    INC(maxSet); IF maxSet > maxSetNr THEN Restriction(3, maxSetNr) END;
+    set[maxSet] := s; RETURN maxSet
+  END NewSet;
+
+(* CompFirstSet         Compute first symbols of (sub) graph at gp
+----------------------------------------------------------------------*)
+PROCEDURE CompFirstSet (gp: INTEGER; VAR fs: Set);
+  VAR
+    visited: MarkList;
+
+  PROCEDURE CompFirst (gp: INTEGER; VAR fs: Set);
+    VAR
+      s: Set;
+      gn: GraphNode;
+      sn: SymbolNode;
+    BEGIN
+      Sets.Clear(fs);
+      WHILE (gp # 0) & ~ Sets.In(visited, gp) DO
+        GetNode(gp, gn); Sets.Incl(visited, gp);
+        CASE gn.typ OF
+          nt:
+            IF first[gn.p1 - firstNt].ready THEN
+              Sets.Unite(fs, first[gn.p1 - firstNt].ts);
+            ELSE
+              GetSym(gn.p1, sn);
+              CompFirst(sn.struct, s); Sets.Unite(fs, s);
+            END;
+        | t, wt:
+            Sets.Incl(fs, gn.p1);
+        | any:
+            Sets.Unite(fs, set[gn.p1])
+        | alt, iter, opt:
+            CompFirst(gn.p1, s); Sets.Unite(fs, s);
+            IF gn.typ = alt THEN CompFirst(gn.p2, s); Sets.Unite(fs, s) END
+        ELSE (* eps, sem, sync, ind: nothing *)
+        END;
+        IF ~ DelNode(gn) THEN RETURN END;
+        gp := ABS(gn.next)
+       END
+    END CompFirst;
+
+  BEGIN (* ComputeFirstSet *)
+    ClearMarkList(visited);
+    CompFirst(gp, fs);
+    IF ddt["I"] THEN
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "ComputeFirstSet: gp = ");
+      FileIO.WriteInt(FileIO.StdOut, gp, 1);
+      FileIO.WriteLn(FileIO.StdOut);
+      PrintSet(FileIO.StdOut, fs, 0);
+    END;
+  END CompFirstSet;
+
+(* CompFirstSets        Compute first symbols of nonterminals
+----------------------------------------------------------------------*)
+PROCEDURE CompFirstSets;
+  VAR
+    i: INTEGER;
+    sn: SymbolNode;
+  BEGIN
+    i := firstNt;
+    IF lastNt-firstNt > maxNt THEN Restriction(11, maxNt) END;;
+    WHILE i <= lastNt DO first[i - firstNt].ready := FALSE; INC(i) END;
+    i := firstNt;
+    WHILE i <= lastNt DO (* for all nonterminals *)
+      GetSym(i, sn); CompFirstSet(sn.struct, first[i - firstNt].ts);
+      first[i - firstNt].ready := TRUE;
+      INC(i)
+    END;
+  END CompFirstSets;
+
+(* CompExpected     Compute symbols expected at location gp in Symbol sp
+----------------------------------------------------------------------*)
+PROCEDURE CompExpected (gp, sp: INTEGER; VAR exp: Set);
+  BEGIN
+    CompFirstSet(gp, exp);
+    IF DelGraph(gp) THEN Sets.Unite(exp, follow[sp - firstNt].ts) END
+  END CompExpected;
+
+(* CompFollowSets       Get follow symbols of nonterminals
+----------------------------------------------------------------------*)
+PROCEDURE CompFollowSets;
+  VAR
+    sn: SymbolNode;
+    curSy, i, size: INTEGER;
+    visited: MarkList;
+
+  PROCEDURE CompFol (gp: INTEGER);
+    VAR
+      s: Set;
+      gn: GraphNode;
+    BEGIN
+      WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
+        GetNode(gp, gn); Sets.Incl(visited, gp);
+        IF gn.typ = nt THEN
+          CompFirstSet(ABS(gn.next), s);
+          Sets.Unite(follow[gn.p1 - firstNt].ts, s);
+          IF DelGraph(ABS(gn.next)) THEN
+            Sets.Incl(follow[gn.p1 - firstNt].nts, curSy - firstNt)
+          END
+        ELSIF (gn.typ=opt) OR (gn.typ=iter) THEN CompFol(gn.p1)
+        ELSIF gn.typ = alt THEN CompFol(gn.p1); CompFol(gn.p2)
+        END;
+        gp := gn.next
+      END
+    END CompFol;
+
+  PROCEDURE Complete (i: INTEGER);
+    VAR
+      j: INTEGER;
+    BEGIN
+      IF Sets.In(visited, i) THEN RETURN END;
+      Sets.Incl(visited, i);
+      j := 0;
+      WHILE j <= lastNt - firstNt DO (* for all nonterminals *)
+        IF Sets.In(follow[i].nts, j) THEN
+          Complete(j); Sets.Unite(follow[i].ts, follow[j].ts);
+          (* fix 1.42 *) IF i = curSy THEN Sets.Excl(follow[i].nts, j) END
+        END;
+        INC(j)
+      END;
+    END Complete;
+
+  BEGIN (* GetFollowSets *)
+    size := (lastNt - firstNt + 2) DIV Sets.size;
+    curSy := firstNt;
+    WHILE curSy <= lastNt DO
+      Sets.Clear(follow[curSy - firstNt].ts);
+      i := 0;
+      WHILE i <= size DO
+        follow[curSy - firstNt].nts[i] := BITSET{}; INC(i)
+      END;
+      INC(curSy)
+    END;
+
+    ClearMarkList(visited);
+    curSy := firstNt;         (*get direct successors of nonterminals*)
+    WHILE curSy <= lastNt DO
+      GetSym(curSy, sn); CompFol(sn.struct);
+      INC(curSy)
+    END;
+
+    curSy := 0;               (*add indirect successors to follow.ts*)
+    WHILE curSy <= lastNt - firstNt DO
+      ClearMarkList(visited); Complete(curSy);
+      INC(curSy);
+    END;
+  END CompFollowSets;
+
+(* CompAnySets          Compute all any-sets
+----------------------------------------------------------------------*)
+PROCEDURE CompAnySets;
+  VAR
+    curSy: INTEGER;
+    sn: SymbolNode;
+
+  PROCEDURE LeadingAny (gp: INTEGER; VAR a: GraphNode): BOOLEAN;
+    VAR
+      gn: GraphNode;
+    BEGIN
+      IF gp <= 0 THEN RETURN FALSE END;
+      GetNode(gp, gn);
+      IF (gn.typ = any) THEN a := gn; RETURN TRUE
+      ELSE
+        RETURN (gn.typ = alt) & (LeadingAny(gn.p1, a)
+               OR LeadingAny(gn.p2, a))
+               OR ((gn.typ=opt) OR (gn.typ=iter)) & LeadingAny(gn.p1, a)
+               OR DelNode(gn) & LeadingAny(gn.next, a)
+      END
+    END LeadingAny;
+
+  PROCEDURE FindAS (gp: INTEGER);
+    VAR
+      gn, gn2, a: GraphNode;
+      s1, s2: Set;
+      p: INTEGER;
+    BEGIN
+      WHILE gp > 0 DO
+        GetNode(gp, gn);
+        IF (gn.typ=opt) OR (gn.typ=iter) THEN
+          FindAS(gn.p1);
+          IF LeadingAny(gn.p1, a) THEN
+            CompExpected(ABS(gn.next), curSy, s1);
+            Sets.Differ(set[a.p1], s1)
+          END
+        ELSIF gn.typ = alt THEN
+          p := gp; Sets.Clear(s1);
+          WHILE p # 0 DO
+            GetNode(p, gn2); FindAS(gn2.p1);
+            IF LeadingAny(gn2.p1, a) THEN
+              CompExpected(gn2.p2, curSy, s2); Sets.Unite(s2, s1);
+              Sets.Differ(set[a.p1], s2)
+            ELSE
+              CompFirstSet(gn2.p1, s2); Sets.Unite(s1, s2)
+            END;
+            p := gn2.p2
+          END
+        END;
+        gp := gn.next
+      END
+    END FindAS;
+
+  BEGIN
+    curSy := firstNt;
+    WHILE curSy <= lastNt DO (* for all nonterminals *)
+      GetSym(curSy, sn); FindAS(sn.struct);
+      INC(curSy)
+    END
+  END CompAnySets;
+
+(* CompSyncSets         Compute follow symbols of sync-nodes
+----------------------------------------------------------------------*)
+PROCEDURE CompSyncSets;
+  VAR
+    curSy: INTEGER;
+    sn: SymbolNode;
+    visited: MarkList;
+
+  PROCEDURE CompSync (gp: INTEGER);
+    VAR
+      s: Set;
+      gn: GraphNode;
+    BEGIN
+      WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
+        GetNode(gp, gn); Sets.Incl(visited, gp);
+        IF gn.typ = sync THEN
+          CompExpected(ABS(gn.next), curSy, s);
+          Sets.Incl(s, eofSy); Sets.Unite(set[0], s);
+          gn.p1 := NewSet(s); PutNode(gp, gn)
+        ELSIF gn.typ = alt THEN CompSync(gn.p1); CompSync(gn.p2)
+        ELSIF (gn.typ=opt) OR (gn.typ=iter) THEN CompSync(gn.p1)
+        END;
+        gp := gn.next
+      END
+    END CompSync;
+
+  BEGIN
+    curSy := firstNt; ClearMarkList(visited);
+    WHILE curSy <= lastNt DO
+      GetSym(curSy, sn); CompSync(sn.struct);
+      INC(curSy);
+    END
+  END CompSyncSets;
+
+(* CompDeletableSymbols Compute all deletable symbols and print them
+----------------------------------------------------------------------*)
+PROCEDURE CompDeletableSymbols;
+  VAR
+    changed, none: BOOLEAN;
+    i: INTEGER;
+    sn: SymbolNode;
+  BEGIN
+    REPEAT
+      changed := FALSE;
+      i := firstNt;
+      WHILE i <= lastNt DO (*for all nonterminals*)
+        GetSym(i, sn);
+        IF ~ sn.deletable & (sn.struct # 0) & DelGraph(sn.struct) THEN
+          sn.deletable := TRUE; PutSym(i, sn); changed := TRUE
+        END;
+        INC(i)
+      END;
+    UNTIL ~ changed;
+
+    FileIO.WriteString(CRS.lst, "Deletable symbols:");
+    i := firstNt; none := TRUE;
+    WHILE i <= lastNt DO
+      GetSym(i, sn);
+      IF sn.deletable THEN
+        none := FALSE;
+        FileIO.WriteLn(CRS.lst); FileIO.WriteString(CRS.lst, "     ");
+        FileIO.WriteString(CRS.lst, sn.name)
+      END;
+      INC(i);
+    END;
+    IF none THEN FileIO.WriteString(CRS.lst, "        -- none --") END;
+    FileIO.WriteLn(CRS.lst);
+  END CompDeletableSymbols;
+
+(* CompSymbolSets       Get first-sets, follow-sets, and sync-set
+----------------------------------------------------------------------*)
+PROCEDURE CompSymbolSets;
+  VAR
+    i: INTEGER;
+    sn: SymbolNode;
+  BEGIN
+    MovePragmas;
+    CompDeletableSymbols;
+    CompFirstSets;
+    CompFollowSets;
+    CompAnySets;
+    CompSyncSets;
+    IF ddt["F"] THEN
+      i := firstNt;
+      FileIO.WriteString(CRS.lst, "List of first & follow symbols:");
+      FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+      WHILE i <= lastNt DO (* for all nonterminals *)
+        GetSym(i, sn);
+        FileIO.WriteString(CRS.lst, sn.name); FileIO.WriteLn(CRS.lst);
+        FileIO.WriteString(CRS.lst, "first:   ");
+        PrintSet(CRS.lst, first[i - firstNt].ts, 10);
+        FileIO.WriteString(CRS.lst, "follow:  ");
+        PrintSet(CRS.lst, follow[i - firstNt].ts, 10);
+        FileIO.WriteLn(CRS.lst);
+        INC(i);
+      END;
+
+      i := 0;
+      FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+      FileIO.WriteString(CRS.lst, "List of sets (ANY, SYNC): ");
+      IF maxSet < 0 THEN FileIO.WriteString(CRS.lst, "        -- none --");
+      ELSE FileIO.WriteLn(CRS.lst);
+      END;
+      WHILE i <= maxSet DO
+        FileIO.WriteString(CRS.lst, "     set[");
+        FileIO.WriteInt(CRS.lst, i, 2);
+        FileIO.WriteString(CRS.lst, "] = ");
+        PrintSet(CRS.lst, set[i], 16);
+        INC(i)
+      END;
+      FileIO.WriteLn(CRS.lst);
+    END;
+  END CompSymbolSets;
+
+(* GetFirstSet          Get precomputed first-set for nonterminal sp
+----------------------------------------------------------------------*)
+PROCEDURE GetFirstSet (sp: INTEGER; VAR s: Set);
+  BEGIN
+    s := first[sp - firstNt].ts
+  END GetFirstSet;
+
+(* GetFollowSet         Get precomputed follow-set for nonterminal snix
+----------------------------------------------------------------------*)
+PROCEDURE GetFollowSet (sp: INTEGER; VAR s: Set);
+  BEGIN
+    s := follow[sp - firstNt].ts
+  END GetFollowSet;
+
+(* GetSet               Get set with index nr
+----------------------------------------------------------------------*)
+PROCEDURE GetSet (nr: INTEGER; VAR s: Set);
+  BEGIN
+    s := set[nr]
+  END GetSet;
+
+(* PrintSymbolTable     Print symbol table
+----------------------------------------------------------------------*)
+PROCEDURE PrintSymbolTable;
+  VAR
+    i: INTEGER;
+
+  PROCEDURE WriteBool (b: BOOLEAN);
+    BEGIN
+      IF b THEN FileIO.WriteString(CRS.lst, "  TRUE ");
+      ELSE FileIO.WriteString(CRS.lst, "  FALSE");
+      END;
+    END WriteBool;
+
+  PROCEDURE WriteTyp1 (typ: INTEGER);
+    BEGIN
+      CASE typ OF
+        unknown: FileIO.WriteString(CRS.lst, " unknown");
+      | t      : FileIO.WriteString(CRS.lst, " t      ");
+      | pr     : FileIO.WriteString(CRS.lst, " pr     ");
+      | nt     : FileIO.WriteString(CRS.lst, " nt     ");
+      END;
+    END WriteTyp1;
+
+  BEGIN (* PrintSymbolTable *)
+    FileIO.WriteString(CRS.lst, "SymbolTable:");
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+    FileIO.WriteString(CRS.lst, "nr    definition                ");
+    IF (*CRT.*) ddt["N"] OR (*CRT.*) symNames THEN
+      FileIO.WriteString(CRS.lst, "constant        ")
+    END;
+    FileIO.WriteString(CRS.lst, "typ    hasAttrs struct del  line");
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+    i := 0;
+    WHILE i < maxSymbols DO
+      FileIO.WriteInt(CRS.lst, i, 3); FileIO.WriteText(CRS.lst, "", 3);
+      FileIO.WriteText(CRS.lst, st^[i].name, 26);
+      IF (*CRT.*) ddt["N"] OR (*CRT.*) symNames THEN
+        IF i <= maxT THEN
+          FileIO.WriteText(CRS.lst, st^[i].constant, 16);
+        ELSE
+          FileIO.WriteText(CRS.lst, "", 16);
+        END;
+      END;
+      WriteTyp1(st^[i].typ);
+      WriteBool(st^[i].attrPos.beg >= FileIO.Long0);
+      FileIO.WriteInt(CRS.lst, st^[i].struct, 5);
+      WriteBool(st^[i].deletable);
+      FileIO.WriteInt(CRS.lst, st^[i].line, 5);
+      FileIO.WriteLn(CRS.lst);
+      IF i = maxT THEN i := firstNt ELSE INC(i) END
+    END;
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+  END PrintSymbolTable;
+
+(* NewClass             Define a new character class
+----------------------------------------------------------------------*)
+PROCEDURE NewClass (name: Name; set: Set): INTEGER;
+  BEGIN
+    INC(maxC); IF maxC > maxClasses THEN Restriction(4, maxClasses) END;
+    IF name[0] = "#" THEN
+      name[1] := CHR(ORD("A") + dummyName); INC(dummyName)
+    END;
+    chClass[maxC].name := name; chClass[maxC].set := NewSet(set);
+    RETURN maxC
+  END NewClass;
+
+(* ClassWithName        Return index of class with name n
+----------------------------------------------------------------------*)
+PROCEDURE ClassWithName (n: Name): INTEGER;
+  VAR
+    i: INTEGER;
+  BEGIN
+    i := maxC;
+    WHILE (i >= 0) & (FileIO.Compare(chClass[i].name, n) # 0) DO
+      DEC(i)
+    END;
+    RETURN i
+  END ClassWithName;
+
+(* ClassWithSet        Return index of class with the specified set
+----------------------------------------------------------------------*)
+PROCEDURE ClassWithSet (s: Set): INTEGER;
+  VAR
+    i: INTEGER;
+  BEGIN
+    i := maxC;
+    WHILE (i >= 0) & ~ Sets.Equal(set[chClass[i].set], s) DO DEC(i) END;
+    RETURN i
+  END ClassWithSet;
+
+(* GetClass             Return character class n
+----------------------------------------------------------------------*)
+PROCEDURE GetClass (n: INTEGER; VAR s: Set);
+  BEGIN
+    GetSet(chClass[n].set, s);
+  END GetClass;
+
+(* GetClassName         Get the name of class n
+----------------------------------------------------------------------*)
+PROCEDURE GetClassName (n: INTEGER; VAR name: Name);
+  BEGIN
+    name := chClass[n].name
+  END GetClassName;
+
+(* XRef                 Produce a cross reference listing of all symbols
+----------------------------------------------------------------------*)
+PROCEDURE XRef;
+  CONST
+    maxLineLen = 80;
+  TYPE
+    ListPtr  = POINTER TO ListNode;
+    ListNode = RECORD
+      next: ListPtr;
+      line: INTEGER;
+    END;
+    ListHdr  = RECORD
+      name: Name;
+      lptr: ListPtr;
+    END;
+  VAR
+    gn: GraphNode;
+    col, i: INTEGER;
+    l, p, q: ListPtr;
+    sn: SymbolNode;
+    xList: ARRAY [0 .. maxSymbols] OF ListHdr;
+
+  BEGIN (* XRef *)
+    IF maxT <= 0 THEN RETURN END;
+    MovePragmas;
+    (* initialize cross reference list *)
+    i := 0;
+    WHILE i <= lastNt DO (* for all symbols *)
+      GetSym(i, sn); xList[i].name := sn.name; xList[i].lptr := NIL;
+      IF i = maxP THEN i := firstNt ELSE INC(i) END
+    END;
+
+    (* search lines where symbol has been referenced *)
+    i := 1;
+    WHILE i <= nNodes DO (* for all graph nodes *)
+      GetNode(i, gn);
+      IF (gn.typ = t) OR (gn.typ = wt) OR (gn.typ = nt) THEN
+        Storage.ALLOCATE(l, SYSTEM.TSIZE(ListNode));
+        l^.next := xList[gn.p1].lptr; l^.line := gn.line;
+        xList[gn.p1].lptr := l
+      END;
+      INC(i);
+    END;
+
+    (* search lines where symbol has been defined and insert in order *)
+    i := 1;
+    WHILE i <= lastNt DO (*for all symbols*)
+      GetSym(i, sn); p := xList[i].lptr; q := NIL;
+      WHILE (p # NIL) & (p^.line > sn.line) DO q := p; p := p^.next END;
+      Storage.ALLOCATE(l, SYSTEM.TSIZE(ListNode)); l^.next := p;
+      l^.line := -sn.line;
+      IF q # NIL THEN q^.next := l ELSE xList[i].lptr := l END;
+      IF i = maxP THEN i := firstNt ELSE INC(i) END
+    END;
+
+    (* print cross reference listing *)
+    FileIO.WriteString(CRS.lst, "Cross reference list:");
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+    FileIO.WriteString(CRS.lst, "Terminals:"); FileIO.WriteLn(CRS.lst);
+    FileIO.WriteString(CRS.lst, "  0  EOF"); FileIO.WriteLn(CRS.lst);
+    i := 1;
+    WHILE i <= lastNt DO (* for all symbols *)
+      IF i = maxT THEN
+        FileIO.WriteLn(CRS.lst);
+        FileIO.WriteString(CRS.lst, "Pragmas:"); FileIO.WriteLn(CRS.lst);
+      ELSE
+        FileIO.WriteInt(CRS.lst, i, 3); FileIO.WriteString(CRS.lst, "  ");
+        FileIO.WriteText(CRS.lst, xList[i].name, 25);
+        l := xList[i].lptr; col := 35;
+        WHILE l # NIL DO
+          IF col + 5 > maxLineLen THEN
+            FileIO.WriteLn(CRS.lst); FileIO.WriteText(CRS.lst, "", 30);
+            col := 35
+          END;
+          IF l^.line = 0 THEN FileIO.WriteString(CRS.lst, "undef")
+          ELSE FileIO.WriteInt(CRS.lst, l^.line, 5)
+          END;
+          INC(col, 5);
+          l := l^.next
+        END;
+        FileIO.WriteLn(CRS.lst);
+      END;
+      IF i = maxP THEN
+        FileIO.WriteLn(CRS.lst);
+        FileIO.WriteString(CRS.lst, "Nonterminals:");
+        FileIO.WriteLn(CRS.lst);
+        i := firstNt
+      ELSE INC(i)
+      END
+    END;
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+  END XRef;
+
+(* NewNode              Generate a new graph node and return its index gp
+----------------------------------------------------------------------*)
+PROCEDURE NewNode (typ, p1, line: INTEGER): INTEGER;
+  BEGIN
+    INC(nNodes); IF nNodes > maxNodes THEN Restriction(1, maxNodes) END;
+    gn^[nNodes].typ     := typ;    gn^[nNodes].next     := 0;
+    gn^[nNodes].p1      := p1;     gn^[nNodes].p2       := 0;
+    gn^[nNodes].pos.beg := - FileIO.Long1; (* Bugfix - PDT *)
+    gn^[nNodes].pos.len := 0;      gn^[nNodes].pos.col := 0;
+    gn^[nNodes].line    := line;
+    RETURN nNodes;
+  END NewNode;
+
+(* CompleteGraph        Set right ends of graph gp to 0
+----------------------------------------------------------------------*)
+PROCEDURE CompleteGraph (gp: INTEGER);
+  VAR
+    p: INTEGER;
+  BEGIN
+    WHILE gp # 0 DO
+      p := gn^[gp].next; gn^[gp].next := 0; gp := p
+    END
+  END CompleteGraph;
+
+(* ConcatAlt            Make (gL2, gR2) an alternative of (gL1, gR1)
+----------------------------------------------------------------------*)
+PROCEDURE ConcatAlt (VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
+  VAR
+    p: INTEGER;
+  BEGIN
+    gL2 := NewNode(alt, gL2, 0); p := gL1;
+    WHILE gn^[p].p2 # 0 DO p := gn^[p].p2 END;
+    gn^[p].p2 := gL2; p := gR1;
+    WHILE gn^[p].next # 0 DO p := gn^[p].next END;
+    gn^[p].next := gR2
+  END ConcatAlt;
+
+(* ConcatSeq            Make (gL2, gR2) a successor of (gL1, gR1)
+----------------------------------------------------------------------*)
+PROCEDURE ConcatSeq (VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
+  VAR
+    p, q: INTEGER;
+  BEGIN
+    p := gn^[gR1].next; gn^[gR1].next := gL2; (*head node*)
+    WHILE p # 0 DO (*substructure*)
+      q := gn^[p].next; gn^[p].next := -gL2; p := q
+    END;
+    gR1 := gR2
+  END ConcatSeq;
+
+(* MakeFirstAlt         Generate alt-node with (gL,gR) as only alternative
+----------------------------------------------------------------------*)
+PROCEDURE MakeFirstAlt (VAR gL, gR: INTEGER);
+  BEGIN
+    gL := NewNode(alt, gL, 0); gn^[gL].next := gR; gR := gL
+  END MakeFirstAlt;
+
+(* MakeIteration        Enclose (gL, gR) into iteration node
+----------------------------------------------------------------------*)
+PROCEDURE MakeIteration (VAR gL, gR: INTEGER);
+  VAR
+    p, q: INTEGER;
+  BEGIN
+    gL := NewNode(iter, gL, 0); p := gR; gR := gL;
+    WHILE p # 0 DO
+      q := gn^[p].next; gn^[p].next := - gL; p := q
+    END
+  END MakeIteration;
+
+(* MakeOption           Enclose (gL, gR) into option node
+----------------------------------------------------------------------*)
+PROCEDURE MakeOption (VAR gL, gR: INTEGER);
+  BEGIN
+    gL := NewNode(opt, gL, 0); gn^[gL].next := gR; gR := gL
+  END MakeOption;
+
+(* StrToGraph           Generate node chain from characters in s
+----------------------------------------------------------------------*)
+PROCEDURE StrToGraph (s: ARRAY OF CHAR; VAR gL, gR: INTEGER);
+  VAR
+    i, len: CARDINAL;
+  BEGIN
+    gR := 0; i := 1; len := FileIO.SLENGTH(s) - 1; (*strip quotes*)
+    WHILE i < len DO
+      gn^[gR].next := NewNode(char, ORD(s[i]), 0); gR := gn^[gR].next;
+      INC(i)
+    END;
+    gL := gn^[0].next; gn^[0].next := 0
+  END StrToGraph;
+
+(* DelGraph             Check if graph starting with index gp is deletable
+----------------------------------------------------------------------*)
+PROCEDURE DelGraph (gp: INTEGER): BOOLEAN;
+  VAR
+    gn: GraphNode;
+  BEGIN
+    IF gp = 0 THEN RETURN TRUE END; (*end of graph found*)
+    GetNode(gp, gn);
+    RETURN DelNode(gn) & DelGraph(ABS(gn.next));
+  END DelGraph;
+
+(* DelNode              Check if graph node gn is deletable
+----------------------------------------------------------------------*)
+PROCEDURE DelNode (gn: GraphNode): BOOLEAN;
+  VAR
+    sn: SymbolNode;
+
+  PROCEDURE DelAlt (gp: INTEGER): BOOLEAN;
+    VAR
+      gn: GraphNode;
+    BEGIN
+      IF gp <= 0 THEN RETURN TRUE END; (*end of graph found*)
+      GetNode(gp, gn);
+      RETURN DelNode(gn) & DelAlt(gn.next);
+    END DelAlt;
+
+  BEGIN
+    IF gn.typ = nt THEN GetSym(gn.p1, sn); RETURN sn.deletable
+    ELSIF gn.typ = alt THEN
+      RETURN DelAlt(gn.p1) OR (gn.p2 # 0) & DelAlt(gn.p2)
+    ELSE RETURN (gn.typ = eps) OR (gn.typ = iter)
+                OR (gn.typ = opt) OR (gn.typ = sem) OR (gn.typ = sync)
+    END
+  END DelNode;
+
+(* PrintGraph           Print the graph
+----------------------------------------------------------------------*)
+PROCEDURE PrintGraph;
+  VAR
+    i: INTEGER;
+
+  PROCEDURE WriteTyp2 (typ: INTEGER);
+    BEGIN
+      CASE typ OF
+        nt  : FileIO.WriteString(CRS.lst, "nt  ")
+      | t   : FileIO.WriteString(CRS.lst, "t   ")
+      | wt  : FileIO.WriteString(CRS.lst, "wt  ")
+      | any : FileIO.WriteString(CRS.lst, "any ")
+      | eps : FileIO.WriteString(CRS.lst, "eps ")
+      | sem : FileIO.WriteString(CRS.lst, "sem ")
+      | sync: FileIO.WriteString(CRS.lst, "sync")
+      | alt : FileIO.WriteString(CRS.lst, "alt ")
+      | iter: FileIO.WriteString(CRS.lst, "iter")
+      | opt : FileIO.WriteString(CRS.lst, "opt ")
+      ELSE    FileIO.WriteString(CRS.lst, "--- ")
+      END;
+    END WriteTyp2;
+
+  BEGIN (* PrintGraph *)
+    FileIO.WriteString(CRS.lst, "GraphList:");
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+    FileIO.WriteString(CRS.lst, " nr   typ    next     p1     p2   line");
+(* useful for debugging - PDT *)
+    FileIO.WriteString(CRS.lst, " posbeg poslen poscol");
+(* *)
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+    i := 0;
+    WHILE i <= nNodes DO
+      FileIO.WriteInt(CRS.lst, i, 3); FileIO.WriteString(CRS.lst, "   ");
+      WriteTyp2(gn^[i].typ); FileIO.WriteInt(CRS.lst, gn^[i].next, 7);
+      FileIO.WriteInt(CRS.lst, gn^[i].p1, 7);
+      FileIO.WriteInt(CRS.lst, gn^[i].p2, 7);
+      FileIO.WriteInt(CRS.lst, gn^[i].line, 7);
+(* useful for debugging - PDT *)
+      FileIO.WriteInt(CRS.lst, FileIO.INTL(gn^[i].pos.beg), 7);
+      FileIO.WriteCard(CRS.lst, gn^[i].pos.len, 7);
+      FileIO.WriteInt(CRS.lst, gn^[i].pos.col, 7);
+(*  *)
+      FileIO.WriteLn(CRS.lst);
+      INC(i);
+    END;
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+  END PrintGraph;
+
+(* FindCircularProductions      Test grammar for circular derivations
+----------------------------------------------------------------------*)
+PROCEDURE FindCircularProductions (VAR ok: BOOLEAN);
+  TYPE
+    ListEntry = RECORD
+      left: INTEGER;
+      right: INTEGER;
+      deleted: BOOLEAN;
+    END;
+  VAR
+    changed, onLeftSide,
+    onRightSide: BOOLEAN;
+    i, j, listLength: INTEGER;
+    list: ARRAY [0 .. maxList] OF ListEntry;
+    singles: MarkList;
+    sn: SymbolNode;
+
+  PROCEDURE GetSingles (gp: INTEGER; VAR singles: MarkList);
+    VAR
+      gn: GraphNode;
+    BEGIN
+      IF gp <= 0 THEN RETURN END; (* end of graph found *)
+      GetNode (gp, gn);
+      IF gn.typ = nt THEN
+        IF DelGraph(ABS(gn.next)) THEN Sets.Incl(singles, gn.p1) END
+      ELSIF (gn.typ = alt) OR (gn.typ = iter) OR (gn.typ = opt) THEN
+        IF DelGraph(ABS(gn.next)) THEN
+          GetSingles(gn.p1, singles);
+          IF gn.typ = alt THEN GetSingles(gn.p2, singles) END
+        END
+      END;
+      IF DelNode(gn) THEN GetSingles(gn.next, singles) END
+    END GetSingles;
+
+  BEGIN (* FindCircularProductions *)
+    i := firstNt; listLength := 0;
+    WHILE i <= lastNt DO (* for all nonterminals i *)
+      ClearMarkList(singles); GetSym(i, sn);
+      GetSingles(sn.struct, singles); (* get nt's j such that i-->j *)
+      j := firstNt;
+      WHILE j <= lastNt DO (* for all nonterminals j *)
+        IF Sets.In(singles, j) THEN
+          list[listLength].left := i; list[listLength].right := j;
+          list[listLength].deleted := FALSE;
+          INC(listLength);
+          IF listLength > maxList THEN Restriction(9, maxList) END
+        END;
+        INC(j)
+      END;
+      INC(i)
+    END;
+
+    REPEAT
+      i := 0; changed := FALSE;
+      WHILE i < listLength DO
+        IF ~ list[i].deleted THEN
+          j := 0; onLeftSide := FALSE; onRightSide := FALSE;
+          WHILE j < listLength DO
+            IF ~ list[j].deleted THEN
+              IF list[i].left = list[j].right THEN onRightSide := TRUE END;
+              IF list[j].left = list[i].right THEN onLeftSide := TRUE END
+            END;
+            INC(j)
+          END;
+          IF ~ onRightSide OR ~ onLeftSide THEN
+            list[i].deleted := TRUE; changed := TRUE
+          END
+        END;
+        INC(i)
+      END
+    UNTIL ~ changed;
+
+    FileIO.WriteString(CRS.lst, "Circular derivations:    ");
+    i := 0; ok := TRUE;
+    WHILE i < listLength DO
+      IF ~ list[i].deleted THEN
+        ok := FALSE;
+        FileIO.WriteLn(CRS.lst); FileIO.WriteString(CRS.lst, "     ");
+        GetSym(list[i].left, sn); FileIO.WriteText(CRS.lst, sn.name, 20);
+        FileIO.WriteString(CRS.lst, " --> ");
+        GetSym(list[i].right, sn); FileIO.WriteText(CRS.lst, sn.name, 20);
+      END;
+      INC(i)
+    END;
+    IF ok THEN FileIO.WriteString(CRS.lst, " -- none --") END;
+    FileIO.WriteLn(CRS.lst);
+  END FindCircularProductions;
+
+(* LL1Test              Collect terminal sets and checks LL(1) conditions
+----------------------------------------------------------------------*)
+PROCEDURE LL1Test (VAR ll1: BOOLEAN);
+  VAR
+    sn: SymbolNode;
+    curSy: INTEGER;
+
+  PROCEDURE LL1Error (cond, ts: INTEGER);
+    VAR
+      sn: SymbolNode;
+    BEGIN
+      ll1 := FALSE;
+      FileIO.WriteLn(CRS.lst);
+      FileIO.WriteString(CRS.lst, " LL(1) error in ");
+      GetSym(curSy, sn); FileIO.WriteString(CRS.lst, sn.name);
+      FileIO.WriteString(CRS.lst, ": ");
+      IF ts > 0 THEN
+        GetSym(ts, sn); FileIO.WriteString(CRS.lst, sn.name);
+        FileIO.WriteString(CRS.lst, " is ");
+      END;
+      CASE cond OF
+        1: FileIO.WriteString(CRS.lst,
+                  "the start of several alternatives.")
+      | 2: FileIO.WriteString(CRS.lst,
+                  "the start & successor of a deletable structure")
+      | 3: FileIO.WriteString(CRS.lst,
+                  "an ANY node that matches no symbol")
+      END;
+    END LL1Error;
+
+  PROCEDURE Check (cond: INTEGER; VAR s1, s2: Set);
+    VAR
+      i: INTEGER;
+    BEGIN
+      i := 0;
+      WHILE i <= maxT DO
+        IF Sets.In(s1, i) & Sets.In(s2, i) THEN LL1Error(cond, i) END;
+        INC(i)
+      END
+    END Check;
+
+  PROCEDURE CheckAlternatives (gp: INTEGER);
+    VAR
+      gn, gn1: GraphNode;
+      s1, s2: Set;
+      p: INTEGER;
+    BEGIN
+      WHILE gp > 0 DO
+        GetNode(gp, gn);
+        IF gn.typ = alt THEN
+          p := gp; Sets.Clear(s1);
+          WHILE p # 0 DO (*for all alternatives*)
+            GetNode(p, gn1); CompExpected(gn1.p1, curSy, s2);
+            Check(1, s1, s2);
+            Sets.Unite(s1, s2);
+            CheckAlternatives(gn1.p1);
+            p := gn1.p2
+          END
+        ELSIF (gn.typ = opt) OR (gn.typ = iter) THEN
+          CompExpected(gn.p1, curSy, s1);
+          CompExpected(ABS(gn.next), curSy, s2);
+          Check(2, s1, s2);
+          CheckAlternatives(gn.p1)
+        ELSIF gn.typ = any THEN
+          GetSet(gn.p1, s1);
+          IF Sets.Empty(s1) THEN LL1Error(3, 0) END
+          (*e.g. {ANY} ANY or [ANY] ANY*)
+        END;
+        gp := gn.next
+      END
+    END CheckAlternatives;
+
+  BEGIN (* LL1Test *)
+    FileIO.WriteString(CRS.lst, "LL(1) conditions:");
+    curSy := firstNt; ll1 := TRUE;
+    WHILE curSy <= lastNt DO (*for all nonterminals*)
+      GetSym(curSy, sn); CheckAlternatives(sn.struct);
+      INC(curSy)
+    END;
+    IF ll1 THEN FileIO.WriteString(CRS.lst, "         --  ok  --") END;
+    FileIO.WriteLn(CRS.lst);
+  END LL1Test;
+
+(* TestCompleteness     Test if all nonterminals have productions
+----------------------------------------------------------------------*)
+PROCEDURE TestCompleteness (VAR ok: BOOLEAN);
+  VAR
+    sp: INTEGER;
+    sn: SymbolNode;
+  BEGIN
+    FileIO.WriteString(CRS.lst, "Undefined nonterminals:  ");
+    sp := firstNt; ok := TRUE;
+    WHILE sp <= lastNt DO (*for all nonterminals*)
+      GetSym(sp, sn);
+      IF sn.struct = 0 THEN
+        ok := FALSE;
+        FileIO.WriteLn(CRS.lst); FileIO.WriteString(CRS.lst, "     ");
+        FileIO.WriteString(CRS.lst, sn.name);
+      END;
+      INC(sp)
+    END;
+    IF ok THEN FileIO.WriteString(CRS.lst, " -- none --") END;
+    FileIO.WriteLn(CRS.lst);
+  END TestCompleteness;
+
+(* TestIfAllNtReached   Test if all nonterminals can be reached
+----------------------------------------------------------------------*)
+PROCEDURE TestIfAllNtReached (VAR ok: BOOLEAN);
+  VAR
+    gn: GraphNode;
+    sp: INTEGER;
+    reached: MarkList;
+    sn: SymbolNode;
+
+  PROCEDURE MarkReachedNts (gp: INTEGER);
+    VAR
+      gn: GraphNode;
+      sn: SymbolNode;
+    BEGIN
+      WHILE gp > 0 DO
+        GetNode(gp, gn);
+        IF gn.typ = nt THEN
+          IF ~ Sets.In(reached, gn.p1) THEN (*new nt reached*)
+            Sets.Incl(reached, gn.p1);
+            GetSym(gn.p1, sn); MarkReachedNts(sn.struct)
+          END
+        ELSIF (gn.typ = alt) OR (gn.typ = iter) OR (gn.typ = opt) THEN
+          MarkReachedNts(gn.p1);
+          IF gn.typ = alt THEN MarkReachedNts(gn.p2) END
+        END;
+        gp := gn.next
+      END
+    END MarkReachedNts;
+
+  BEGIN (* TestIfAllNtReached *)
+    ClearMarkList(reached);
+    GetNode(root, gn); Sets.Incl(reached, gn.p1);
+    GetSym(gn.p1, sn); MarkReachedNts(sn.struct);
+
+    FileIO.WriteString(CRS.lst, "Unreachable nonterminals:");
+    sp := firstNt; ok := TRUE;
+    WHILE sp <= lastNt DO (*for all nonterminals*)
+      IF ~ Sets.In(reached, sp) THEN
+        ok := FALSE; GetSym(sp, sn);
+        FileIO.WriteLn(CRS.lst); FileIO.WriteString(CRS.lst, "     ");
+        FileIO.WriteString(CRS.lst, sn.name)
+      END;
+      INC(sp)
+    END;
+    IF ok THEN FileIO.WriteString(CRS.lst, " -- none --") END;
+    FileIO.WriteLn(CRS.lst);
+  END TestIfAllNtReached;
+
+(* TestIfNtToTerm   Test if all nonterminals can be derived to terminals
+----------------------------------------------------------------------*)
+PROCEDURE TestIfNtToTerm (VAR ok: BOOLEAN);
+  VAR
+    changed: BOOLEAN;
+    sp: INTEGER;
+    sn: SymbolNode;
+    termList: MarkList;
+
+  PROCEDURE IsTerm (gp: INTEGER): BOOLEAN;
+    VAR
+      gn: GraphNode;
+    BEGIN
+      WHILE gp > 0 DO
+        GetNode(gp, gn);
+        IF (gn.typ = nt) & ~ Sets.In(termList, gn.p1)
+           OR (gn.typ = alt) & ~ IsTerm(gn.p1)
+              & ((gn.p2 = 0) OR ~ IsTerm(gn.p2)) THEN
+             RETURN FALSE
+        END;
+        gp := gn.next
+      END;
+      RETURN TRUE
+    END IsTerm;
+
+  BEGIN (* TestIfNtToTerm *)
+    ClearMarkList(termList);
+    REPEAT
+      sp := firstNt; changed := FALSE;
+      WHILE sp <= lastNt DO
+        IF ~ Sets.In(termList, sp) THEN
+          GetSym(sp, sn);
+          IF IsTerm(sn.struct) THEN
+            Sets.Incl(termList, sp); changed := TRUE
+          END
+        END;
+        INC(sp)
+      END
+    UNTIL ~ changed;
+
+    FileIO.WriteString(CRS.lst, "Underivable nonterminals:");
+    sp := firstNt; ok := TRUE;
+    WHILE sp <= lastNt DO
+      IF ~ Sets.In(termList, sp) THEN
+        ok := FALSE; GetSym(sp, sn);
+        FileIO.WriteLn(CRS.lst); FileIO.WriteString(CRS.lst, "     ");
+        FileIO.WriteString(CRS.lst, sn.name);
+      END;
+      INC(sp)
+    END;
+    IF ok THEN FileIO.WriteString(CRS.lst, " -- none --") END;
+    FileIO.WriteLn(CRS.lst);
+  END TestIfNtToTerm;
+
+(* ASCIIName            Assigns the wellknown ASCII-Name in lowercase
+----------------------------------------------------------------------*)
+PROCEDURE ASCIIName (ascii: CHAR; VAR asciiname: Name);
+  VAR
+    N : CARDINAL;
+  BEGIN
+    CASE ascii OF
+      00C : asciiname := "nul"
+    | 01C : asciiname := "soh"
+    | 02C : asciiname := "stx"
+    | 03C : asciiname := "etx"
+    | 04C : asciiname := "eot"
+    | 05C : asciiname := "enq"
+    | 06C : asciiname := "ack"
+    | 07C : asciiname := "bel"
+    | 10C : asciiname := "bs"
+    | 11C : asciiname := "ht"
+    | 12C : asciiname := "lf"
+    | 13C : asciiname := "vt"
+    | 14C : asciiname := "ff"
+    | 15C : asciiname := "cr"
+    | 16C : asciiname := "so"
+    | 17C : asciiname := "si"
+    | 20C : asciiname := "dle"
+    | 21C : asciiname := "dc1"
+    | 22C : asciiname := "dc2"
+    | 23C : asciiname := "dc3"
+    | 24C : asciiname := "dc4"
+    | 25C : asciiname := "nak"
+    | 26C : asciiname := "syn"
+    | 27C : asciiname := "etb"
+    | 30C : asciiname := "can"
+    | 31C : asciiname := "em"
+    | 32C : asciiname := "sub"
+    | 33C : asciiname := "esc"
+    | 34C : asciiname := "fs"
+    | 35C : asciiname := "gs"
+    | 36C : asciiname := "rs"
+    | 37C : asciiname := "us"
+    | " " : asciiname := "sp"
+    | "!" : asciiname := "bang"
+    | '"' : asciiname := "dquote"
+    | "#" : asciiname := "hash"
+    | "$" : asciiname := "dollar"
+    | "%" : asciiname := "percent"
+    | "&" : asciiname := "and"
+    | "'" : asciiname := "squote"
+    | "(" : asciiname := "lparen"
+    | ")" : asciiname := "rparen"
+    | "*" : asciiname := "star"
+    | "+" : asciiname := "plus"
+    | "," : asciiname := "comma"
+    | "-" : asciiname := "minus"
+    | "." : asciiname := "point"
+    | "/" : asciiname := "slash"
+    | "0" : asciiname := "zero"
+    | "1" : asciiname := "one"
+    | "2" : asciiname := "two"
+    | "3" : asciiname := "three"
+    | "4" : asciiname := "four"
+    | "5" : asciiname := "five"
+    | "6" : asciiname := "six"
+    | "7" : asciiname := "seven"
+    | "8" : asciiname := "eight"
+    | "9" : asciiname := "nine"
+    | ":" : asciiname := "colon"
+    | ";" : asciiname := "semicolon"
+    | "<" : asciiname := "less"
+    | "=" : asciiname := "equal"
+    | ">" : asciiname := "greater"
+    | "?" : asciiname := "query"
+    | "@" : asciiname := "at"
+    | "A" .. "Z", "a" .. "z"
+          : asciiname := " "; asciiname[0] := ascii
+    | "[" : asciiname := "lbrack"
+    | "\" : asciiname := "backslash"
+    | "]" : asciiname := "rbrack"
+    | "^" : asciiname := "uparrow"
+    | "_" : asciiname := "underscore"
+    | "`" : asciiname := "accent"
+    | "{" : asciiname := "lbrace"
+    | "|" : asciiname := "bar"
+    | "}" : asciiname := "rbrace"
+    | "~" : asciiname := "tilde"
+    | 177C: asciiname := "delete"
+    ELSE
+      N := ORD(ascii);
+      asciiname := 'ascii  ';
+      asciiname[6] := CHR(N MOD 10 + ORD('0'));
+      N := N DIV 10;
+      asciiname[5] := CHR(N MOD 10 + ORD('0'));
+      asciiname[4] := CHR(N DIV 10 + ORD('0'));
+    END
+  END ASCIIName;
+
+(* BuildName            Build new Name to represent old string
+----------------------------------------------------------------------*)
+PROCEDURE BuildName (VAR old, new: ARRAY OF CHAR);
+  VAR
+    ForLoop, I, TargetIndex: CARDINAL;
+    AsciiName: Name;
+  BEGIN
+    TargetIndex := 0;
+    FOR ForLoop := 1 TO FileIO.SLENGTH(old) - 2 DO
+      CASE old[ForLoop] OF
+        "A" .. "Z", "a" .. "z":
+          IF TargetIndex <= HIGH(new) THEN
+            new[TargetIndex] := old[ForLoop];
+            INC(TargetIndex);
+          END;
+        ELSE
+          ASCIIName(old[ForLoop], AsciiName);
+          FOR I := 0 TO FileIO.SLENGTH(AsciiName) - 1 DO
+            IF TargetIndex <= HIGH(new) THEN
+              new[TargetIndex] := AsciiName[I];
+              INC(TargetIndex);
+            END;
+          END;
+      END;
+    END;
+    IF TargetIndex <= HIGH(new) THEN new[TargetIndex] := 0C END;
+  END BuildName;
+
+(* SymName              Generates a new name for a symbol constant
+----------------------------------------------------------------------*)
+PROCEDURE SymName (symn: Name; VAR conn: Name);
+  BEGIN
+    IF (symn[0] = '"') OR (symn[0] = "'") THEN
+      IF FileIO.SLENGTH(symn) = 3 THEN
+        ASCIIName(symn[1], conn);
+      ELSE
+        BuildName(symn, conn);
+      END;
+    ELSE
+      conn := symn;
+    END;
+    FileIO.Concat(conn, "Sym", conn);
+  END SymName;
+
+(* AssignSymNames     Assigns the user defined or generated token names
+----------------------------------------------------------------------*)
+PROCEDURE AssignSymNames (default: BOOLEAN; VAR thereExists: BOOLEAN);
+
+  PROCEDURE AssignDef (VAR n (*is not modified*), const: Name);
+    VAR
+      ForLoop: CARDINAL;
+    BEGIN
+      FOR ForLoop := 1 TO lastName DO
+        IF FileIO.Compare(n, tt[ForLoop].definition) = 0 THEN
+          const := tt[ForLoop].name; thereExists := TRUE; RETURN;
+        END;
+      END;
+      IF default THEN SymName(n, const); ELSE const := ""; END;
+    END AssignDef;
+
+  VAR
+    ForLoop: INTEGER;
+
+  BEGIN
+    thereExists := default;
+    st^[0].constant := "EOFSYM";
+    FOR ForLoop := 1 TO maxP DO
+      AssignDef(st^[ForLoop].name, st^[ForLoop].constant)
+    END;
+    st^[maxT].constant := "NOSYM";
+  END AssignSymNames;
+
+BEGIN (* CRT *)
+  ch := "A"; WHILE ch <= "Z" DO ddt[ch] := FALSE; INC(ch) END;
+  maxSet := 0; Sets.Clear(set[0]); Sets.Incl(set[0], eofSy);
+  firstNt := maxSymbols; maxP := maxSymbols; maxT := -1; maxC := -1;
+  lastNt := maxP - 1;
+  dummyName := 0; lastName := 0; symNames := FALSE;
+  (* The dummy node gn^[0] ensures that none of the procedures
+     above have to check for 0 indices. *)
+  Storage.ALLOCATE(gn, SYSTEM.TSIZE(GraphList));
+  Storage.ALLOCATE(st, SYSTEM.TSIZE(SymbolTable));
+  nNodes := 0;
+  gn^[0].typ := -1; gn^[0].p1 := 0; gn^[0].p2 := 0;
+  gn^[0].next := 0; gn^[0].line := 0;
+  gn^[0].pos.beg := - FileIO.Long1;
+  gn^[0].pos.len := 0; gn^[0].pos.col := 0;
+(* debug info when choosing constants - PDT
+  FileIO.WriteString(FileIO.StdOut, "Symbol table");
+  FileIO.WriteCard(FileIO.StdOut, SIZE(SymbolTable), 1);
+  FileIO.WriteLn(FileIO.StdOut);
+  FileIO.WriteString(FileIO.StdOut, "Class table ");
+  FileIO.WriteCard(FileIO.StdOut, SIZE(ClassTable), 1);
+  FileIO.WriteLn(FileIO.StdOut);
+  FileIO.WriteString(FileIO.StdOut, "Name table  ");
+  FileIO.WriteCard(FileIO.StdOut, SIZE(NameTable), 1);
+  FileIO.WriteLn(FileIO.StdOut);
+  FileIO.WriteString(FileIO.StdOut, "Graph list  ");
+  FileIO.WriteCard(FileIO.StdOut, SIZE(GraphList), 1);
+  FileIO.WriteLn(FileIO.StdOut);
+*)
+END CRT.

CRX.def

@@ -0,0 +1,10 @@
+DEFINITION MODULE CRX;
+(* Parser Generation *)
+
+PROCEDURE GenCompiler;
+(* Generates the target compiler (parser). *)
+
+PROCEDURE WriteStatistics;
+(* Writes statistics about compilation to list file. *)
+
+END CRX.

CRX.mod

@@ -0,0 +1,813 @@
+IMPLEMENTATION MODULE CRX;
+
+(* CRX   Parser Generation
+   ===   =================
+
+   Uses the top-down graph and the computed sets of terminal start symbols
+   from CRT to generate recursive descent parsing procedures.
+
+   Errors are reported by error numbers. The corresponding error messages
+   are written to <grammar name>.ERR.
+
+   ---------------------------------------------------------------------*)
+
+IMPORT CRS, CRT, CRA, FileIO, Sets;
+
+CONST
+  symSetSize = 100; (* max.number of symbol sets of the generated parser *)
+  maxTerm    =   5; (* sets of size < maxTerm are enumerated *)
+  maxAlter   =   5; (* more than maxAlter alternatives are handled with
+                       a case statement *)
+                    (* kinds of generated error messages *)
+  tErr       =   0; (* unmatched terminal symbol *)
+  altErr     =   1; (* unmatched alternatives *)
+  syncErr    =   2; (* error reported at synchronization point *)
+
+TYPE
+  INT32 = FileIO.INT32;
+
+VAR
+  symSet:   ARRAY [0 .. symSetSize] OF CRT.Set; (* symbol sets in the
+                                                   generated parser *)
+  maxSS:    INTEGER; (* number of symbol sets *)
+  errorNr:  INTEGER; (* number of last generated error message*)
+  curSy:    INTEGER; (* symbol whose production is currently generated *)
+  err:      FileIO.File; (* output: error message texts *)
+  fram:     FileIO.File; (* input:  parser frame parser.frm *)
+  syn:      FileIO.File; (* output: generated parser *)
+  NewLine:  BOOLEAN;
+  IndDisp:  INTEGER;
+
+(*#check(overflow=>off)*)
+
+(* Put                  Write ch
+----------------------------------------------------------------------*)
+PROCEDURE Put (ch: CHAR);
+  BEGIN
+    FileIO.Write(syn, ch)
+  END Put;
+
+(* PutLn                Write line mark
+----------------------------------------------------------------------*)
+PROCEDURE PutLn;
+  BEGIN
+    FileIO.WriteLn(syn)
+  END PutLn;
+
+(* PutB                 Write n blanks
+----------------------------------------------------------------------*)
+PROCEDURE PutB (n: INTEGER);
+  BEGIN
+    IF n > 0 THEN FileIO.WriteText(syn, "", n) END;
+  END PutB;
+
+(* Indent               Indent n characters
+----------------------------------------------------------------------*)
+PROCEDURE Indent (n: INTEGER);
+  BEGIN
+    IF NewLine THEN PutB(n) ELSE NewLine := TRUE END;
+  END Indent;
+
+(* IndentProc           IndentProc n characters with additional IndDisp
+----------------------------------------------------------------------*)
+PROCEDURE IndentProc (n: INTEGER);
+  BEGIN
+    Indent(n + IndDisp);
+  END IndentProc;
+
+(* PutS                 Shortcut for WriteString(syn, ..)
+----------------------------------------------------------------------*)
+PROCEDURE PutS (s: ARRAY OF CHAR);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE (i <= HIGH(s)) & (s[i] # 0C) DO
+      IF s[i] = "$"
+        THEN FileIO.WriteLn(syn)
+        ELSE FileIO.Write(syn, s[i])
+      END;
+      INC(i)
+    END
+  END PutS;
+
+(* PutI                 Shortcut for WriteInt(syn, i, 1)
+----------------------------------------------------------------------*)
+PROCEDURE PutI (i: INTEGER);
+  BEGIN
+    FileIO.WriteInt(syn, i, 1)
+  END PutI;
+
+(* PutI2                Shortcut for WriteInt(syn, i, 2)
+----------------------------------------------------------------------*)
+PROCEDURE PutI2 (i: INTEGER);
+  BEGIN
+    FileIO.WriteInt(syn, i, 2)
+  END PutI2;
+
+(* PutSI                Writes i or named constant of symbol i
+----------------------------------------------------------------------*)
+PROCEDURE PutSI (i: INTEGER);
+  VAR
+    sn: CRT.SymbolNode;
+  BEGIN
+    CRT.GetSym(i, sn);
+    IF FileIO.SLENGTH(sn.constant) > 0 THEN
+      PutS(sn.constant);
+    ELSE
+      PutI(i);
+    END;
+  END PutSI;
+
+(* PutSet               Enumerate bitset
+----------------------------------------------------------------------*)
+PROCEDURE PutSet (s: BITSET; offset: CARDINAL);
+  CONST
+    MaxLine = 76;
+  VAR
+    first: BOOLEAN;
+    i, l, len: CARDINAL;
+    sn: CRT.SymbolNode;
+  BEGIN
+    i := 0; first := TRUE; len := 20;
+    WHILE (i < Sets.size) & (offset + i <= ORD(CRT.maxT)) DO
+      IF i IN s THEN
+        IF first THEN first := FALSE ELSE PutS(", "); INC(len, 2) END;
+        CRT.GetSym(offset + i, sn); l := FileIO.SLENGTH(sn.constant);
+        IF l > 0 THEN
+          IF len + l > MaxLine THEN
+            PutS('$                    ');
+            len := 20;
+          END;
+          PutS(sn.constant); INC(len, l);
+          IF offset > 0 THEN Put("-"); PutI(offset); INC(len, 3) END;
+        ELSE
+          IF len + l > MaxLine THEN
+            PutS('$                    ');
+            len := 20;
+          END;
+          PutI(i); INC(len, i DIV 10 + 1);
+        END;
+      END;
+      INC(i)
+    END
+  END PutSet;
+
+(* PutSet1              Enumerate long set
+----------------------------------------------------------------------*)
+PROCEDURE PutSet1 (s: CRT.Set);
+  VAR
+    i: INTEGER;
+    first: BOOLEAN;
+  BEGIN
+    i := 0; first := TRUE;
+    WHILE i <= CRT.maxT DO
+      IF Sets.In(s, i) THEN
+        IF first THEN first := FALSE ELSE PutS(", ") END;
+        PutSI(i)
+      END;
+      INC(i)
+    END
+  END PutSet1;
+
+(* Alternatives         Count alternatives of gp
+----------------------------------------------------------------------*)
+PROCEDURE Alternatives (gp: INTEGER): INTEGER;
+  VAR
+    gn: CRT.GraphNode;
+    n: INTEGER;
+  BEGIN
+    n := 0;
+    WHILE gp > 0 DO
+      CRT.GetNode(gp, gn); gp := gn.p2; INC(n);
+    END;
+    RETURN n;
+  END Alternatives;
+
+(* CopyFramePart        Copy from file <fram> to file <syn> until <stopStr>
+----------------------------------------------------------------------*)
+PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR; VAR leftMarg: CARDINAL);
+  BEGIN
+    CRA.CopyFramePart(stopStr, leftMarg, fram, syn);
+  END CopyFramePart;
+
+TYPE
+  IndentProcType = PROCEDURE (INTEGER);
+
+(* CopySourcePart       Copy sequence <pos> from input file to file <syn>
+----------------------------------------------------------------------*)
+PROCEDURE CopySourcePart (pos: CRT.Position; indent: INTEGER;
+                          indentProc: IndentProcType);
+  VAR
+    lastCh, ch: CHAR;
+    extra, col, i: INTEGER;
+    bp: INT32;
+    nChars: CARDINAL;
+  BEGIN
+    IF pos.beg >= FileIO.Long0 THEN
+      bp := pos.beg; nChars := pos.len;
+      col := pos.col - 1; ch := " "; extra := 0;
+      WHILE (nChars > 0) & ((ch = " ") OR (ch = CHR(9))) DO
+      (* skip leading white space *)
+        ch := CRS.CharAt(bp); INC(bp); DEC(nChars); INC(col);
+      END;
+      indentProc(indent);
+      LOOP
+        WHILE (ch = FileIO.CR) OR (ch = FileIO.LF) DO
+          (* Write blank lines with the correct number of leading blanks *)
+          FileIO.WriteLn(syn);
+          lastCh := ch;
+          IF nChars > 0
+            THEN ch := CRS.CharAt(bp); INC(bp); DEC(nChars);
+            ELSE EXIT
+          END;
+          IF (ch = FileIO.LF) & (lastCh = FileIO.CR) THEN
+            extra := 1 (* must be MS-DOS format *);
+            IF nChars > 0
+              THEN ch := CRS.CharAt(bp); INC(bp); DEC(nChars);
+              ELSE EXIT
+            END
+          END;
+          IF (ch # FileIO.CR) & (ch # FileIO.LF) THEN
+            (* we have something on this line *)
+            indentProc(indent);
+            i := col - 1 - extra;
+            WHILE ((ch = " ") OR (ch = CHR(9))) & (i > 0) DO
+              (* skip at most "col-1" white space chars at start of line *)
+              IF nChars > 0
+                THEN ch := CRS.CharAt(bp); INC(bp); DEC(nChars);
+                ELSE EXIT
+              END;
+              DEC(i);
+            END;
+          END;
+        END;
+        (* Handle extra blanks *)
+        i := 0;
+        WHILE ch = " " DO
+          IF nChars > 0
+            THEN ch := CRS.CharAt(bp); INC(bp); DEC(nChars);
+            ELSE EXIT
+          END;
+          INC(i);
+        END;
+        IF (ch # FileIO.CR) & (ch # FileIO.LF) & (ch # FileIO.EOF) THEN
+          IF i > 0 THEN PutB(i) END;
+          FileIO.Write(syn, ch);
+          IF nChars > 0
+            THEN ch := CRS.CharAt(bp); INC(bp); DEC(nChars);
+            ELSE EXIT
+          END;
+        END;
+      END;
+    END;
+  END CopySourcePart;
+
+(* GenErrorMsg          Generate an error message and return its number
+----------------------------------------------------------------------*)
+PROCEDURE GenErrorMsg (errTyp, errSym: INTEGER; VAR errNr: INTEGER);
+  VAR
+    i: INTEGER;
+    name: CRT.Name;
+    sn: CRT.SymbolNode;
+  BEGIN
+    INC(errorNr); errNr := errorNr;
+    CRT.GetSym(errSym, sn); name := sn.name;
+    i := 0;
+    WHILE name[i] # 0C DO
+      IF name[i] = '"' THEN name[i] := "'" END;
+      INC(i)
+    END;
+    IF errNr = 0
+      THEN FileIO.WriteString(err, " ");
+      ELSE FileIO.WriteString(err, "|");
+    END;
+    FileIO.WriteInt(err, errNr, 3); FileIO.WriteString(err, ': Msg("');
+    CASE errTyp OF
+      tErr   : FileIO.WriteString(err, name);
+               FileIO.WriteString(err, " expected")
+    | altErr : FileIO.WriteString(err, "invalid ");
+               FileIO.WriteString(err, name)
+    | syncErr: FileIO.WriteString(err, "this symbol not expected in ");
+               FileIO.WriteString(err, name)
+    END;
+    FileIO.WriteString(err, '")');
+    FileIO.WriteLn(err);
+  END GenErrorMsg;
+
+(* NewCondSet    Generate a new condition set, if set not yet exists
+----------------------------------------------------------------------*)
+PROCEDURE NewCondSet (set: CRT.Set): INTEGER;
+  VAR
+    i: INTEGER;
+  BEGIN
+    i := 1; (*skip symSet[0]*)
+    WHILE i <= maxSS DO
+      IF Sets.Equal(set, symSet[i]) THEN RETURN i END;
+      INC(i)
+    END;
+    INC(maxSS);
+    IF maxSS > symSetSize THEN CRT.Restriction(5, symSetSize) END;
+    symSet[maxSS] := set;
+    RETURN maxSS
+  END NewCondSet;
+
+(* GenCond              Generate code to check if sym is in set
+----------------------------------------------------------------------*)
+PROCEDURE GenCond (set: CRT.Set; indent: INTEGER);
+  VAR
+    i, n: INTEGER;
+
+  PROCEDURE Small (s: CRT.Set): BOOLEAN;
+    BEGIN
+      i := Sets.size;
+      WHILE i <= CRT.maxT DO
+        IF Sets.In(s, i) THEN RETURN FALSE END;
+        INC(i)
+      END;
+      RETURN TRUE
+    END Small;
+
+  BEGIN
+    n := Sets.Elements(set, i);
+    IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
+    ELSIF n <= maxTerm THEN
+      i := 0;
+      WHILE i <= CRT.maxT DO
+        IF Sets.In(set, i) THEN
+          PutS(" (sym = "); PutSI(i); Put(")"); DEC(n);
+          IF n > 0 THEN
+            PutS(" OR");
+            IF CRT.ddt["N"] THEN PutLn; IndentProc(indent) END
+          END
+        END;
+        INC(i)
+      END
+    ELSIF Small(set) THEN
+      PutS(" (sym < "); PutI2(Sets.size);
+      PutS(") (* prevent range error *) AND$");
+      IndentProc(indent); PutS(" (sym IN BITSET{");
+      PutSet(set[0], 0); PutS("}) ")
+    ELSE PutS(" In(symSet["); PutI(NewCondSet(set)); PutS("], sym)")
+    END;
+  END GenCond;
+
+(* GenCode              Generate code for graph gp in production curSy
+----------------------------------------------------------------------*)
+PROCEDURE GenCode (gp, indent: INTEGER; checked: CRT.Set);
+  VAR
+    gn, gn2: CRT.GraphNode;
+    sn: CRT.SymbolNode;
+    s1, s2: CRT.Set;
+    gp2, errNr, alts, indent1, addInd, errSemNod: INTEGER;
+    FirstCase, equal, OldNewLine: BOOLEAN;
+    altStart: INT32;
+  BEGIN
+    WHILE gp > 0 DO
+      CRT.GetNode(gp, gn);
+      CASE gn.typ OF
+
+        CRT.nt:
+          IndentProc(indent);
+          CRT.GetSym(gn.p1, sn); PutS(sn.name);
+          IF gn.pos.beg >= FileIO.Long0 THEN
+            Put("("); NewLine := FALSE;
+            indent1 := indent + VAL(INTEGER, FileIO.SLENGTH(sn.name)) + 1;
+            CopySourcePart(gn.pos, indent1, IndentProc);
+(* was      CopySourcePart(gn.pos, 0, IndentProc); ++++ *)
+            Put(")")
+          END;
+          PutS(";$")
+
+      | CRT.t:
+          CRT.GetSym(gn.p1, sn); IndentProc(indent);
+          IF Sets.In(checked, gn.p1) THEN
+            PutS("Get;$");
+          ELSE
+            PutS("Expect("); PutSI(gn.p1); PutS(");$");
+          END
+
+      | CRT.wt:
+          CRT.CompExpected(ABS(gn.next), curSy, s1);
+          CRT.GetSet(0, s2); Sets.Unite(s1, s2);
+          CRT.GetSym(gn.p1, sn); IndentProc(indent);
+          PutS("ExpectWeak("); PutSI(gn.p1); PutS(", ");
+          PutI(NewCondSet(s1)); PutS(");$")
+
+      | CRT.any:
+          IndentProc(indent); PutS("Get;$")
+
+      | CRT.eps: (* nothing *)
+
+      | CRT.sem:
+          CopySourcePart(gn.pos, indent, IndentProc); PutS(";$");
+
+      | CRT.sync:
+          CRT.GetSet(gn.p1, s1);
+          GenErrorMsg(syncErr, curSy, errNr);
+          IndentProc(indent);
+          PutS("WHILE ~ ("); GenCond(s1, indent + 9); PutS(") DO SynError(");
+          PutI(errNr); PutS("); Get END;$")
+
+      | CRT.alt:
+          CRT.CompFirstSet(gp, s1); equal := Sets.Equal(s1, checked);
+          alts := Alternatives(gp);
+          OldNewLine := NewLine; altStart := FileIO.GetPos(syn);
+          IF alts > maxAlter THEN
+            IndentProc(indent); PutS("CASE sym OF$")
+          END;
+          gp2 := gp;
+          IF alts > maxAlter THEN addInd := 4 ELSE addInd := 2 END;
+          errSemNod := -1; FirstCase := TRUE;
+          WHILE gp2 # 0 DO
+            CRT.GetNode(gp2, gn2);
+            CRT.CompExpected(gn2.p1, curSy, s1);
+            IndentProc(indent);
+            IF alts > maxAlter THEN
+              IF FirstCase
+                THEN FirstCase := FALSE; PutS("  ")
+                ELSE PutS("| ") END;
+              PutSet1(s1); PutS(" :$");
+            ELSIF gp2 = gp
+              THEN PutS("IF"); GenCond(s1, indent + 2); PutS(" THEN$")
+            ELSIF (gn2.p2 = 0) & equal THEN PutS("ELSE$")
+            ELSE PutS("ELSIF"); GenCond(s1, indent + 5); PutS(" THEN$")
+            END;
+            Sets.Unite(s1, checked);
+            GenCode(gn2.p1, indent + addInd, s1); NewLine := TRUE;
+            gp2 := gn2.p2;
+          END;
+          IF ~ equal THEN
+            GenErrorMsg(altErr, curSy, errNr);
+            IndentProc(indent);
+            PutS("ELSE SynError("); PutI(errNr); PutS(");$");
+          END;
+          IndentProc(indent); PutS("END;$");
+
+      | CRT.iter:
+          CRT.GetNode(gn.p1, gn2);
+          IndentProc(indent); PutS("WHILE");
+          IF gn2.typ = CRT.wt THEN
+            CRT.CompExpected(ABS(gn2.next), curSy, s1);
+            CRT.CompExpected(ABS(gn.next), curSy, s2);
+            CRT.GetSym(gn2.p1, sn);
+            PutS(" WeakSeparator("); PutSI(gn2.p1); PutS(", ");
+            PutI(NewCondSet(s1));
+            PutS(", "); PutI(NewCondSet(s2)); Put(")");
+            Sets.Clear(s1); (*for inner structure*)
+            IF gn2.next > 0 THEN gp2 := gn2.next ELSE gp2 := 0 END
+          ELSE
+            gp2 := gn.p1;
+            CRT.CompFirstSet(gp2, s1); GenCond(s1, indent + 5)
+          END;
+          PutS(" DO$");
+          GenCode(gp2, indent + 2, s1);
+          IndentProc(indent); PutS("END;$");
+
+      | CRT.opt:
+          CRT.CompFirstSet(gn.p1, s1);
+          IF Sets.Equal(checked, s1) THEN
+            GenCode(gn.p1, indent, checked);
+          ELSE
+            IndentProc(indent); PutS("IF");
+            GenCond(s1, indent + 2); PutS(" THEN$");
+            GenCode(gn.p1, indent + 2, s1);
+            IndentProc(indent); PutS("END;$");
+          END
+
+      END; (*CASE*)
+      IF (gn.typ # CRT.eps) & (gn.typ # CRT.sem) & (gn.typ # CRT.sync) THEN
+        Sets.Clear(checked)
+      END;
+      gp := gn.next;
+    END; (* WHILE gp > 0 *)
+  END GenCode;
+
+(* GenPragmaCode        Generate code for pragmas
+----------------------------------------------------------------------*)
+PROCEDURE GenPragmaCode (leftMarg: CARDINAL; gramName : ARRAY OF CHAR);
+  VAR
+    i: INTEGER;
+    sn: CRT.SymbolNode;
+    FirstCase: BOOLEAN;
+  BEGIN
+    i := CRT.maxT + 1; 
+    IF i > CRT.maxP THEN RETURN END;
+    FirstCase := TRUE;
+    PutS("CASE sym OF$"); PutB(leftMarg);
+    LOOP
+      CRT.GetSym(i, sn);
+      IF FirstCase THEN FirstCase := FALSE; PutS("  ") ELSE PutS("| ") END;
+      PutSI(i); PutS(": "); NewLine := FALSE;
+      CopySourcePart(sn.semPos, leftMarg + 6, Indent);
+      IF i = CRT.maxP THEN EXIT END;
+      INC(i); PutLn; PutB(leftMarg);
+    END; (* LOOP *)
+    PutLn; PutB(leftMarg); PutS("END;$");
+    PutB(leftMarg); PutS(gramName); PutS("S.nextPos := ");
+    PutS(gramName); PutS("S.pos;$");
+    PutB(leftMarg); PutS(gramName); PutS("S.nextCol := ");
+    PutS(gramName); PutS("S.col;$");
+    PutB(leftMarg); PutS(gramName); PutS("S.nextLine := ");
+    PutS(gramName); PutS("S.line;$");
+    PutB(leftMarg); PutS(gramName); PutS("S.nextLen := ");
+    PutS(gramName); PutS("S.len;");
+  END GenPragmaCode;
+
+(* GenProcedureHeading  Generate procedure heading
+----------------------------------------------------------------------*)
+PROCEDURE GenProcedureHeading (sn: CRT.SymbolNode);
+  BEGIN
+    PutS("PROCEDURE "); PutS(sn.name);
+    IF sn.attrPos.beg >= FileIO.Long0 THEN
+(* was  PutS(" ("); CopySourcePart(sn.attrPos, 0, PutB); Put(")") ++ *)
+      PutS(" ("); NewLine := FALSE;
+      CopySourcePart(sn.attrPos, 13 + FileIO.SLENGTH(sn.name), Indent);
+      Put(")")
+    END;
+    Put(";")
+  END GenProcedureHeading;
+
+(* GenForwardRefs       Generate forward references for one-pass compilers
+----------------------------------------------------------------------*)
+PROCEDURE GenForwardRefs;
+  VAR
+    sp: INTEGER;
+    sn: CRT.SymbolNode;
+  BEGIN
+    IF CRT.ddt["M"] THEN
+      PutS("(* ----- FORWARD not needed in multipass compilers$$")
+    END;
+    sp := CRT.firstNt;
+    WHILE sp <= CRT.lastNt DO (* for all nonterminals *)
+      CRT.GetSym(sp, sn); GenProcedureHeading(sn); PutS(" FORWARD;$");
+      INC(sp)
+    END;
+    FileIO.WriteLn(syn);
+    IF CRT.ddt["M"] THEN
+      PutS("----- *)$$")
+    END;
+  END GenForwardRefs;
+
+(* GenProductions       Generate code for all productions
+----------------------------------------------------------------------*)
+PROCEDURE GenProductions;
+  VAR
+    sn: CRT.SymbolNode;
+    checked: CRT.Set;
+  BEGIN
+    curSy := CRT.firstNt; NewLine := TRUE; (* Bug fix PDT*)
+    WHILE curSy <= CRT.lastNt DO (* for all nonterminals *)
+      CRT.GetSym(curSy, sn); GenProcedureHeading(sn); FileIO.WriteLn(syn);
+      IF sn.semPos.beg >= FileIO.Long0 THEN
+        CopySourcePart(sn.semPos, 2, IndentProc); PutLn
+      END;
+      PutB(2); PutS("BEGIN$");
+      (* may like to add PutS(" (* "); PutS(sn.name); PutS(" *)$"); *)
+      Sets.Clear(checked);
+      GenCode(sn.struct, 4, checked);
+      PutB(2); PutS("END "); PutS(sn.name); PutS(";$$");
+      INC(curSy);
+  END;
+END GenProductions;
+
+(* GenSetInits          Initialise all sets
+----------------------------------------------------------------------*)
+PROCEDURE InitSets;
+  VAR
+    i, j: INTEGER;
+  BEGIN
+    CRT.GetSet(0, symSet[0]);
+    NewLine := FALSE; i := 0;
+    WHILE i <= maxSS DO
+      IF i # 0 THEN PutLn END;
+      j := 0;
+      WHILE j <= CRT.maxT DIV Sets.size DO
+        IF j # 0 THEN PutLn END;
+        Indent(2); PutS("symSet["); PutI2(i); PutS(", ");PutI(j);
+        PutS("] := BITSET{");
+        PutSet(symSet[i, j], j * Sets.size); PutS("};");
+        INC(j);
+      END;
+      INC(i)
+    END
+  END InitSets;
+
+(* GenCompiler          Generate the target compiler
+----------------------------------------------------------------------*)
+PROCEDURE GenCompiler;
+  VAR
+    Digits, len, pos, LeftMargin: CARDINAL;
+    errNr, i: INTEGER;
+    checked: CRT.Set;
+    gn: CRT.GraphNode;
+    sn: CRT.SymbolNode;
+    gramName: ARRAY [0 .. 31] OF CHAR;
+    fGramName, fn, ParserFrame: ARRAY [0 .. 63] OF CHAR;
+    endPos, SS: INT32;
+  BEGIN
+    FileIO.Concat(CRS.directory, "parser.frm", ParserFrame);
+    FileIO.Open(fram, ParserFrame, FALSE);
+    IF ~ FileIO.Okay THEN
+      FileIO.SearchFile(fram, "CRFRAMES", "parser.frm", FALSE);
+      IF ~ FileIO.Okay THEN
+        FileIO.WriteLn(FileIO.StdOut);
+        FileIO.WriteString(FileIO.StdOut, "'parser.frm' not found.");
+        FileIO.WriteString(FileIO.StdOut, "- Aborted.");
+        FileIO.QuitExecution
+      END
+    END;
+    LeftMargin := 0;
+
+    CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
+    FileIO.Extract(sn.name, 0, 7, gramName);
+    FileIO.Concat(CRS.directory, gramName, fGramName);
+
+    (*----- write *.ERR -----*)
+    FileIO.Concat(fGramName, FileIO.ErrExt, fn);
+    FileIO.Open(err, fn, TRUE);
+(* ++
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "  ");
+    FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+    i := 0;
+    WHILE i <= CRT.maxT DO GenErrorMsg(tErr, i, errNr); INC(i) END;
+
+    IF (CRT.ddt["N"] OR CRT.symNames) AND ~ CRT.ddt["D"] THEN
+      (*----- write *G.DEF -----*)
+      FileIO.Concat(fGramName, "G", fn);
+      FileIO.Concat(fn, FileIO.DefExt, fn);
+      FileIO.Open(syn, fn, TRUE);
+(* ++
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "  ");
+      FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+      PutS("DEFINITION MODULE "); PutS(gramName); PutS("G;$$");
+      PutS("CONST");
+      i := 0; pos := CRA.MaxSourceLineLength + 1;
+      REPEAT
+        CRT.GetSym(i, sn); len := FileIO.SLENGTH(sn.constant);
+        IF len > 0 THEN
+          errNr := i; Digits := 1;
+          WHILE errNr >= 10 DO INC(Digits); errNr := errNr DIV 10 END;
+          INC(len, 3 + Digits + 1);
+          IF pos + len > CRA.MaxSourceLineLength THEN
+            PutLn; pos := 0
+          END;
+          PutS("  ");
+          PutS(sn.constant); PutS(" = "); PutI(i); Put(";");
+          INC(pos, len + 2);
+        END;
+        INC(i);
+      UNTIL i > CRT.maxP;
+      PutS("$$END "); PutS(gramName); PutS("G.$");
+      FileIO.Close(syn);
+
+      (*----- write *G.MOD -----*)
+      FileIO.Concat(fGramName, "G", fn);
+      FileIO.Concat(fn, FileIO.ModExt, fn);
+      FileIO.Open(syn, fn, TRUE);
+(* ++
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "  ");
+      FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+      PutS("IMPLEMENTATION MODULE "); PutS(gramName); PutS("G;$");
+      PutS("END "); PutS(gramName); PutS("G.$");
+      FileIO.Close(syn);
+    END; (* IF CRT.ddt["N"] OR CRT.symNames *)
+
+    (*----- write *P.MOD -----*)
+    FileIO.Concat(fGramName, "P", fn);
+    FileIO.Concat(fn, FileIO.ModExt, fn);
+    FileIO.Open(syn, fn, TRUE);
+(* ++
+    FileIO.WriteLn(FileIO.StdOut);
+    FileIO.WriteString(FileIO.StdOut, "  ");
+    FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+    CopyFramePart("-->modulename", LeftMargin); PutS(gramName); Put("P");
+    IF CRT.ddt["N"] OR CRT.symNames THEN CRA.ImportSymConsts(PutS) END;
+
+    CopyFramePart("-->scanner", LeftMargin);
+    PutS(gramName); Put("S");
+
+    CopyFramePart("-->declarations", LeftMargin);
+    CopySourcePart(CRT.semDeclPos, 0, PutB);
+
+    CopyFramePart("-->constants", LeftMargin);
+    PutS("maxT = "); PutI(CRT.maxT); Put(";");
+    IF CRT.maxP > CRT.maxT THEN
+      PutLn; PutB(LeftMargin); PutS("maxP = ");
+      PutI(CRT.maxP); Put(";");
+    END;
+
+    CopyFramePart("-->symSetSize", LeftMargin);
+    SS := FileIO.GetPos(syn);
+    FileIO.WriteInt(syn, 999, 3);
+
+    CopyFramePart("-->error", LeftMargin);
+    PutS(gramName); PutS("S.Error(errNo, ");
+    PutS(gramName); PutS("S.line, ");
+    PutS(gramName); PutS("S.col, ");
+    PutS(gramName); PutS("S.pos);");
+
+    CopyFramePart("-->error", LeftMargin);
+    PutS(gramName); PutS("S.Error(errNo, ");
+    PutS(gramName); PutS("S.nextLine, ");
+    PutS(gramName); PutS("S.nextCol, ");
+    PutS(gramName); PutS("S.nextPos);");
+
+    CopyFramePart("-->scanner", LeftMargin);
+    PutS(gramName); Put("S");
+
+    CopyFramePart("-->pragmas", LeftMargin);
+    GenPragmaCode(LeftMargin, gramName);
+
+    FOR i := 1 TO 13 DO
+      CopyFramePart("-->scanner", LeftMargin);
+      PutS(gramName); Put("S");
+    END;
+
+    CopyFramePart("-->productions", LeftMargin);
+    GenForwardRefs; GenProductions;
+
+    CopyFramePart("-->parseRoot", LeftMargin);
+    PutS(gramName); PutS("S.Reset; Get;$");
+    Sets.Clear(checked); GenCode(CRT.root, LeftMargin, checked);
+
+    CopyFramePart("-->initialization", LeftMargin);
+    InitSets;
+
+    CopyFramePart("-->modulename", LeftMargin);
+    PutS(gramName); Put("P");
+
+    CopyFramePart("-->definition", LeftMargin);
+
+    endPos := FileIO.GetPos(syn); (* end position of the file *)
+    FileIO.SetPos(syn, SS);       (* fix up array declaration *)
+    IF maxSS < 0 THEN maxSS := 0 END;
+    FileIO.WriteInt(syn, maxSS, 3);
+    FileIO.SetPos(syn, endPos);   (* set file pointer to end of file *)
+    FileIO.Close(syn);
+
+    IF ~ CRT.ddt["D"] THEN
+      (*----- write *P.DEF -----*)
+      FileIO.Concat(fGramName, "P", fn);
+      FileIO.Concat(fn, FileIO.DefExt, fn);
+      FileIO.Open(syn, fn, TRUE);
+(* ++
+      FileIO.WriteLn(FileIO.StdOut);
+      FileIO.WriteString(FileIO.StdOut, "  ");
+      FileIO.WriteString(FileIO.StdOut, fn);
+ ++ *)
+      CopyFramePart("-->modulename", LeftMargin);
+      PutS(gramName); Put("P");
+
+      CopyFramePart("-->modulename", LeftMargin);
+      PutS(gramName); PutS("P.$");
+
+      FileIO.Close(syn);
+    END;
+    FileIO.Close(fram); FileIO.Close(err);
+  END GenCompiler;
+
+(* WriteStatistics      Write statistics about compilation to list file
+----------------------------------------------------------------------*)
+PROCEDURE WriteStatistics;
+
+  PROCEDURE WriteNumbers (used, available: INTEGER);
+    BEGIN
+      FileIO.WriteInt(CRS.lst, used + 1, 6);
+      FileIO.WriteString(CRS.lst, " (limit ");
+      FileIO.WriteInt(CRS.lst, available, 5);
+      FileIO.Write(CRS.lst, ")"); FileIO.WriteLn(CRS.lst);
+    END WriteNumbers;
+
+  BEGIN
+    FileIO.WriteString(CRS.lst, "Statistics:"); FileIO.WriteLn(CRS.lst);
+    FileIO.WriteLn(CRS.lst);
+    FileIO.WriteString(CRS.lst, "  nr of terminals:    ");
+    WriteNumbers(CRT.maxT, CRT.maxTerminals);
+    FileIO.WriteString(CRS.lst, "  nr of non-terminals:");
+    WriteNumbers(CRT.lastNt-CRT.firstNt, CRT.maxNt);
+    FileIO.WriteString(CRS.lst, "  nr of pragmas:      ");
+    WriteNumbers(CRT.maxSymbols-CRT.lastNt-2, CRT.maxSymbols-CRT.maxT-1);
+    FileIO.WriteString(CRS.lst, "  nr of symbolnodes:  ");
+    WriteNumbers(CRT.maxSymbols-CRT.firstNt+CRT.maxT, CRT.maxSymbols);
+    FileIO.WriteString(CRS.lst, "  nr of graphnodes:   ");
+    WriteNumbers(CRT.nNodes, CRT.maxNodes);
+    FileIO.WriteString(CRS.lst, "  nr of conditionsets:");
+    WriteNumbers(maxSS, symSetSize);
+    FileIO.WriteString(CRS.lst, "  nr of charactersets:");
+    WriteNumbers(CRT.maxC, CRT.maxClasses);
+    FileIO.WriteLn(CRS.lst); FileIO.WriteLn(CRS.lst);
+  END WriteStatistics;
+
+
+BEGIN (* CRX *)
+  errorNr := -1; maxSS := 0; (*symSet[0] reserved for allSyncSyms*)
+  NewLine := TRUE; IndDisp := 0;
+END CRX.

Docs/FIO.def

@@ -0,0 +1,279 @@
+(* FIO.def provides a simple buffered file input/output library.
+
+Copyright (C) 2001-2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  *)
+
+DEFINITION MODULE FIO ;
+
+(* Provides a simple buffered file input/output library.  *)
+
+
+FROM SYSTEM IMPORT ADDRESS, BYTE ;
+
+EXPORT QUALIFIED (* types *)
+                 File,
+                 (* procedures *)
+                 OpenToRead, OpenToWrite, OpenForRandom, Close,
+                 EOF, EOLN, WasEOLN, IsNoError, Exists, IsActive,
+                 exists, openToRead, openToWrite, openForRandom,
+                 SetPositionFromBeginning,
+                 SetPositionFromEnd,
+                 FindPosition,
+                 ReadChar, ReadString,
+                 WriteChar, WriteString, WriteLine,
+                 WriteCardinal, ReadCardinal,
+                 UnReadChar,
+                 WriteNBytes, ReadNBytes,
+                 FlushBuffer,
+                 GetUnixFileDescriptor,
+                 GetFileName, getFileName, getFileNameLength,
+                 FlushOutErr,
+                 (* variables *)
+                 StdIn, StdOut, StdErr ;
+
+TYPE
+   File = CARDINAL ;
+
+(* the following variables are initialized to their UNIX equivalents *)
+VAR
+   StdIn, StdOut, StdErr: File ;
+
+(*
+   IsNoError - returns a TRUE if no error has occured on file, f.
+*)
+
+PROCEDURE IsNoError (f: File) : BOOLEAN ;
+(*
+   IsActive - returns TRUE if the file, f, is still active.
+*)
+
+PROCEDURE IsActive (f: File) : BOOLEAN ;
+(*
+   Exists - returns TRUE if a file named, fname exists for reading.
+*)
+
+PROCEDURE Exists (fname: ARRAY OF CHAR) : BOOLEAN ;
+(*
+   OpenToRead - attempts to open a file, fname, for reading and
+                it returns this file.
+                The success of this operation can be checked by
+                calling IsNoError.
+*)
+
+PROCEDURE OpenToRead (fname: ARRAY OF CHAR) : File ;
+(*
+   OpenToWrite - attempts to open a file, fname, for write and
+                 it returns this file.
+                 The success of this operation can be checked by
+                 calling IsNoError.
+*)
+
+PROCEDURE OpenToWrite (fname: ARRAY OF CHAR) : File ;
+(*
+   OpenForRandom - attempts to open a file, fname, for random access
+                   read or write and it returns this file.
+                   The success of this operation can be checked by
+                   calling IsNoError.
+                   towrite, determines whether the file should be
+                   opened for writing or reading.
+                   newfile, determines whether a file should be
+                   created if towrite is TRUE or whether the
+                   previous file should be left alone,
+                   allowing this descriptor to seek
+                   and modify an existing file.
+*)
+
+PROCEDURE OpenForRandom (fname: ARRAY OF CHAR;
+                         towrite, newfile: BOOLEAN) : File ;
+(*
+   Close - close a file which has been previously opened using:
+           OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Close (f: File) ;
+(* the following functions are functionally equivalent to the above
+   except they allow C style names.
+*)
+
+PROCEDURE exists        (fname: ADDRESS; flength: CARDINAL) : BOOLEAN ;
+PROCEDURE openToRead    (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openToWrite   (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openForRandom (fname: ADDRESS; flength: CARDINAL;
+                         towrite, newfile: BOOLEAN) : File ;
+(*
+   FlushBuffer - flush contents of the FIO file, f, to libc.
+*)
+
+PROCEDURE FlushBuffer (f: File) ;
+(*
+   ReadNBytes - reads nBytes of a file into memory area, dest, returning
+                the number of bytes actually read.
+                This function will consume from the buffer and then
+                perform direct libc reads. It is ideal for large reads.
+*)
+
+PROCEDURE ReadNBytes (f: File; nBytes: CARDINAL;
+                      dest: ADDRESS) : CARDINAL ;
+(*
+   ReadAny - reads HIGH (a) + 1 bytes into, a.  All input
+             is fully buffered, unlike ReadNBytes and thus is more
+             suited to small reads.
+*)
+
+PROCEDURE ReadAny (f: File; VAR a: ARRAY OF BYTE) ;
+(*
+   WriteNBytes - writes nBytes from memory area src to a file
+                 returning the number of bytes actually written.
+                 This function will flush the buffer and then
+                 write the nBytes using a direct write from libc.
+                 It is ideal for large writes.
+*)
+
+PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL;
+                       src: ADDRESS) : CARDINAL ;
+(*
+   WriteAny - writes HIGH (a) + 1 bytes onto, file, f.  All output
+              is fully buffered, unlike WriteNBytes and thus is more
+              suited to small writes.
+*)
+
+PROCEDURE WriteAny (f: File; VAR a: ARRAY OF BYTE) ;
+(*
+   WriteChar - writes a single character to file, f.
+*)
+
+PROCEDURE WriteChar (f: File; ch: CHAR) ;
+(*
+   EOF - tests to see whether a file, f, has reached end of file.
+*)
+
+PROCEDURE EOF (f: File) : BOOLEAN ;
+(*
+   EOLN - tests to see whether a file, f, is about to read a newline.
+          It does NOT consume the newline.  It reads the next character
+          and then immediately unreads the character.
+*)
+
+PROCEDURE EOLN (f: File) : BOOLEAN ;
+(*
+   WasEOLN - tests to see whether a file, f, has just read a newline
+             character.
+*)
+
+PROCEDURE WasEOLN (f: File) : BOOLEAN ;
+(*
+   ReadChar - returns a character read from file, f.
+              Sensible to check with IsNoError or EOF after calling
+              this function.
+*)
+
+PROCEDURE ReadChar (f: File) : CHAR ;
+(*
+   UnReadChar - replaces a character, ch, back into file, f.
+                This character must have been read by ReadChar
+                and it does not allow successive calls.  It may
+                only be called if the previous read was successful,
+                end of file or end of line seen.
+*)
+
+PROCEDURE UnReadChar (f: File ; ch: CHAR) ;
+(*
+   WriteLine - writes out a linefeed to file, f.
+*)
+
+PROCEDURE WriteLine (f: File) ;
+(*
+   WriteString - writes a string to file, f.
+*)
+
+PROCEDURE WriteString (f: File; a: ARRAY OF CHAR) ;
+(*
+   ReadString - reads a string from file, f, into string, a.
+                It terminates the string if HIGH is reached or
+                if a newline is seen or an error occurs.
+*)
+
+PROCEDURE ReadString (f: File; VAR a: ARRAY OF CHAR) ;
+(*
+   WriteCardinal - writes a CARDINAL to file, f.
+                   It writes the binary image of the CARDINAL.
+                   to file, f.
+*)
+
+PROCEDURE WriteCardinal (f: File; c: CARDINAL) ;
+(*
+   ReadCardinal - reads a CARDINAL from file, f.
+                  It reads a bit image of a CARDINAL
+                  from file, f.
+*)
+
+PROCEDURE ReadCardinal (f: File) : CARDINAL ;
+(*
+   GetUnixFileDescriptor - returns the UNIX file descriptor of a file.
+                           Useful when combining FIO.mod with select
+                           (in Selective.def - but note the comments in
+                            Selective about using read/write primatives)
+*)
+
+PROCEDURE GetUnixFileDescriptor (f: File) : INTEGER ;
+(*
+   SetPositionFromBeginning - sets the position from the beginning
+                              of the file.
+*)
+
+PROCEDURE SetPositionFromBeginning (f: File; pos: LONGINT) ;
+(*
+   SetPositionFromEnd - sets the position from the end of the file.
+*)
+
+PROCEDURE SetPositionFromEnd (f: File; pos: LONGINT) ;
+(*
+   FindPosition - returns the current absolute position in file, f.
+*)
+
+PROCEDURE FindPosition (f: File) : LONGINT ;
+(*
+   GetFileName - assigns, a, with the filename associated with, f.
+*)
+
+PROCEDURE GetFileName (f: File; VAR a: ARRAY OF CHAR) ;
+(*
+   getFileName - returns the address of the filename associated with, f.
+*)
+
+PROCEDURE getFileName (f: File) : ADDRESS ;
+(*
+   getFileNameLength - returns the number of characters associated with
+                       filename, f.
+*)
+
+PROCEDURE getFileNameLength (f: File) : CARDINAL ;
+(*
+   FlushOutErr - flushes, StdOut, and, StdErr.
+*)
+
+PROCEDURE FlushOutErr ;
+
+END FIO.

Docs/FileIO-1.mod

@@ -0,0 +1,923 @@
+IMPLEMENTATION MODULE FileIO ;
+
+(* This module attempts to provide several potentially non-portable
+   facilities for Coco/R.
+
+   (a)  A general file input/output module, with all routines required for
+        Coco/R itself, as well as several other that would be useful in
+        Coco-generated applications.
+   (b)  Definition of the "LONGINT" type needed by Coco.
+   (c)  Some conversion functions to handle this long type.
+   (d)  Some "long" and other constant literals that may be problematic
+        on some implementations.
+   (e)  Some string handling primitives needed to interface to a variety
+        of known implementations.
+
+   The intention is that the rest of the code of Coco and its generated
+   parsers should be as portable as possible.  Provided the definition
+   module given, and the associated implementation, satisfy the
+   specification given here, this should be almost 100% possible (with
+   the exception of a few constants, avoid changing anything in this
+   specification).
+
+   FileIO is based on code by MB 1990/11/25; heavily modified and extended
+   by PDT and others between 1992/1/6 and the present day. *)
+
+(* This is the generic WinTel version *)
+
+FROM SYSTEM IMPORT TSIZE;
+IMPORT FileSystem, Strings, InOut;
+FROM OS2DEF IMPORT APIRET;
+FROM OS2ARG IMPORT ArgCount, Arg, STRING, PSTRING,
+         EnvCount, Env   ;
+FROM DOSDATETIME IMPORT DATETIME, DosGetDateTime;
+
+FROM Storage IMPORT ALLOCATE, DEALLOCATE;
+
+CONST
+  MaxFiles = BitSetSize;
+  NameLength = 256;
+  BufSize  = 1024 ;
+
+TYPE Buftype = ARRAY [0..BufSize] OF CHAR;
+
+VAR
+  Handles: BITSET;
+  Opened: ARRAY [0 .. MaxFiles-1] OF File;
+  FromKeyboard, ToScreen: BOOLEAN;
+  Param: LONGCARD;
+  Continue: PROC;
+
+TYPE CommandType = POINTER TO ARRAY [0..255] OF CHAR;
+
+     File = POINTER TO FileRec;
+     FileRec = RECORD
+              ref: FileSystem.File;
+              self: File;
+              handle: CARDINAL;
+              savedCh: CHAR;
+              textOK, eof, eol, noOutput, noInput, haveCh: BOOLEAN;
+              name: ARRAY [0 .. NameLength] OF CHAR;
+              END;
+
+
+
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+VAR P : PSTRING;
+BEGIN
+  INC(Param);
+  IF Param <= ArgCount()
+  THEN P := Arg ( Param );
+       IF P # NIL THEN Assign ( P^, s);END;
+  ELSE s[0] := 0C
+  END
+END NextParameter;
+
+
+PROCEDURE GetEnv ( envVar : ARRAY OF CHAR; VAR s : ARRAY OF CHAR );
+VAR pos, index, idxmax : LONGCARD;
+       match : BOOLEAN;
+       ct : CommandType;
+       i,j : LONGCARD;
+       c : CHAR;
+BEGIN
+    match := FALSE;
+    s [ 0 ] := CHR(0);
+    j := Strings.Length (envVar);
+    FOR i := 0 TO j DO envVar[i] := CAP(envVar[i]) END;
+    idxmax := EnvCount();
+    INC (idxmax);
+    index := 0;
+    WHILE (index < idxmax) AND (NOT match) DO
+    ct := CommandType( Env (index));
+    IF ct # NIL THEN
+    pos := Strings.Pos ( envVar, ct^ );
+    match := ( pos = 0)
+    END; (* if ct # *)
+    INC (index);
+    END; (* While *)
+
+    IF match THEN
+     i:=0;
+     REPEAT c := ct^[i]; INC (i) UNTIL c = '=';
+     c := ct^[i];
+    WHILE ct^[i] = ' ' DO  INC(i)  END;
+     j := 0;
+     REPEAT
+      c := ct^[i];
+      s[j] := c ;
+      INC(i); INC(j);
+     UNTIL ( c = CHR(0)) OR (j = HIGH(s)) ;
+    END;
+END GetEnv ;
+
+PROCEDURE ASCIIZ (VAR s1, s2: ARRAY OF CHAR);
+(* Convert s2 to a nul terminated string in s1 *)
+VAR i: CARDINAL;
+BEGIN
+  i := 0;
+  WHILE (i <= HIGH(s2)) & (s2[i] # 0C) DO
+        s1[i] := s2[i]; INC(i)
+  END;
+  s1[i] := 0C
+END ASCIIZ;
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+  VAR
+    i: CARDINAL;
+    NoWrite: BOOLEAN;
+    name: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    ExtractFileName(fileName, name);
+    FOR i := 0 TO NameLength - 1 DO name[i] := CAP(name[i]) END;
+    IF (name[0] = 0C) OR (Strings.Compare(name, "CON") = 0) THEN
+      (* con already opened, but reset it *)
+      Okay := TRUE; f := con;
+      f^.savedCh := 0C; f^.haveCh := FALSE;
+      f^.eof := FALSE; f^.eol := FALSE; f^.name := "CON";
+      RETURN
+    ELSIF Strings.Compare(name, "ERR") = 0 THEN
+      Okay := TRUE; f := err; RETURN
+    ELSE
+      ALLOCATE(f, SIZE(FileRec));
+      NoWrite := FALSE;
+      IF newFile
+        THEN FileSystem.Create( f^.ref, fileName)
+        ELSE
+          FileSystem.Lookup(f^.ref, fileName, FALSE );
+      END;
+      Okay := f^.ref.res = 0;
+      IF ~ Okay
+        THEN
+          DEALLOCATE(f, SIZE(FileRec)); f := NIL
+        ELSE
+      (* textOK below may have to be altered according to implementation *)
+          f^.savedCh := 0C; f^.haveCh := FALSE; f^.textOK := TRUE;
+          f^.eof := newFile; f^.eol := newFile; f^.self := f;
+          f^.noInput := newFile; f^.noOutput := ~ newFile OR NoWrite;
+          ASCIIZ(f^.name, fileName);
+          i := 0 (* find next available filehandle *);
+          WHILE (i IN Handles) & (i < MaxFiles) DO INC(i) END;
+          IF i < MaxFiles
+            THEN f^.handle := i; INCL(Handles, i); Opened[i] := f
+            ELSE (* WriteString(err, "Too many files"); Okay := FALSE *)
+          END;
+        (*  IF Okay THEN FIO.AssignBuffer(f^.ref, f^.buffer) END; *)
+      END
+    END
+  END Open;
+
+
+PROCEDURE NotRead (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noInput);
+  END NotRead;
+
+PROCEDURE NotWrite (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noOutput);
+  END NotWrite;
+
+PROCEDURE NotFile (f: File): BOOLEAN;
+  BEGIN
+    IF (f = NIL) THEN RETURN TRUE END;
+    IF (f^.self # f) OR (File(f) = con) OR (File(f) = err)
+    THEN RETURN TRUE END;
+    IF (File(f) = StdIn) & FromKeyboard
+    THEN RETURN TRUE END;
+    IF (File(f) = StdOut) & ToScreen
+    THEN RETURN TRUE END;
+    RETURN FALSE
+  END NotFile;
+
+PROCEDURE Close (VAR f: File);
+  BEGIN
+   (* IF f = NIL THEN RETURN END;*)
+    IF NotFile(f) OR (File(f) = StdIn) OR (File(f) = StdOut)
+      THEN Okay := FALSE
+      ELSE
+        EXCL(Handles, f^.handle);
+        FileSystem.Close(f^.ref);
+        Okay := f^.ref.res = 0;
+        IF Okay THEN DEALLOCATE(f, TSIZE(FileRec)) END;
+        f := NIL
+    END
+  END Close;
+
+
+PROCEDURE CloseAll;
+  VAR
+    handle: CARDINAL;
+  BEGIN
+    FOR handle := 0 TO MaxFiles - 1 DO
+      IF handle IN Handles THEN Close(Opened[handle]) END
+    END;
+    IF ~ ToScreen THEN FileSystem.Close(StdOut^.ref) END;
+    Continue;
+  END CloseAll;
+
+
+PROCEDURE Delete (VAR f: File);
+  BEGIN
+    IF NotFile(f) OR (File(f) = StdIn) OR (File(f) = StdOut)
+      THEN Okay := FALSE
+      ELSE
+        EXCL(Handles, f^.handle);
+        FileSystem.Close (f^.ref);
+        FileSystem.Delete(f^.ref);
+        Okay := f^.ref.res = 0;
+        IF Okay THEN DEALLOCATE(f, TSIZE(FileRec)) END;
+        f := NIL
+    END
+  END Delete;
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+BEGIN
+  RETURN CARDINAL ( Strings.Length(stringVal) )
+END SLENGTH;
+
+
+PROCEDURE Concat (string1, string2: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+BEGIN
+  Strings.Concat( string1, string2,destination );
+END Concat;
+
+PROCEDURE Assign ( source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+BEGIN
+  Strings.Assign ( source, destination )
+END Assign;
+
+PROCEDURE Extract (source: ARRAY OF CHAR; startIndex: CARDINAL;
+                   numberToExtract: CARDINAL; VAR destination: ARRAY OF CHAR);
+BEGIN
+  Strings.Copy (source, startIndex, numberToExtract, destination )
+END Extract;
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+BEGIN
+  RETURN Strings.Compare(stringVal1, stringVal2)
+END Compare;
+
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+  VAR
+    i, j: INTEGER;
+    k : CARDINAL;
+    c: CHAR;
+    fname: ARRAY [0 .. NameLength] OF CHAR;
+    path: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    FOR k := 0 TO CARDINAL ( HIGH(envVar) ) DO envVar[k] := CAP(envVar[k]) END;
+    GetEnv(envVar, path);
+    i := 0;
+    REPEAT
+      j := 0;
+      REPEAT
+        c := path[i]; fname[j] := c; INC(i); INC(j)
+      UNTIL (c = PathSep) OR (c = 0C);
+      IF (j > 1) & (fname[j-2] = DirSep) THEN DEC(j) ELSE fname[j-1] := DirSep END;
+      fname[j] := 0C; Concat(fname, fileName, fname);
+      Open(f, fname, newFile);
+    UNTIL (c = 0C) OR Okay
+  END SearchFile;
+
+
+PROCEDURE ExtractFileName (fullName : ARRAY OF CHAR; VAR fileName : ARRAY OF CHAR );
+VAR  i, l, start: CARDINAL;
+BEGIN
+  start := 0; l := 0;
+  WHILE (l <= HIGH(fullName)) & (fullName[l] # 0C) DO
+  IF (fullName[l] = ":") OR (fullName[l] = DirSep) THEN start := l + 1 END;
+  INC(l)
+  END;
+  i := 0;
+  WHILE (start < l) & (i <= HIGH(fileName)) DO
+  fileName[i] := fullName[start]; INC(start); INC(i)
+  END;
+  IF i <= HIGH(fileName) THEN fileName[i] := 0C END
+END ExtractFileName;
+
+PROCEDURE ExtractDirectory (fullName : ARRAY OF CHAR; VAR directory : ARRAY OF CHAR );
+VAR  i, start: CARDINAL;
+BEGIN
+  start := 0; i := 0;
+  WHILE (i <= HIGH(fullName)) & (fullName[i] # 0C) DO
+  IF i <= HIGH(directory) THEN directory[i] := fullName[i]  END;
+  IF (fullName[i] = ":") OR (fullName[i] = DirSep) THEN start := i + 1 END;
+  INC(i)
+  END;
+  IF start <= HIGH(directory) THEN directory[start] := 0C END
+END ExtractDirectory ;
+
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR; VAR newName: ARRAY OF CHAR);
+VAR i, j: CARDINAL;
+    fn: ARRAY [0 .. NameLength] OF CHAR;
+BEGIN
+  ExtractDirectory(oldName, newName);
+  ExtractFileName(oldName, fn);
+  i := 0; j := 0;
+  WHILE (i <= NameLength) & (fn[i] # 0C) DO
+  IF fn[i] = "." THEN j := i + 1 END;
+  INC(i)
+  END;
+  IF (j # i) (* then name did not end with "." *) OR (i = 0)
+  THEN IF j # 0 THEN i := j - 1 END;
+       IF (ext[0] # ".") & (ext[0] # 0C) THEN
+       IF i <= NameLength THEN fn[i] := "."; INC(i) END
+  END;
+  j := 0;
+  WHILE (j <= HIGH(ext)) & (ext[j] # 0C) & (i <= NameLength) DO
+  fn[i] := ext[j]; INC(i); INC(j)
+  END
+  END;
+  IF i <= NameLength THEN fn[i] := 0C END;
+  Strings.Concat(newName, fn, newName)
+END AppendExtension;
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR; VAR newName: ARRAY OF CHAR);
+VAR i, j: CARDINAL;
+    fn: ARRAY [0 .. NameLength] OF CHAR;
+BEGIN
+  ExtractDirectory(oldName, newName);
+  ExtractFileName(oldName, fn);
+  i := 0; j := 0;
+  WHILE (i <= NameLength) & (fn[i] # 0C) DO
+  IF fn[i] = "." THEN j := i + 1 END;
+  INC(i)
+  END;
+  IF j # 0 THEN i := j - 1 END;
+  IF (ext[0] # ".") & (ext[0] # 0C)
+  THEN IF i <= NameLength THEN fn[i] := "."; INC(i) END
+  END;
+  j := 0;
+  WHILE (j <= HIGH(ext)) & (ext[j] # 0C) & (i <= NameLength) DO
+  fn[i] := ext[j]; INC(i); INC(j)
+  END;
+  IF i <= NameLength THEN fn[i] := 0C END;
+  Strings.Concat(newName, fn, newName)
+END ChangeExtension;
+
+
+PROCEDURE Length (f: File): INT32;
+VAR result: LONGCARD;
+BEGIN
+  IF NotFile(f)
+  THEN Okay := FALSE; RETURN 0
+  ELSE FileSystem.LongLength (f^.ref, result );
+       Okay := f^.ref.res = 0;
+       RETURN INT32(result)
+  END
+END Length;
+
+PROCEDURE GetPos (f: File): INT32;
+VAR pos: LONGCARD;
+BEGIN
+  IF NotFile(f)
+  THEN Okay := FALSE; RETURN Long0
+  ELSE FileSystem.GetLongPos(f^.ref,  pos );
+       Okay :=  f^.ref.res = 0;
+       RETURN pos
+  END
+END GetPos;
+
+PROCEDURE SetPos (f: File; pos: INT32);
+BEGIN
+  IF NotFile(f)
+  THEN Okay := FALSE
+  ELSE FileSystem.SetLongPos(f^.ref, LONGCARD(pos) );
+       Okay := f^.ref.res = 0; f^.haveCh := FALSE
+  END
+END SetPos;
+
+
+PROCEDURE Reset (f: File);
+BEGIN
+  IF NotFile(f)
+  THEN Okay := FALSE
+  ELSE SetPos(f, 0);
+    IF Okay
+    THEN f^.haveCh := FALSE;
+         f^.eof := f^.noInput;
+         f^.eol := f^.noInput
+    END
+  END
+END Reset;
+
+
+PROCEDURE Rewrite (f: File);
+VAR c: CHAR;
+BEGIN
+  IF NotFile(f)
+  THEN Okay := FALSE
+  ELSE SetPos(f, 0);
+    IF Okay
+    THEN WriteBytes(f, c, 0);
+         f^.haveCh := FALSE;
+         f^.savedCh := 0C;
+         f^.eof := FALSE;
+         f^.eol := FALSE
+    END
+  END
+END Rewrite;
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+BEGIN
+  IF NotRead(f)
+  THEN Okay := FALSE;
+       RETURN TRUE
+  ELSE Okay := TRUE;
+       RETURN f^.eol OR f^.eof
+  END
+END EndOfLine;
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+BEGIN
+  IF NotRead(f)
+  THEN Okay := FALSE;
+       RETURN TRUE
+  ELSE Okay := TRUE;
+       RETURN f^.eof
+  END
+END EndOfFile;
+
+
+PROCEDURE ErrWrite (ch: CHAR);
+CONST StdErr = DOSFILEMGR.STDERR;
+VAR c : ARRAY [0..0] OF CHAR;
+    res,n : LONGCARD;
+BEGIN
+  c[0] := ch;
+  res := LONGCARD( DOSFILEMGR.DosWrite (StdErr,c,1,n))
+END ErrWrite;
+
+(* --------------A VERIFIER ------>>>> redirection *)
+
+PROCEDURE ConRead (VAR ch: CHAR);
+BEGIN
+  InOut.Read ( ch )
+END ConRead;
+
+PROCEDURE ConWrite ( ch : CHAR );
+BEGIN
+  InOut.Write (ch );
+END ConWrite;
+(*------------------------------------------------*)
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+BEGIN
+  IF NotRead(f) THEN Okay := FALSE; ch := 0C; RETURN END;
+  IF f^.haveCh OR f^.eof
+  THEN ch := f^.savedCh;
+       Okay := ch # 0C;
+  ELSE
+    IF (File(f) = con) OR (File(f) = StdIn) & FromKeyboard
+    THEN ConRead(ch);
+         Write(con, ch);
+         IF ch = BS
+         THEN ConWrite(" ");
+              ConWrite(BS)
+         END;
+         Okay := ch # EOFChar;
+     ELSE FileSystem.ReadChar(f^.ref, ch);
+          IF ch = CR THEN FileSystem.ReadChar(f^.ref, ch); ch := EOL END;
+             Okay := f^.ref.res = 0;
+          IF ch = EOFChar THEN Okay := FALSE END;
+     END;
+  END;
+  IF ~ Okay THEN ch := 0C END;
+  f^.savedCh := ch; f^.haveCh := ~ Okay;
+  f^.eof := ch = 0C; f^.eol := f^.eof OR (ch = EOL);
+END Read;
+
+
+PROCEDURE ReadAgain (f: File);
+BEGIN
+  IF NotRead(f)
+  THEN Okay := FALSE
+  ELSE f^.haveCh := TRUE
+  END
+END ReadAgain;
+
+PROCEDURE ReadLn (f: File);
+VAR ch: CHAR;
+BEGIN
+  IF NotRead(f) THEN Okay := FALSE; RETURN END;
+  WHILE ~ f^.eol DO Read(f, ch) END;
+  f^.haveCh := FALSE; f^.eol := FALSE;
+END ReadLn;
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+VAR j: CARDINAL;
+    ch: CHAR;
+BEGIN
+  str[0] := 0C; j := 0;
+  IF NotRead(f) THEN Okay := FALSE; RETURN END;
+  REPEAT Read(f, ch) UNTIL (ch # " ") OR ~ Okay;
+  IF Okay THEN
+  WHILE ch >= " " DO
+    IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+    Read(f, ch);
+    WHILE (ch = BS) OR (ch = DEL) DO
+      IF j > 0 THEN DEC(j) END; Read(f, ch) END
+    END;
+    IF j <= HIGH(str) THEN str[j] := 0C END;
+    Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+  END
+END ReadString;
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+VAR j: CARDINAL;
+    ch: CHAR;
+BEGIN
+  str[0] := 0C; j := 0;
+  IF NotRead(f) THEN Okay := FALSE; RETURN END;
+  Read(f, ch);
+  IF Okay
+  THEN WHILE ch >= " " DO
+         IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+         Read(f, ch);
+         WHILE (ch = BS) OR (ch = DEL) DO
+           IF j > 0 THEN DEC(j) END; Read(f, ch)
+         END
+       END;
+       IF j <= HIGH(str) THEN str[j] := 0C END;
+       Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+  END
+END ReadLine;
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+VAR j: CARDINAL;
+    ch: CHAR;
+BEGIN
+  str[0] := 0C; j := 0;
+  IF NotRead(f) THEN Okay := FALSE; RETURN END;
+  REPEAT Read(f, ch) UNTIL (ch > " ") OR ~ Okay;
+  IF Okay
+  THEN WHILE ch > " " DO
+         IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+         Read(f, ch);
+         WHILE (ch = BS) OR (ch = DEL) DO
+           IF j > 0 THEN DEC(j) END; Read(f, ch)
+         END
+       END;
+       IF j <= HIGH(str) THEN str[j] := 0C END;
+       Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+  END
+END ReadToken;
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+  VAR
+    Digit: INTEGER;
+    j: CARDINAL;
+    Negative: BOOLEAN;
+    s: ARRAY [0 .. 80] OF CHAR;
+  BEGIN
+    i := 0; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    ReadToken(f, s);
+    IF s[0] = "-" (* deal with sign *)
+      THEN Negative := TRUE; INC(j)
+      ELSE Negative := FALSE; IF s[0] = "+" THEN INC(j) END
+    END;
+    IF (s[j] < "0") OR (s[j] > "9") THEN Okay := FALSE END;
+    WHILE (j <= 80) & (s[j] >= "0") & (s[j] <= "9") DO
+      Digit := VAL(INTEGER, ORD(s[j]) - ORD("0"));
+      IF i <= (MAX(INTEGER) - Digit) DIV 10
+        THEN i := 10 * i + Digit
+        ELSE Okay := FALSE
+      END;
+      INC(j)
+    END;
+    IF Negative THEN i := -i END;
+    IF (j > 80) OR (s[j] # 0C) THEN Okay := FALSE END;
+    IF ~ Okay THEN i := 0 END;
+  END ReadInt;
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+  VAR
+    Digit: CARDINAL;
+    j: CARDINAL;
+    s: ARRAY [0 .. 80] OF CHAR;
+  BEGIN
+    i := 0; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    ReadToken(f, s);
+    WHILE (j <= 80) & (s[j] >= "0") & (s[j] <= "9") DO
+      Digit := ORD(s[j]) - ORD("0");
+      IF i <= (MAX(CARDINAL) - Digit) DIV 10
+        THEN i := 10 * i + Digit
+        ELSE Okay := FALSE
+      END;
+      INC(j)
+    END;
+    IF (j > 80) OR (s[j] # 0C) THEN Okay := FALSE END;
+    IF ~ Okay THEN i := 0 END;
+  END ReadCard;
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+VAR TooMany: BOOLEAN;
+    Wanted : LONGCARD;
+BEGIN
+  IF NotRead(f) OR (File(f) = con)
+  THEN Okay := FALSE; len := 0;
+  ELSE
+    IF len = 0 THEN Okay := TRUE; RETURN END;
+    TooMany := len - 1 > HIGH(buf);
+    IF TooMany THEN Wanted := HIGH(buf) + 1 ELSE Wanted := len END;
+    f^.ref.res := LONGCARD ( DOSFILEMGR.DosRead( f^.ref.id, buf, HIGH(buf)+1, Wanted ));
+    Okay := f^.ref.res = 0;
+    IF len # Wanted THEN Okay := FALSE END;
+  END;
+  IF ~ Okay THEN f^.eof := TRUE END;
+  IF TooMany THEN Okay := FALSE END;
+END ReadBytes;
+
+PROCEDURE Write (f: File; ch: CHAR);
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    IF (File(f) = con) OR (File(f) = StdOut) & ToScreen
+      THEN
+        IF ch = EOL
+          THEN ConWrite(CR); ConWrite(LF)
+          ELSE ConWrite(ch)
+        END;
+        Okay := TRUE;
+      ELSIF File(f) = err
+        THEN
+          IF ch = EOL
+            THEN ErrWrite(CR); ErrWrite(LF)
+            ELSE ErrWrite(ch)
+          END;
+          Okay := TRUE;
+      ELSE
+        IF ch = EOL
+          THEN FileSystem.WriteLn(f^.ref)
+          ELSE FileSystem.WriteChar(f^.ref, ch)
+        END;
+        Okay := f^.ref.res = 0;
+    END;
+  END Write;
+
+PROCEDURE WriteLn (f: File);
+  BEGIN
+    IF NotWrite(f)
+      THEN Okay := FALSE;
+      ELSE Write(f, EOL)
+    END
+  END WriteLn;
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+  VAR
+    pos: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    pos := 0;
+    WHILE (pos <= HIGH(str)) & (str[pos] # 0C) DO
+      Write(f, str[pos]); INC(pos)
+    END
+  END WriteString;
+
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+  VAR i,j, slen : LONGCARD;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    IF len > 0 THEN j := LONGCARD(len - 1) ELSE j := 0 END;
+    slen := Strings.Length(text);
+    FOR i := 0 TO j DO
+      IF i < slen THEN Write(f, text[i]) ELSE Write(f, " ") END;
+    END
+  END WriteText;
+
+PROCEDURE WriteInt (f: File; n: INTEGER; wid: CARDINAL);
+  VAR
+    l, d: CARDINAL;
+    x: INTEGER;
+    t: ARRAY [1 .. 25] OF CHAR;
+    sign: CHAR;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    IF n < 0
+      THEN sign := "-"; x := - n;
+      ELSE sign := " "; x := n;
+    END;
+    l := 0;
+    REPEAT
+      d := x MOD 10; x := x DIV 10;
+      INC(l); t[l] := CHR(ORD("0") + d);
+    UNTIL x = 0;
+    IF wid = 0 THEN Write(f, " ") END;
+    WHILE wid > l + 1 DO Write(f, " "); DEC(wid); END;
+    IF (sign = "-") OR (wid > l) THEN Write(f, sign); END;
+    WHILE l > 0 DO Write(f, t[l]); DEC(l); END;
+  END WriteInt;
+
+PROCEDURE WriteCard (f: File; n, wid: CARDINAL);
+  VAR
+    l, d: CARDINAL;
+    t: ARRAY [1 .. 25] OF CHAR;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    l := 0;
+    REPEAT
+      d := n MOD 10; n := n DIV 10;
+      INC(l); t[l] := CHR(ORD("0") + d);
+    UNTIL n = 0;
+    IF wid = 0 THEN Write(f, " ") END;
+    WHILE wid > l DO Write(f, " "); DEC(wid); END;
+    WHILE l > 0 DO Write(f, t[l]); DEC(l); END;
+  END WriteCard;
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+  VAR
+    TooMany: BOOLEAN;
+    len2 : LONGCARD;
+  BEGIN
+    TooMany := (len > 0) & (len - 1 > HIGH(buf));
+    IF NotWrite(f) OR (File(f) = con) OR (File(f) = err)
+      THEN
+        Okay := FALSE
+      ELSE
+        IF TooMany THEN len := CARDINAL ( HIGH(buf) + 1 ) END;
+        len2 :=  LONGCARD (len);
+        f^.ref.res := LONGCARD ( DOSFILEMGR.DosRead( f^.ref.id, buf, HIGH(buf)+1, len2 ));
+        Okay := f^.ref.res = 0;
+    END;
+    IF TooMany THEN Okay := FALSE END;
+  END WriteBytes;
+
+PROCEDURE Write2 (f: File; i: SHORTCARD);
+  BEGIN
+    Write(f, CHR(i DIV 10 + ORD("0")));
+    Write(f, CHR(i MOD 10 + ORD("0")));
+  END Write2;
+
+
+PROCEDURE WriteDate (f: File);
+  VAR
+    dt : DATETIME;
+    r : APIRET;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    r := DosGetDateTime (dt);
+    WITH dt DO
+    Write2(f, day); Write(f, "/"); Write2(f, month); Write(f, "/");
+    WriteCard(f, year, 4)
+    END;
+  END WriteDate;
+
+PROCEDURE WriteTime (f: File);
+  VAR
+    dt : DATETIME;
+    r : APIRET;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    r := DosGetDateTime ( dt);
+    WITH dt DO
+    Write2(f, hours); Write(f, ":"); Write2(f, minutes); Write(f, ":");
+    Write2(f, seconds)
+    END;
+  END WriteTime;
+
+VAR
+  Hrs0, Mins0, Secs0, Hsecs0: SHORTCARD;
+  Hrs1, Mins1, Secs1, Hsecs1: SHORTCARD;
+
+PROCEDURE GetInitTime();
+VAR dt : DATETIME;
+    r : APIRET;
+BEGIN
+  r := DosGetDateTime ( dt );
+  WITH dt DO
+  Hrs0 := hours; Mins0 := minutes;
+  Secs0 := seconds; Hsecs0 :=   hundredths;
+  END;
+END GetInitTime;
+
+
+PROCEDURE WriteElapsedTime (f: File);
+  VAR dt : DATETIME;
+      r : APIRET;
+      s : CARDINAL;
+      hs : SHORTCARD;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    r:= DosGetDateTime( dt );
+    WriteString(f, "Elapsed time: ");
+    WITH dt DO
+    IF hours >= Hrs1
+      THEN s := (hours - Hrs1) * 3600 + (minutes - Mins1) * 60 + seconds - Secs1
+      ELSE s := (hours + 24 - Hrs1) * 3600 + (minutes - Mins1) * 60 + seconds - Secs1
+    END;
+    IF hundredths >= Hsecs1
+      THEN hs := hundredths - Hsecs1
+      ELSE hs := (hundredths + 100) - Hsecs1; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, ".");
+    Write2(f, hs); WriteString(f, " s"); WriteLn(f);
+    Hrs1 := hours; Mins1 := minutes; Secs1 := seconds; Hsecs1 := hundredths;
+    END;
+  END WriteElapsedTime;
+
+
+PROCEDURE WriteExecutionTime (f: File);
+ VAR dt : DATETIME;
+      r : APIRET;
+      s : CARDINAL;
+      hs : SHORTCARD;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    r:= DosGetDateTime( dt );
+    WriteString(f, "Execution time: ");
+    WITH dt DO
+    IF hours >= Hrs0
+      THEN s := (hours - Hrs0) * 3600 + (minutes - Mins0) * 60 + seconds - Secs0
+      ELSE s := (hours + 24 - Hrs0) * 3600 + (minutes - Mins0) * 60 + seconds - Secs0
+    END;
+    IF hundredths >= Hsecs0
+      THEN hs := hundredths - Hsecs0
+      ELSE hs := (hundredths + 100) - Hsecs0; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, ".");
+    Write2(f, hs); WriteString(f, " s"); WriteLn(f);
+    END;
+  END WriteExecutionTime;
+
+
+PROCEDURE INTL (n: INT32): INTEGER;
+BEGIN
+  RETURN VAL(INTEGER, n)
+END INTL;
+
+PROCEDURE INT (n: CARDINAL): INT32;
+BEGIN
+  RETURN VAL(INT32, n)
+END INT;
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+BEGIN
+  RETURN VAL(CARDINAL, n)
+END ORDL;
+
+PROCEDURE QuitExecution;
+BEGIN
+  HALT
+END QuitExecution;
+
+(* OS2 Std Channels *)
+PROCEDURE InitStdChannels();
+BEGIN
+WITH StdOut^.ref DO
+ id := DOSFILEMGR.STDOUT;
+ eof := FALSE;
+ tmp := FALSE;
+ name := "SCREEN$";
+END;
+WITH StdIn^.ref DO
+ id := DOSFILEMGR.STDIN;
+ eof := FALSE;
+ tmp := FALSE;
+ name := "KBD$";
+END;
+END InitStdChannels;
+
+
+
+BEGIN
+  Handles := BITSET{};
+  Okay := FALSE; EOFChar := 32C;
+  Param := 0;
+  GetInitTime();
+  Hrs1 := Hrs0; Mins1 := Mins0; Secs1 := Secs0; Hsecs1 := Hsecs0;
+
+  ALLOCATE(con, SYSTEM.TSIZE(FileRec));
+  con^.ref := InOut.out;
+  con^.savedCh := 0C; con^.haveCh := FALSE; con^.self := con;
+  con^.noOutput := FALSE; con^.noInput := FALSE; con^.textOK := TRUE;
+  con^.eof := FALSE; con^.eol := FALSE;
+
+  IF FromKeyboard
+    THEN ALLOCATE(StdIn, SYSTEM.TSIZE(FileRec));
+    ELSE ALLOCATE(StdIn, SYSTEM.TSIZE(FileRec));
+
+  END;
+  StdIn^.ref := InOut.in;
+  StdIn^.savedCh := 0C; StdIn^.haveCh := FALSE; StdIn^.self := StdIn;
+  StdIn^.noOutput := TRUE; StdIn^.noInput := FALSE; StdIn^.textOK := TRUE;
+  StdIn^.eof := FALSE; StdIn^.eol := FALSE;
+
+  IF ToScreen
+    THEN ALLOCATE(StdOut, SYSTEM.TSIZE(FileRec));
+    ELSE ALLOCATE(StdOut, SYSTEM.TSIZE(FileRec));
+
+  END;
+  StdOut^.ref := InOut.out;
+  StdOut^.savedCh := 0C; StdOut^.haveCh := FALSE; StdOut^.self := StdOut;
+  StdOut^.noOutput := FALSE; StdOut^.noInput := TRUE; StdOut^.textOK := TRUE;
+  StdOut^.eof := TRUE; StdOut^.eol := TRUE;
+  InitStdChannels();
+
+END FileIO .
+

Docs/FileIO-2.def

@@ -0,0 +1,328 @@
+DEFINITION MODULE FileIO;
+(* This module attempts to provide several potentially non-portable
+   facilities for Coco/R.
+
+   (a)  A general file input/output module, with all routines required for
+        Coco/R itself, as well as several other that would be useful in
+        Coco-generated applications.
+   (b)  Definition of the "LONGINT" type needed by Coco.
+   (c)  Some conversion functions to handle this long type.
+   (d)  Some "long" and other constant literals that may be problematic
+        on some implementations.
+   (e)  Some string handling primitives needed to interface to a variety
+        of known implementations.
+
+   The intention is that the rest of the code of Coco and its generated
+   parsers should be as portable as possible.  Provided the definition
+   module given, and the associated implementation, satisfy the
+   specification given here, this should be almost 100% possible (with
+   the exception of a few constants, avoid changing anything in this
+   specification).
+
+   FileIO is based on code by MB 1990/11/25; heavily modified and extended
+   by PDT and others between 1992/1/6 and the present day. *)
+
+IMPORT SYSTEM;
+
+TYPE
+  File;                (* Preferably opaque *)
+  INT32 = LONGINT;     (* This may require a special import; on 32 bit
+                          systems INT32 = INTEGER may even suffice. *)
+
+CONST
+  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). *)
+
+  BitSetSize = 16;     (* number of bits actually used in BITSET type *)
+
+  Long0 = VAL(INT32, 0); (* Some systems allow 0 or require 0L. *)
+  Long1 = VAL(INT32, 1); (* Some systems allow 1 or require 1L. *)
+  Long2 = VAL(INT32, 2); (* Some systems allow 2 or require 2L. *)
+
+  FrmExt = ".frm";     (* supplied frame files have this extension. *)
+  TxtExt = ".txt";     (* generated text files may have this extension. *)
+  ErrExt = ".err";     (* generated error files may have this extension. *)
+  DefExt = ".def";     (* generated definition modules have this extension. *)
+  PasExt = ".pas";     (* generated Pascal units have this extension. *)
+  ModExt = ".mod";     (* generated implementation/program modules have this
+                          extension. *)
+  PathSep = ":";       (* separate components in path environment variables
+                          DOS = ";"  UNIX = ":" *)
+  DirSep  = "/";       (* separate directory element of file specifiers
+                          DOS = "\"  UNIX = "/" *)
+
+VAR
+  Okay: BOOLEAN;       (* Status of last I/O operation. *)
+  con, err:  File;     (* Standard terminal and error channels. *)
+  StdIn, StdOut: File; (* standard input/output - redirectable *)
+  EOFChar: CHAR;       (* Signal EOF interactively *)
+
+(* The following routines provide access to command line parameters and
+   the environment. *)
+
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+(* Extracts next parameter from command line.
+   Returns empty string (s[0] = 0C) if no further parameter can be found. *)
+
+PROCEDURE GetEnv (envVar: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+(* Returns s as the value of environment variable envVar, or empty string
+   if that variable is not defined. *)
+
+(* The following routines provide a minimal set of file opening routines
+   and closing routines. *)
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+(* Opens file f whose full name is specified by fileName.
+   Opening mode is specified by newFile:
+       TRUE:  the specified file is opened for output only.  Any existing
+              file with the same name is deleted.
+      FALSE:  the specified file is opened for input only.
+   FileIO.Okay indicates whether the file f has been opened successfully. *)
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+(* As for Open, but tries to open file of given fileName by searching each
+   directory specified by the environment variable named by envVar. *)
+
+PROCEDURE Close (VAR f: File);
+(* Closes file f.  f becomes NIL.
+   If possible, Close should be called automatically for all files that
+   remain open when the application terminates.  This will be possible on
+   implementations that provide some sort of termination or at-exit
+   facility. *)
+
+PROCEDURE CloseAll;
+(* Closes all files opened by Open or SearchFile.
+   On systems that allow this, CloseAll should be automatically installed
+   as the termination (at-exit) procedure *)
+
+(* The following utility procedure is not used by Coco, but may be useful.
+   However, some operating systems may not allow for its implementation. *)
+
+PROCEDURE Delete (VAR f: File);
+(* Deletes file f.  f becomes NIL. *)
+
+(* The following routines provide a minimal set of file name manipulation
+   routines.  These are modelled after MS-DOS conventions, where a file
+   specifier is of a form exemplified by D:\DIR\SUBDIR\PRIMARY.EXT
+   Other conventions may be introduced; these routines are used by Coco to
+   derive names for the generated modules from the grammar name and the
+   directory in which the grammar specification is located. *)
+
+PROCEDURE ExtractDirectory (fullName: ARRAY OF CHAR;
+                            VAR directory: ARRAY OF CHAR);
+(* Extracts D:\DIRECTORY\ portion of fullName. *)
+
+PROCEDURE ExtractFileName (fullName: ARRAY OF CHAR;
+                           VAR fileName: ARRAY OF CHAR);
+(* Extracts PRIMARY.EXT portion of fullName. *)
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as complete file name by appending ext to oldName
+   if it doesn't end with "."  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as a complete file name by changing extension of
+   oldName to ext.  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.EXT
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+
+(* The following routines provide a minimal set of file positioning routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+
+PROCEDURE Length (f: File): INT32;
+(* Returns length of file f. *)
+
+PROCEDURE GetPos (f: File): INT32;
+(* Returns the current read/write position in f. *)
+
+PROCEDURE SetPos (f: File; pos: INT32);
+(* Sets the current position for f to pos. *)
+
+(* The following routines provide a minimal set of file rewinding routines.
+   These two are not currently used by Coco itself.
+   Success of each operation is recorded in FileIO.Okay *)
+
+PROCEDURE Reset (f: File);
+(* Sets the read/write position to the start of the file *)
+
+PROCEDURE Rewrite (f: File);
+(* Truncates the file, leaving open for writing *)
+
+(* The following routines provide a minimal set of input routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of a line, or at end of file. *)
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of file. *)
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+(* Reads a character ch from file f.
+   Maps filing system line mark sequence to FileIO.EOL. *)
+
+PROCEDURE ReadAgain (f: File);
+(* Prepares to re-read the last character read from f.
+   There is no buffer, so at most one character can be re-read. *)
+
+PROCEDURE ReadLn (f: File);
+(* Reads to start of next line on file f, or to end of file if no next
+   line.  Skips to, and consumes next line mark. *)
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are skipped, and str is delimited by line mark.
+   Line mark is not consumed. *)
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are not skipped, and str is terminated by line mark or
+   control character, which is not consumed. *)
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks and line feeds are skipped, and token is terminated by a
+   character <= ' ', which is not consumed. *)
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+(* Reads an integer value from file f. *)
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+(* Reads a cardinal value from file f. *)
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+(* Attempts to read len bytes from the current file position into buf.
+   After the call, len contains the number of bytes actually read. *)
+
+(* The following routines provide a minimal set of output routines.
+   Others may be introduced, but at least these should be implemented. *)
+
+PROCEDURE Write (f: File; ch: CHAR);
+(* Writes a character ch to file f.
+   If ch = FileIO.EOL, writes line mark appropriate to filing system. *)
+
+PROCEDURE WriteLn (f: File);
+(* Skips to the start of the next line on file f.
+   Writes line mark appropriate to filing system. *)
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+(* Writes entire string str to file f. *)
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+(* Writes text to file f.
+   At most len characters are written.  Trailing spaces are introduced
+   if necessary (thus providing left justification). *)
+
+PROCEDURE WriteInt (f: File; int: INTEGER; wid: CARDINAL);
+(* Writes an INTEGER int into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+
+PROCEDURE WriteCard (f: File; card, wid: CARDINAL);
+(* Writes a CARDINAL card into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+(* Writes len bytes from buf to f at the current file position. *)
+
+(* The following procedures are not currently used by Coco, and may be
+   safely omitted, or implemented as null procedures.  They might be
+   useful in measuring performance. *)
+
+PROCEDURE WriteDate (f: File);
+(* Write current date DD/MM/YYYY to file f. *)
+
+PROCEDURE WriteTime (f: File);
+(* Write time HH:MM:SS to file f. *)
+
+PROCEDURE WriteElapsedTime (f: File);
+(* Write elapsed time in seconds since last call of this procedure. *)
+
+PROCEDURE WriteExecutionTime (f: File);
+(* Write total execution time in seconds thus far to file f. *)
+
+(* The following procedures are a minimal set used within Coco for
+   string manipulation.  They almost follow the conventions of the ISO
+   routines, and are provided here to interface onto whatever Strings
+   library is available.  On ISO compilers it should be possible to
+   implement most of these with CONST declarations, and even replace
+   SLENGTH with the pervasive function LENGTH at the points where it is
+   called.
+
+CONST
+  SLENGTH = Strings.Length;
+  Assign  = Strings.Assign;
+  Extract = Strings.Extract;
+  Concat  = Strings.Concat;
+
+*)
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+(* Returns number of characters in stringVal, not including nul *)
+
+PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+(* Copies as much of source to destination as possible, truncating if too
+   long, and nul terminating if shorter.
+   Be careful - some libraries have the parameters reversed! *)
+
+PROCEDURE Extract (source: ARRAY OF CHAR;
+                   startIndex, numberToExtract: CARDINAL;
+                   VAR destination: ARRAY OF CHAR);
+(* Extracts at most numberToExtract characters from source[startIndex]
+   to destination.  If source is too short, fewer will be extracted, even
+   zero perhaps *)
+
+PROCEDURE Concat (stringVal1, stringVal2: ARRAY OF CHAR;
+                  VAR destination: ARRAY OF CHAR);
+(* Concatenates stringVal1 and stringVal2 to form destination.
+   Nul terminated if concatenation is short enough, truncated if it is
+   too long *)
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+(* Returns -1, 0, 1 depending whether stringVal1 < = > stringVal2.
+   This is not directly ISO compatible *)
+
+(* The following routines are for conversions to and from the INT32 type.
+   Their names are modelled after the ISO pervasive routines that would
+   achieve the same end.  Where possible, replacing calls to these routines
+   by the pervasives would improve performance markedly.  As used in Coco,
+   these routines should not give range problems. *)
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+(* Convert long integer n to corresponding (short) cardinal value.
+   Potentially FileIO.ORDL(n) = VAL(CARDINAL, n) *)
+
+PROCEDURE INTL (n: INT32): INTEGER;
+(* Convert long integer n to corresponding short integer value.
+   Potentially FileIO.INTL(n) = VAL(INTEGER, n) *)
+
+PROCEDURE INT (n: CARDINAL): INT32;
+(* Convert cardinal n to corresponding long integer value.
+   Potentially FileIO.INT(n) = VAL(INT32, n) *)
+
+PROCEDURE QuitExecution;
+(* Close all files and halt execution.
+   On some implementations QuitExecution will be simply implemented as HALT *)
+
+END FileIO.

Docs/FileIO-2.mod

@@ -0,0 +1,571 @@
+IMPLEMENTATION MODULE FileIO;
+
+IMPORT FIO, Strings, SYSTEM, Environment, FileSystem, ProgramArgs;
+FROM Storage IMPORT ALLOCATE, DEALLOCATE;
+
+CONST
+  MaxFiles = BitSetSize;
+  NameLength = 256;
+  BufSize  = 2048; (*1024 + FIO.BufferOverhead;*)
+  (*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
+  Buftype = ARRAY [1 .. BufSize] OF CHAR;
+  File = POINTER TO FileRec;
+  FileRec = RECORD
+              ref: FIO.File;
+              self: File;
+              handle: CARDINAL;
+              savedCh: CHAR;
+              textOK, eof, eol, noOutput, noInput, haveCh: BOOLEAN;
+              name: ARRAY [0 .. NameLength] OF CHAR;
+              buffer: Buftype;
+            END;
+
+
+VAR
+  Handles: BITSET;
+  Opened: ARRAY [0 .. MaxFiles-1] OF File;
+  FromKeyboard, ToScreen: BOOLEAN;
+  Param: CARDINAL;
+  Continue: PROC;
+
+PROCEDURE ErrWrite (ch: CHAR);
+  BEGIN
+    FIO.WriteChar(err^.ref, ch)
+  END ErrWrite;
+
+PROCEDURE ConWrite (ch: CHAR);
+  BEGIN
+    ErrWrite(ch);
+  END ConWrite;
+
+(*PROCEDURE ConRead (VAR ch: CHAR);
+  VAR
+    R: SYSTEM.Registers;
+  BEGIN
+    R.AX := 0; Lib.Intr(R, 16H); ch := CHR(R.AL);
+    IF ch = CR THEN ch := EOL END;
+  END ConRead;*)
+
+PROCEDURE NotRead (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noInput);
+  END NotRead;
+
+PROCEDURE NotWrite (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noOutput);
+  END NotWrite;
+
+PROCEDURE NotFile (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (File(f) = con) OR (File(f) = err)
+      OR (File(f) = StdIn) & FromKeyboard
+      OR (File(f) = StdOut) & ToScreen
+  END NotFile;
+
+(*PROCEDURE CheckRedirection;
+  VAR
+    R: SYSTEM.Registers;
+  BEGIN
+    FromKeyboard := FALSE; ToScreen := FALSE;
+    R.AX := 4400H; R.BX := 0; Lib.Dos(R);
+    IF ~ (0 IN R.Flags) THEN
+      IF {7, 0} <= BITSET(R.DX) THEN FromKeyboard := TRUE END;
+    END;
+    R.AX := 4400H; R.BX := 1; Lib.Dos(R);
+    IF ~ (0 IN R.Flags) THEN
+      IF {7, 1} <= BITSET(R.DX) THEN ToScreen := TRUE END;
+    END;
+  END CheckRedirection;*)
+
+PROCEDURE ASCIIZ (VAR s1, s2: ARRAY OF CHAR);
+(* Convert s2 to a nul terminated string in s1 *)
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE (i <= HIGH(s2)) & (s2[i] # 0C) DO
+      s1[i] := s2[i]; INC(i)
+    END;
+    s1[i] := 0C
+  END ASCIIZ;
+
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+  BEGIN
+    
+  END NextParameter;
+
+PROCEDURE GetEnv (envVar: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+  
+(*
+GetEnvironment - gets the environment variable Env and places
+a copy of its value into string, dest.
+It returns TRUE if the string Env was found in
+the processes environment.
+
+PROCEDURE GetEnvironment (Env: ARRAY OF CHAR;
+VAR dest: ARRAY OF CHAR) : BOOLEAN ;
+*)
+  
+VAR 
+  result : BOOLEAN;
+  
+  BEGIN
+    result := Environment.GetEnvironment(envVar, s);
+  END GetEnv;
+
+PROCEDURE OpenRead (fileName: ARRAY OF CHAR) : FIO.File;
+
+  BEGIN
+   RETURN FIO.OpenToRead(fileName);
+  END OpenRead;
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+ 
+  BEGIN
+    ExtractFileName(fileName, name);
+    FOR i := 0 TO NameLength - 1 DO 
+      name[i] := CAP(name[i]) 
+    END;
+    IF (name[0] = 0C) OR (Compare(name, "CON") = 0) THEN
+      (* con already opened, but reset it *)
+      Okay := TRUE; 
+      f := con;
+      f^.savedCh := 0C; 
+      f^.haveCh := FALSE;
+      f^.eof := FALSE; 
+      f^.eol := FALSE; 
+      f^.name := "CON";
+      RETURN
+    ELSIF Compare(name, "ERR") = 0 THEN
+      Okay := TRUE; 
+      f := err; 
+      RETURN
+    ELSE
+      ALLOCATE(f, SYSTEM.TSIZE(FileRec));
+      NoWrite := FALSE;
+      IF newFile THEN 
+        f^.ref := FIO.OpenToWrite(fileName)
+      ELSE
+        f^.ref := FIO.OpenToRead(fileName);
+        IF FIO.IsNoError(f^.ref)  THEN 
+          f^.ref := OpenToRead(fileName); 
+          NoWrite := TRUE;
+        END;
+      END;
+      Okay := FIO.IsNoError(f^.ref);
+      IF ~ Okay
+        THEN
+          DEALLOCATE(f, SYSTEM.TSIZE(FileRec)); f := NIL
+        ELSE
+      (* textOK below may have to be altered according to implementation *)
+          f^.savedCh := 0C; f^.haveCh := FALSE; f^.textOK := TRUE;
+          f^.eof := newFile; f^.eol := newFile; f^.self := f;
+          f^.noInput := newFile; f^.noOutput := ~ newFile OR NoWrite;
+          ASCIIZ(f^.name, fileName);
+          i := 0 (* find next available filehandle *);
+          WHILE (i IN Handles) & (i < MaxFiles) DO 
+            INC(i) 
+          END;
+          IF i < MaxFiles THEN 
+            f^.handle := i; INCL(Handles, i); Opened[i] := f
+          ELSE 
+            WriteString(err, "Too many files"); 
+            Okay := FALSE
+          END;
+          IF Okay THEN 
+            FIO.AssignBuffer(f^.ref, f^.buffer) 
+          END;
+      END
+    END
+  END Open;
+
+PROCEDURE Close (VAR f: File);
+  BEGIN
+    FIO.Close(f)
+  END Close;
+
+PROCEDURE Delete (VAR f: File);
+  BEGIN
+    Fio.Delete(f);
+  END Delete;
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+
+(*
+Lookup - looks for a file, filename. If the file is found
+then, f, is opened. If it is not found and, newFile,
+is TRUE then a new file is created and attached to, f.
+If, newFile, is FALSE and no file was found then f.res
+is set to notdone.
+
+PROCEDURE Lookup (VAR f: File; filename: ARRAY OF CHAR; newFile: BOOLEAN) ;
+*)
+
+  BEGIN
+   FileSystem.Lookup(f,filename,newFile);
+  END SearchFile;
+
+PROCEDURE ExtractDirectory (fullName: ARRAY OF CHAR;
+                            VAR directory: ARRAY OF CHAR);
+ 
+  BEGIN
+    
+  END ExtractDirectory;
+
+PROCEDURE ExtractFileName (fullName: ARRAY OF CHAR;
+                           VAR fileName: ARRAY OF CHAR);
+  
+  BEGIN
+   
+  END ExtractFileName;
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+ 
+  BEGIN
+   
+  END AppendExtension;
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+ 
+  BEGIN
+   
+  END ChangeExtension;
+
+PROCEDURE Length (f: File): INT32;
+ 
+  BEGIN
+   
+  END Length;
+
+PROCEDURE GetPos (f: File): INT32;
+ 
+  BEGIN
+    
+  END GetPos;
+
+PROCEDURE SetPos (f: File; pos: INT32);
+  BEGIN
+   
+  END SetPos;
+
+PROCEDURE Reset (f: File);
+  BEGIN
+   
+  END Reset;
+
+PROCEDURE Rewrite (f: File);
+ 
+  BEGIN
+   
+  END Rewrite;
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+  BEGIN
+   
+  END EndOfLine;
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+  BEGIN
+  
+  END EndOfFile;
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+  BEGIN
+   
+  END Read;
+
+PROCEDURE ReadAgain (f: File);
+  BEGIN
+   
+  END ReadAgain;
+
+PROCEDURE ReadLn (f: File);
+ 
+  BEGIN
+   
+  END ReadLn;
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+ 
+  BEGIN
+   
+  END ReadString;
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+ 
+  BEGIN
+   
+  END ReadLine;
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+ 
+  BEGIN
+    
+  END ReadToken;
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+ 
+  BEGIN
+   
+  END ReadInt;
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+ 
+  BEGIN
+   
+  END ReadCard;
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+ 
+  BEGIN
+   
+  END ReadBytes;
+
+PROCEDURE Write (f: File; ch: CHAR);
+  BEGIN
+   
+  END Write;
+
+PROCEDURE WriteLn (f: File);
+  BEGIN
+   
+  END WriteLn;
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+  
+  BEGIN
+   
+  END WriteString;
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+ 
+  BEGIN
+   
+  END WriteText;
+
+PROCEDURE WriteInt (f: File; n: INTEGER; wid: CARDINAL);
+ 
+  BEGIN
+   
+  END WriteInt;
+
+PROCEDURE WriteCard (f: File; n, wid: CARDINAL);
+ 
+  BEGIN
+   
+  END WriteCard;
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+ 
+  BEGIN
+  
+  END WriteBytes;
+
+PROCEDURE GetDate (VAR Year, Month, Day: CARDINAL);
+ 
+  BEGIN
+   
+  END GetDate;
+
+PROCEDURE GetTime (VAR Hrs, Mins, Secs, Hsecs: CARDINAL);
+  
+  BEGIN
+  
+  END GetTime;
+
+PROCEDURE Write2 (f: File; i: CARDINAL);
+  BEGIN
+    Write(f, CHR(i DIV 10 + ORD("0")));
+    Write(f, CHR(i MOD 10 + ORD("0")));
+  END Write2;
+
+PROCEDURE WriteDate (f: File);
+  VAR
+    Year, Month, Day: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetDate(Year, Month, Day);
+    Write2(f, Day); Write(f, "/"); Write2(f, Month); Write(f, "/");
+    WriteCard(f, Year, 1)
+  END WriteDate;
+
+PROCEDURE WriteTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    Write2(f, Hrs); Write(f, ":"); Write2(f, Mins); Write(f, ":");
+    Write2(f, Secs)
+  END WriteTime;
+
+VAR
+  Hrs0, Mins0, Secs0, Hsecs0: CARDINAL;
+  Hrs1, Mins1, Secs1, Hsecs1: CARDINAL;
+
+PROCEDURE WriteElapsedTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    WriteString(f, "Elapsed time: ");
+    IF Hrs >= Hrs1
+      THEN s := (Hrs - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+      ELSE s := (Hrs + 24 - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+    END;
+    IF Hsecs >= Hsecs1
+      THEN hs := Hsecs - Hsecs1
+      ELSE hs := (Hsecs + 100) - Hsecs1; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, ".");
+    Write2(f, hs); WriteString(f, " s"); WriteLn(f);
+    Hrs1 := Hrs; Mins1 := Mins; Secs1 := Secs; Hsecs1 := Hsecs;
+  END WriteElapsedTime;
+
+PROCEDURE WriteExecutionTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    WriteString(f, "Execution time: ");
+    IF Hrs >= Hrs0
+      THEN s := (Hrs - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+      ELSE s := (Hrs + 24 - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+    END;
+    IF Hsecs >= Hsecs0
+      THEN hs := Hsecs - Hsecs0
+      ELSE hs := (Hsecs + 100) - Hsecs0; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, "."); Write2(f, hs);
+    WriteString(f, " s"); WriteLn(f);
+  END WriteExecutionTime;
+
+(* The code for the next four procedures below may be commented out if your
+   compiler supports ISO PROCEDURE constant declarations and these declarations
+   are made in the DEFINITION MODULE *)
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+  BEGIN
+    RETURN Str.Length(stringVal)
+  END SLENGTH;
+
+PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+  BEGIN
+  (* Be careful - some libraries have the parameters reversed! *)
+    Str.Copy(destination, source)
+  END Assign;
+
+PROCEDURE Extract (source: ARRAY OF CHAR; startIndex: CARDINAL;
+                   numberToExtract: CARDINAL; VAR destination: ARRAY OF CHAR);
+  BEGIN
+    Str.Slice(destination, source, startIndex, numberToExtract)
+  END Extract;
+
+PROCEDURE Concat (source1, source2: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+  BEGIN
+    Str.Concat(destination, source1, source2);
+  END Concat;
+
+(* The code for the four procedures above may be commented out if your
+   compiler supports ISO PROCEDURE constant declarations and these declarations
+   are made in the DEFINITION MODULE *)
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+  BEGIN
+    RETURN Str.Compare(stringVal1, stringVal2)
+  END Compare;
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+   BEGIN RETURN VAL(CARDINAL, n) END ORDL;
+
+PROCEDURE INTL (n: INT32): INTEGER;
+   BEGIN RETURN VAL(INTEGER, n) END INTL;
+
+PROCEDURE INT (n: CARDINAL): INT32;
+   BEGIN RETURN VAL(INT32, n) END INT;
+
+PROCEDURE CloseAll;
+  VAR
+    handle: CARDINAL;
+  BEGIN
+    FOR handle := 0 TO MaxFiles - 1 DO
+      IF handle IN Handles THEN Close(Opened[handle]) END
+    END;
+    IF ~ ToScreen THEN FIO.Close(StdOut^.ref) END;
+    Continue;
+  END CloseAll;
+
+PROCEDURE QuitExecution;
+  BEGIN
+    HALT
+  END QuitExecution;
+
+BEGIN
+  (*CheckRedirection; (* Not apparently available on many systems *)*)
+  GetTime(Hrs0, Mins0, Secs0, Hsecs0);
+  Hrs1 := Hrs0; 
+  Mins1 := Mins0; 
+  Secs1 := Secs0; 
+  Hsecs1 := Hsecs0;
+  Handles := BITSET{};
+  Okay := FALSE; 
+  EOFChar := 32C;
+  Param := 0;
+  (*FIO.Separators := Str.CHARSET{CHR(0) .. " "}; *)
+  FIO.IOcheck := FALSE;
+
+  ALLOCATE(con, SYSTEM.TSIZE(FileRec)-SYSTEM.TSIZE(Buftype));
+  con^.ref := FIO.StdOut;
+  con^.savedCh := 0C; 
+  con^.haveCh := FALSE; 
+  con^.self := con;
+  con^.noOutput := FALSE; 
+  con^.noInput := FALSE; 
+  con^.textOK := TRUE;
+  con^.eof := FALSE; 
+  con^.eol := FALSE;
+
+  IF FromKeyboard
+    THEN ALLOCATE(StdIn, SYSTEM.TSIZE(FileRec)-SYSTEM.TSIZE(Buftype));
+    ELSE ALLOCATE(StdIn, SYSTEM.TSIZE(FileRec));
+         FIO.AssignBuffer(FIO.StdIn, StdIn^.buffer)
+  END;
+  StdIn^.ref := FIO.StdIn;
+  StdIn^.savedCh := 0C; StdIn^.haveCh := FALSE; StdIn^.self := StdIn;
+  StdIn^.noOutput := TRUE; StdIn^.noInput := FALSE; StdIn^.textOK := TRUE;
+  StdIn^.eof := FALSE; StdIn^.eol := FALSE;
+
+  IF ToScreen
+    THEN ALLOCATE(StdOut, SYSTEM.TSIZE(FileRec)-SYSTEM.TSIZE(Buftype));
+    ELSE ALLOCATE(StdOut, SYSTEM.TSIZE(FileRec));
+         FIO.AssignBuffer(FIO.StdOut, StdOut^.buffer)
+  END;
+  StdOut^.ref := FIO.StdOut;
+  StdOut^.savedCh := 0C; StdOut^.haveCh := FALSE; StdOut^.self := StdOut;
+  StdOut^.noOutput := FALSE; StdOut^.noInput := TRUE; StdOut^.textOK := TRUE;
+  StdOut^.eof := TRUE; StdOut^.eol := TRUE;
+
+  ALLOCATE(err, SYSTEM.TSIZE(FileRec)-SYSTEM.TSIZE(Buftype));
+  err^.ref := FIO.StdErr;
+  err^.savedCh := 0C; err^.haveCh := FALSE; err^.self := err;
+  err^.noOutput := FALSE; err^.noInput := TRUE; err^.textOK := TRUE;
+  err^.eof := TRUE; err^.eol := TRUE;
+
+  Lib.Terminate(CloseAll, Continue);
+END FileIO.

Docs/FileIO-3.mod

@@ -0,0 +1,870 @@
+IMPLEMENTATION MODULE FileIO;
+(* ISO (GPM) version by Pat Terry.  Sat  04-25-98  p.terry@ru.ac.za *)
+
+(* This module attempts to provide several potentially non-portable
+   facilities for Coco/R.
+
+   (a)  A general file input/output module, with all routines required for
+        Coco/R itself, as well as several other that would be useful in
+        Coco-generated applications.
+   (b)  Definition of the "LONGINT" type needed by Coco.
+   (c)  Some conversion functions to handle this long type.
+   (d)  Some "long" and other constant literals that may be problematic
+        on some implementations.
+   (e)  Some string handling primitives needed to interface to a variety
+        of known implementations.
+
+   The intention is that the rest of the code of Coco and its generated
+   parsers should be as portable as possible.  Provided the definition
+   module given, and the associated implementation, satisfy the
+   specification given here, this should be almost 100% possible.
+
+   FileIO is based on code by MB 1990/11/25; heavily modified and extended
+   by PDT and others between 1992/1/6 and the present day. *)
+
+IMPORT SYSTEM, Strings, SysClock, ProgramArgs, TextIO, RawIO, WholeIO,
+       IOChan, IOResult, RndFile, TermFile, StdChans, ChanConsts,Environment, FIO, FileSystem;
+FROM Storage IMPORT ALLOCATE, DEALLOCATE;
+
+CONST
+  MaxFiles = BitSetSize;
+  NameLength = 256;
+
+TYPE
+  File = POINTER TO FileRec;
+  FileRec = RECORD
+              ref: IOChan.ChanId;
+              self: File;
+              handle: CARDINAL;
+              savedCh: CHAR;
+              textOK, eof, eol, noOutput, noInput, haveCh: BOOLEAN;
+              name: ARRAY [0 .. NameLength] OF CHAR;
+            END;
+
+VAR
+  Handles: BITSET;
+  Opened: ARRAY [0 .. MaxFiles-1] OF File;
+  FromKeyboard, ToScreen: BOOLEAN;
+  res: ChanConsts.OpenResults;
+
+PROCEDURE NotRead (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noInput);
+  END NotRead;
+
+PROCEDURE NotWrite (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noOutput);
+  END NotWrite;
+
+PROCEDURE NotFile (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f = con) OR (f = err)
+      OR (f = StdIn) & FromKeyboard
+      OR (f = StdOut) & ToScreen
+  END NotFile;
+
+PROCEDURE CheckRedirection;
+  BEGIN
+    FromKeyboard := TRUE; ToScreen := TRUE; (* ISO fail safe *)
+    (* Ideally we would like
+       FromKeyboard := NOT (StdIn has been redirected )
+       ToScreen := NOT (StdOut has been redirected )
+    *)
+  END CheckRedirection;
+
+PROCEDURE ASCIIZ (VAR s1, s2: ARRAY OF CHAR);
+(* Convert s2 to a nul terminated string in s1 *)
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE (i <= HIGH(s2)) & (s2[i] # 0C) DO
+      s1[i] := s2[i]; INC(i)
+    END;
+    s1[i] := 0C
+  END ASCIIZ;
+
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+  BEGIN
+    IF ProgramArgs.IsArgPresent()
+      THEN
+        TextIO.ReadToken(ProgramArgs.ArgChan(), s);
+        ProgramArgs.NextArg()
+      ELSE s[0] := 0C
+    END
+  END NextParameter;
+
+PROCEDURE GetEnv (envVar: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+
+VAR
+  result : BOOLEAN;
+
+  BEGIN
+    result := Environment.GetEnvironment(envVar, s);
+  END GetEnv;
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+  VAR
+    i: CARDINAL;
+    name: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    ExtractFileName(fileName, name);
+    FOR i := 0 TO NameLength - 1 DO name[i] := CAP(name[i]) END;
+    IF (name[0] = 0C) OR (Compare(name, "CON") = 0) THEN
+      (* con already opened, but reset it *)
+      Okay := TRUE; f := con;
+      f^.savedCh := 0C; f^.haveCh := FALSE;
+      f^.eof := FALSE; f^.eol := FALSE; f^.name := "CON";
+      RETURN
+    ELSIF Compare(name, "ERR") = 0 THEN
+      Okay := TRUE; f := err; RETURN
+    ELSE
+      ALLOCATE(f, SYSTEM.TSIZE(FileRec));
+      (* Flags below may have to be altered according to implementation *)
+      IF newFile
+        THEN RndFile.OpenClean(f^.ref, fileName,
+             RndFile.old (* + RndFile.text *) + RndFile.raw, res)
+        ELSE RndFile.OpenOld(f^.ref, fileName,
+             RndFile.read (* + RnfDile.text *) +RndFile.raw, res)
+      END;
+      Okay := res = RndFile.opened;
+      IF ~ Okay
+        THEN
+          DEALLOCATE(f, SYSTEM.TSIZE(FileRec)); f := NIL
+        ELSE
+      (* textOK below may have to be altered according to implementation *)
+          f^.savedCh := 0C; f^.haveCh := FALSE; f^.textOK := FALSE;
+          f^.eof := newFile; f^.eol := newFile; f^.self := f;
+          f^.noInput := newFile; f^.noOutput := ~ newFile;
+          ASCIIZ(f^.name, fileName);
+          i := 0 (* find next available filehandle *);
+          WHILE (i IN Handles) & (i < MaxFiles) DO INC(i) END;
+          IF i < MaxFiles
+            THEN f^.handle := i; INCL(Handles, i); Opened[i] := f
+            ELSE WriteString(err, "Too many files"); Okay := FALSE
+          END;
+      END
+    END
+  END Open;
+
+PROCEDURE Close (VAR f: File);
+  BEGIN
+    Okay := TRUE;
+    IF NotFile(f) OR (f = StdIn) OR (f = StdOut)
+      THEN Okay := FALSE
+      ELSE
+        EXCL(Handles, f^.handle);
+        RndFile.Close(f^.ref);
+        IF Okay THEN DEALLOCATE(f, SYSTEM.TSIZE(FileRec)) END;
+        f := NIL
+    END;
+(*
+  EXCEPT (* For ISO compilers *)
+    Okay := FALSE; f := NIL; RETURN
+*)
+  END Close;
+
+PROCEDURE Delete (VAR f: File);
+(*
+FileSystem
+
+PROCEDURE Delete (name: ARRAY OF CHAR; VAR f: File) ;
+*)
+  VAR
+    fname : ARRAY [0 .. NameLength] OF CHAR;
+    
+  BEGIN
+    IF NotFile(f) OR (f = StdIn) OR (f = StdOut)
+      THEN Okay := FALSE
+      ELSE
+        Assign(f^.name, fname);
+        Close(f);
+        FileSystem.Delete(fname,f);
+        (*Okay := f^. *)
+    END
+  END Delete;
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+  VAR
+    i, j: INTEGER;
+    k: CARDINAL;
+    c: CHAR;
+    fname: ARRAY [0 .. NameLength] OF CHAR;
+    path: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    FOR k := 0 TO HIGH(envVar) DO envVar[k] := CAP(envVar[k]) END;
+    GetEnv(envVar, path);
+    i := 0;
+    REPEAT
+      j := 0;
+      REPEAT
+        c := path[i]; fname[j] := c; INC(i); INC(j)
+      UNTIL (c = PathSep) OR (c = 0C);
+      IF (j > 1) & (fname[j-2] = DirSep) THEN DEC(j) ELSE fname[j-1] := DirSep END;
+      fname[j] := 0C; Concat(fname, fileName, fname);
+      Open(f, fname, newFile);
+    UNTIL (c = 0C) OR Okay
+  END SearchFile;
+
+PROCEDURE ExtractDirectory (fullName: ARRAY OF CHAR;
+                            VAR directory: ARRAY OF CHAR);
+  VAR
+    i, start: CARDINAL;
+  BEGIN
+    start := 0; i := 0;
+    WHILE (i <= HIGH(fullName)) & (fullName[i] # 0C) DO
+      IF i <= HIGH(directory) THEN
+        directory[i] := fullName[i];
+      END;
+      IF (fullName[i] = ":") OR (fullName[i] = DirSep) THEN start := i + 1 END;
+      INC(i)
+    END;
+    IF start <= HIGH(directory) THEN directory[start] := 0C END
+  END ExtractDirectory;
+
+PROCEDURE ExtractFileName (fullName: ARRAY OF CHAR;
+                           VAR fileName: ARRAY OF CHAR);
+  VAR
+    i, l, start: CARDINAL;
+  BEGIN
+    start := 0; l := 0;
+    WHILE (l <= HIGH(fullName)) & (fullName[l] # 0C) DO
+      IF (fullName[l] = ":") OR (fullName[l] = DirSep) THEN start := l + 1 END;
+      INC(l)
+    END;
+    i := 0;
+    WHILE (start < l) & (i <= HIGH(fileName)) DO
+      fileName[i] := fullName[start]; INC(start); INC(i)
+    END;
+    IF i <= HIGH(fileName) THEN fileName[i] := 0C END
+  END ExtractFileName;
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+  VAR
+    i, j: CARDINAL;
+    fn: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    ExtractDirectory(oldName, newName);
+    ExtractFileName(oldName, fn);
+    i := 0; j := 0;
+    WHILE (i <= NameLength) & (fn[i] # 0C) DO
+      IF fn[i] = "." THEN j := i + 1 END;
+      INC(i)
+    END;
+    IF (j # i) (* then name did not end with "." *) OR (i = 0) THEN
+      IF j # 0 THEN i := j - 1 END;
+      IF (ext[0] # ".") & (ext[0] # 0C) THEN
+        IF i <= NameLength THEN fn[i] := "."; INC(i) END
+      END;
+      j := 0;
+      WHILE (j <= HIGH(ext)) & (ext[j] # 0C) & (i <= NameLength) DO
+        fn[i] := ext[j]; INC(i); INC(j)
+      END
+    END;
+    IF i <= NameLength THEN fn[i] := 0C END;
+    Concat(newName, fn, newName)
+  END AppendExtension;
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+  VAR
+    i, j: CARDINAL;
+    fn: ARRAY [0 .. NameLength] OF CHAR;
+  BEGIN
+    ExtractDirectory(oldName, newName);
+    ExtractFileName(oldName, fn);
+    i := 0; j := 0;
+    WHILE (i <= NameLength) & (fn[i] # 0C) DO
+      IF fn[i] = "." THEN j := i + 1 END;
+      INC(i)
+    END;
+    IF j # 0 THEN i := j - 1 END;
+    IF (ext[0] # ".") & (ext[0] # 0C) THEN
+      IF i <= NameLength THEN fn[i] := "."; INC(i) END
+    END;
+    j := 0;
+    WHILE (j <= HIGH(ext)) & (ext[j] # 0C) & (i <= NameLength) DO
+      fn[i] := ext[j]; INC(i); INC(j)
+    END;
+    IF i <= NameLength THEN fn[i] := 0C END;
+    Concat(newName, fn, newName)
+  END ChangeExtension;
+
+PROCEDURE Length (f: File): INT32;
+(* ++++ implementation specific coercion routine may have to be used ++++ *)
+  VAR
+    pos: RndFile.FilePos;
+  BEGIN
+    IF NotFile(f) THEN
+      Okay := FALSE; 
+      RETURN Long0
+    ELSE
+      Okay := TRUE;
+      FIO.SetPositionFromEnd(f^.ref,0);
+      RETURN VAL(INT32,FIO.FindPosition(f^.ref))
+    END;
+  END Length;
+
+PROCEDURE GetPos (f: File): INT32;
+(* ++++ implementation specific coercion routine may have to be used ++++ *)
+  VAR
+    pos: RndFile.FilePos;
+  BEGIN
+    IF NotFile(f) THEN
+      Okay := FALSE; 
+      RETURN Long0
+    ELSE
+      Okay := TRUE;
+      RETURN VAL(INT32,FIO.FindPosition(f^.ref))
+    END;
+
+  END GetPos;
+
+PROCEDURE SetPos (f: File; pos: INT32);
+(* ++++ implementation specific coercion routine may have to be used ++++ *)
+  BEGIN
+    IF NotFile(f)
+      THEN
+        Okay := FALSE
+      ELSE
+        Okay := TRUE; f^.haveCh := FALSE;
+        FIO.SetPositionFromBeginning(f^.ref,VAL(LONGINT,pos));
+    END;
+  END SetPos;
+
+PROCEDURE Reset (f: File);
+  BEGIN
+    IF NotFile(f)
+      THEN
+        Okay := FALSE
+      ELSE
+        SetPos(f, 0);
+        IF Okay THEN
+          f^.haveCh := FALSE; f^.eof := f^.noInput; f^.eol := f^.noInput
+        END
+    END
+  END Reset;
+
+PROCEDURE Rewrite (f: File);
+  BEGIN
+    IF NotFile(f)
+      THEN
+        Okay := FALSE
+      ELSE
+        RndFile.Close(f^.ref);
+        (* Flags below may have to be altered according to implementation *)
+        RndFile.OpenClean(f^.ref, f^.name,
+                          RndFile.old + (* RndFile.text + *) RndFile.raw, res);
+        Okay := res = RndFile.opened;
+        IF ~ Okay
+          THEN
+            DEALLOCATE(f, SYSTEM.TSIZE(FileRec)); f := NIL
+          ELSE
+            f^.savedCh := 0C; f^.haveCh := FALSE;
+            f^.eof := TRUE; f^.eol := TRUE; 
+            f^.noInput := TRUE; f^.noOutput := FALSE;
+        END
+    END;
+(*
+  EXCEPT (* For ISO compilers *)
+    Okay := FALSE; RETURN
+*)
+  END Rewrite;
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+  BEGIN
+    IF NotRead(f)
+      THEN Okay := FALSE; RETURN TRUE
+      ELSE Okay := TRUE; RETURN f^.eol OR f^.eof
+    END
+  END EndOfLine;
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+  BEGIN
+    IF NotRead(f)
+      THEN Okay := FALSE; RETURN TRUE
+      ELSE Okay := TRUE; RETURN f^.eof
+    END
+  END EndOfFile;
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+  BEGIN
+    IF NotRead(f) THEN Okay := FALSE; ch := 0C; RETURN END;
+    IF f^.haveCh OR f^.eof
+      THEN
+        ch := f^.savedCh; Okay := ch # 0C;
+      ELSE
+        Okay := TRUE;
+        IF ~ f^.textOK (* Work around as best one can *)
+          THEN RawIO.Read(f^.ref, ch)
+          ELSE TextIO.ReadChar(f^.ref, ch);
+        END; 
+        IF f^.textOK & (IOResult.ReadResult(f^.ref) = IOResult.endOfLine)
+          THEN TextIO.SkipLine(f^.ref); ch := EOL
+          ELSIF ch = LF (* Work around possible bug *) THEN ch := EOL
+        END;
+        IF IOResult.ReadResult(f^.ref) = IOResult.endOfInput THEN
+          Okay := FALSE; ch := 0C;
+        END;
+        IF ch = EOFChar THEN Okay := FALSE; ch := 0C END;
+    END;
+    IF ~ Okay THEN ch := 0C END;
+    f^.savedCh := ch; f^.haveCh := ~ Okay;
+    f^.eof := ch = 0C; f^.eol := f^.eof OR (ch = EOL);
+  END Read;
+
+PROCEDURE ReadAgain (f: File);
+  BEGIN
+    IF NotRead(f)
+      THEN Okay := FALSE
+      ELSE f^.haveCh := TRUE
+    END
+  END ReadAgain;
+
+PROCEDURE ReadLn (f: File);
+  VAR
+    ch: CHAR;
+  BEGIN
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    WHILE ~ f^.eol DO Read(f, ch) END;
+    f^.haveCh := FALSE; f^.eol := FALSE;
+  END ReadLn;
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+  VAR
+    j: CARDINAL;
+    ch: CHAR;
+  BEGIN
+    str[0] := 0C; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    REPEAT Read(f, ch) UNTIL (ch # " ") OR ~ Okay;
+    IF Okay THEN
+      WHILE ch >= " " DO
+        IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+        Read(f, ch);
+        WHILE (ch = BS) OR (ch = DEL) DO
+          IF j > 0 THEN DEC(j) END; Read(f, ch)
+        END
+      END;
+      IF j <= HIGH(str) THEN str[j] := 0C END;
+      Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+    END
+  END ReadString;
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+  VAR
+    j: CARDINAL;
+    ch: CHAR;
+  BEGIN
+    str[0] := 0C; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    Read(f, ch);
+    IF Okay THEN
+      WHILE ch >= " " DO
+        IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+        Read(f, ch);
+        WHILE (ch = BS) OR (ch = DEL) DO
+          IF j > 0 THEN DEC(j) END; Read(f, ch)
+        END
+      END;
+      IF j <= HIGH(str) THEN str[j] := 0C END;
+      Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+    END
+  END ReadLine;
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+  VAR
+    j: CARDINAL;
+    ch: CHAR;
+  BEGIN
+    str[0] := 0C; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    REPEAT Read(f, ch) UNTIL (ch > " ") OR ~ Okay;
+    IF Okay THEN
+      WHILE ch > " " DO
+        IF j <= HIGH(str) THEN str[j] := ch END; INC(j);
+        Read(f, ch);
+        WHILE (ch = BS) OR (ch = DEL) DO
+          IF j > 0 THEN DEC(j) END; Read(f, ch)
+        END
+      END;
+      IF j <= HIGH(str) THEN str[j] := 0C END;
+      Okay := j > 0; f^.haveCh := TRUE; f^.savedCh := ch;
+    END
+  END ReadToken;
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+  VAR
+    Digit: INTEGER;
+    j: CARDINAL;
+    Negative: BOOLEAN;
+    s: ARRAY [0 .. 80] OF CHAR;
+  BEGIN
+    i := 0; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    ReadToken(f, s);
+    IF s[0] = "-" (* deal with sign *)
+      THEN Negative := TRUE; INC(j)
+      ELSE Negative := FALSE; IF s[0] = "+" THEN INC(j) END
+    END;
+    IF (s[j] < "0") OR (s[j] > "9") THEN Okay := FALSE END;
+    WHILE (j <= 80) & (s[j] >= "0") & (s[j] <= "9") DO
+      Digit := VAL(INTEGER, ORD(s[j]) - ORD("0"));
+      IF i <= (MAX(INTEGER) - Digit) DIV 10
+        THEN i := 10 * i + Digit
+        ELSE Okay := FALSE
+      END;
+      INC(j)
+    END;
+    IF Negative THEN i := -i END;
+    IF (j > 80) OR (s[j] # 0C) THEN Okay := FALSE END;
+    IF ~ Okay THEN i := 0 END;
+  END ReadInt;
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+  VAR
+    Digit: CARDINAL;
+    j: CARDINAL;
+    s: ARRAY [0 .. 80] OF CHAR;
+  BEGIN
+    i := 0; j := 0;
+    IF NotRead(f) THEN Okay := FALSE; RETURN END;
+    ReadToken(f, s);
+    WHILE (j <= 80) & (s[j] >= "0") & (s[j] <= "9") DO
+      Digit := ORD(s[j]) - ORD("0");
+      IF i <= (MAX(CARDINAL) - Digit) DIV 10
+        THEN i := 10 * i + Digit
+        ELSE Okay := FALSE
+      END;
+      INC(j)
+    END;
+    IF (j > 80) OR (s[j] # 0C) THEN Okay := FALSE END;
+    IF ~ Okay THEN i := 0 END;
+  END ReadCard;
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+  VAR
+    TooMany: BOOLEAN;
+    Wanted: CARDINAL;
+  BEGIN
+    IF NotRead(f) OR (f = con)
+      THEN Okay := FALSE; len := 0;
+      ELSE
+        IF len = 0 THEN Okay := TRUE; RETURN END;
+        TooMany := len - 1 > HIGH(buf);
+        IF TooMany THEN Wanted := HIGH(buf) + 1 ELSE Wanted := len END;
+        IOChan.RawRead(f^.ref, SYSTEM.ADR(buf), Wanted, Wanted);
+        Okay := Wanted # 0;
+        IF len # Wanted THEN Okay := FALSE END;
+        len := Wanted;
+    END;
+    IF ~ Okay THEN f^.eof := TRUE END;
+    IF TooMany THEN Okay := FALSE END;
+(*
+  EXCEPT (* For ISO compilers *)
+    Okay := FALSE; len := 0; RETURN
+*)
+  END ReadBytes;
+
+PROCEDURE Write (f: File; ch: CHAR);
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    Okay := TRUE;
+    IF ch = EOL
+      THEN (* implementation may not support Text operations on all files *)
+        IF f^.textOK 
+          THEN TextIO.WriteLn(f^.ref)
+          ELSE ch := LF; RawIO.Write(f^.ref, ch)
+              (* but you may have to write CR/LF or CR or LF *)
+        END
+      ELSE 
+        IF f^.textOK
+          THEN TextIO.WriteChar(f^.ref, ch)
+          ELSE RawIO.Write(f^.ref, ch)
+        END
+    END;
+(*
+  EXCEPT (* For ISO compilers *)
+    Okay := FALSE; RETURN
+*)
+  END Write;
+
+PROCEDURE WriteLn (f: File);
+  BEGIN
+    IF NotWrite(f)
+      THEN Okay := FALSE;
+      ELSE Write(f, EOL)
+    END
+  END WriteLn;
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+  VAR
+    pos: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    pos := 0;
+    WHILE (pos <= HIGH(str)) & (str[pos] # 0C) DO
+      Write(f, str[pos]); INC(pos)
+    END
+  END WriteString;
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+  VAR
+    i, slen: INTEGER;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    slen := LENGTH(text);
+    FOR i := 0 TO len - 1 DO
+      IF i < slen THEN Write(f, text[i]) ELSE Write(f, " ") END;
+    END
+  END WriteText;
+
+PROCEDURE WriteInt (f: File; n: INTEGER; wid: CARDINAL);
+  VAR
+    l, d: CARDINAL;
+    x: INTEGER;
+    t: ARRAY [1 .. 25] OF CHAR;
+    sign: CHAR;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    IF n < 0
+      THEN sign := "-"; x := - n;
+      ELSE sign := " "; x := n;
+    END;
+    l := 0;
+    REPEAT
+      d := x MOD 10; x := x DIV 10;
+      INC(l); t[l] := CHR(ORD("0") + d);
+    UNTIL x = 0;
+    IF wid = 0 THEN Write(f, " ") END;
+    WHILE wid > l + 1 DO Write(f, " "); DEC(wid); END;
+    IF (sign = "-") OR (wid > l) THEN Write(f, sign); END;
+    WHILE l > 0 DO Write(f, t[l]); DEC(l); END;
+  END WriteInt;
+
+PROCEDURE WriteCard (f: File; n, wid: CARDINAL);
+  VAR
+    l, d: CARDINAL;
+    t: ARRAY [1 .. 25] OF CHAR;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    l := 0;
+    REPEAT
+      d := n MOD 10; n := n DIV 10;
+      INC(l); t[l] := CHR(ORD("0") + d);
+    UNTIL n = 0;
+    IF wid = 0 THEN Write(f, " ") END;
+    WHILE wid > l DO Write(f, " "); DEC(wid); END;
+    WHILE l > 0 DO Write(f, t[l]); DEC(l); END;
+  END WriteCard;
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+  VAR
+    TooMany: BOOLEAN;
+  BEGIN
+    TooMany := (len > 0) & (len - 1 > HIGH(buf));
+    IF NotWrite(f) OR (f = con) OR (f = err)
+      THEN
+        Okay := FALSE
+      ELSE
+        Okay := TRUE;
+        IF TooMany THEN len := HIGH(buf) + 1 END;
+        IOChan.RawWrite(f^.ref, SYSTEM.ADR(buf), len);
+    END;
+    IF TooMany THEN Okay := FALSE END;
+(*
+  EXCEPT (* For ISO compilers *)
+    Okay := FALSE; RETURN
+*)
+  END WriteBytes;
+
+PROCEDURE GetDate (VAR Year, Month, Day: CARDINAL);
+  VAR
+    time: SysClock.DateTime;
+  BEGIN
+    SysClock.GetClock(time);
+    Year := time.year;
+    Month := time.month;
+    Day := time.day;
+  END GetDate;
+
+PROCEDURE GetTime (VAR Hrs, Mins, Secs, Hsecs: CARDINAL);
+  VAR
+    time: SysClock.DateTime;
+  BEGIN
+    SysClock.GetClock(time);
+    Hrs := time.hour;
+    Mins := time.minute;
+    Secs := time.second;
+    Hsecs := time.fractions;
+  END GetTime;
+
+PROCEDURE Write2 (f: File; i: CARDINAL);
+  BEGIN
+    Write(f, CHR(i DIV 10 + ORD("0")));
+    Write(f, CHR(i MOD 10 + ORD("0")));
+  END Write2;
+
+PROCEDURE WriteDate (f: File);
+  VAR
+    Year, Month, Day: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetDate(Year, Month, Day);
+    Write2(f, Day); Write(f, "/"); Write2(f, Month); Write(f, "/");
+    WriteCard(f, Year, 1)
+  END WriteDate;
+
+PROCEDURE WriteTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    Write2(f, Hrs); Write(f, ":"); Write2(f, Mins); Write(f, ":");
+    Write2(f, Secs)
+  END WriteTime;
+
+VAR
+  Hrs0, Mins0, Secs0, Hsecs0: CARDINAL;
+  Hrs1, Mins1, Secs1, Hsecs1: CARDINAL;
+
+PROCEDURE WriteElapsedTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    WriteString(f, "Elapsed time: ");
+    IF Hrs >= Hrs1
+      THEN s := (Hrs - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+      ELSE s := (Hrs + 24 - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+    END;
+    IF Hsecs >= Hsecs1
+      THEN hs := Hsecs - Hsecs1
+      ELSE hs := (Hsecs + 100) - Hsecs1; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, ".");
+    Write2(f, hs); WriteString(f, " s"); WriteLn(f);
+    Hrs1 := Hrs; Mins1 := Mins; Secs1 := Secs; Hsecs1 := Hsecs;
+  END WriteElapsedTime;
+
+PROCEDURE WriteExecutionTime (f: File);
+  VAR
+    Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+  BEGIN
+    IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    GetTime(Hrs, Mins, Secs, Hsecs);
+    WriteString(f, "Execution time: ");
+    IF Hrs >= Hrs0
+      THEN s := (Hrs - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+      ELSE s := (Hrs + 24 - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+    END;
+    IF Hsecs >= Hsecs0
+      THEN hs := Hsecs - Hsecs0
+      ELSE hs := (Hsecs + 100) - Hsecs0; DEC(s);
+    END;
+    WriteCard(f, s, 1); Write(f, "."); Write2(f, hs);
+    WriteString(f, " s"); WriteLn(f);
+  END WriteExecutionTime;
+
+(* The code for the next four procedures below may be commented out if your
+   compiler supports ISO PROCEDURE constant declarations and these declarations
+   are made in the DEFINITION MODULE *)
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+  BEGIN
+    RETURN LENGTH(stringVal)
+  END SLENGTH;
+
+PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+  BEGIN
+  (* Be careful - some libraries have the parameters reversed! *)
+    Strings.Assign(source, destination)
+  END Assign;
+
+PROCEDURE Extract (source: ARRAY OF CHAR; startIndex: CARDINAL;
+                   numberToExtract: CARDINAL; VAR destination: ARRAY OF CHAR);
+  BEGIN
+    Strings.Extract(source, startIndex, numberToExtract, destination)
+  END Extract;
+
+PROCEDURE Concat (source1, source2: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+  BEGIN
+    Strings.Concat(source1, source2, destination);
+  END Concat;
+
+(* The code for the four procedures above may be commented out if your
+   compiler supports ISO PROCEDURE constant declarations and these declarations
+   are made in the DEFINITION MODULE *)
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+  BEGIN
+    RETURN VAL(INTEGER, Strings.Compare(stringVal1, stringVal2)) - 1;
+  END Compare;
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+   BEGIN RETURN VAL(CARDINAL, n) END ORDL;
+
+PROCEDURE INTL (n: INT32): INTEGER;
+   BEGIN RETURN VAL(INTEGER, n) END INTL;
+
+PROCEDURE INT (n: CARDINAL): INT32;
+   BEGIN RETURN VAL(INT32, n) END INT;
+
+PROCEDURE CloseAll;
+  VAR
+    handle: CARDINAL;
+  BEGIN
+    FOR handle := 0 TO MaxFiles - 1 DO
+      IF handle IN Handles THEN Close(Opened[handle]) END
+    END;
+  END CloseAll;
+
+PROCEDURE QuitExecution;
+  BEGIN
+    HALT
+  END QuitExecution;
+
+BEGIN
+  CheckRedirection; (* Not apparently available on many systems *)
+  ProgramArgs.NextArg(); (* Not necessary on some systems *)
+  GetTime(Hrs0, Mins0, Secs0, Hsecs0);
+  Hrs1 := Hrs0; Mins1 := Mins0; Secs1 := Secs0; Hsecs1 := Hsecs0;
+  Handles := BITSET{};
+  Okay := FALSE; EOFChar := 04C;
+
+  ALLOCATE(con, SYSTEM.TSIZE(FileRec));
+  TermFile.Open(con^.ref, TermFile.read + TermFile.write + TermFile.text
+                + TermFile.echo, res);
+  con^.savedCh := 0C; con^.haveCh := FALSE; con^.self := con;
+  con^.noOutput := FALSE; con^.noInput := FALSE; con^.textOK := TRUE;
+  con^.eof := FALSE; con^.eol := FALSE;
+
+  ALLOCATE(StdIn, SYSTEM.TSIZE(FileRec));
+  StdIn^.ref := StdChans.StdInChan();
+  StdIn^.savedCh := 0C; StdIn^.haveCh := FALSE; StdIn^.self := StdIn;
+  StdIn^.noOutput := TRUE; StdIn^.noInput := FALSE; StdIn^.textOK := TRUE;
+  StdIn^.eof := FALSE; StdIn^.eol := FALSE;
+
+  ALLOCATE(StdOut, SYSTEM.TSIZE(FileRec));
+  StdOut^.ref := StdChans.StdOutChan();
+  StdOut^.savedCh := 0C; StdOut^.haveCh := FALSE; StdOut^.self := StdOut;
+  StdOut^.noOutput := FALSE; StdOut^.noInput := TRUE; StdOut^.textOK := TRUE;
+  StdOut^.eof := TRUE; StdOut^.eol := TRUE;
+
+  ALLOCATE(err, SYSTEM.TSIZE(FileRec));
+  err^.ref := StdChans.StdErrChan();
+  err^.savedCh := 0C; err^.haveCh := FALSE; err^.self := err;
+  err^.noOutput := FALSE; err^.noInput := TRUE; err^.textOK := TRUE;
+  err^.eof := TRUE; err^.eol := TRUE;
+
+(* 
+  FINALLY (* For ISO compilers *)
+  (* Preferably find some way to install CloseAll as an at-exit procedure *)
+  CloseAll;
+*)
+END FileIO.

Docs/xrFName.def

@@ -0,0 +1,33 @@
+DEFINITION MODULE xrFName; (* paul 27-Jan-00 *)
+
+(* File name extracting procedures for use in RT lib.
+   File name consists of three parts:
+        - path
+        - name
+        - extensions.
+*)
+
+TYPE
+  Format = RECORD
+    ok: BOOLEAN;               (* result *)
+    dirPos, dirLen : CARDINAL; (* directory position and length *)
+    namePos,nameLen: CARDINAL; (* name position and length *)
+    extPos, extLen : CARDINAL; (* extension position and length *)
+  END;
+
+(*----------------------------------------------------------------*)
+
+PROCEDURE X2C_ParseFileName(str: ARRAY OF CHAR; VAR f: Format);
+(* Returns the format of the string.
+   The values of *Pos, *Len fields are undefined
+   if f.ok=FALSE. *)
+
+PROCEDURE X2C_ExtractPath (fname: ARRAY OF CHAR; VAR path: ARRAY OF CHAR);
+PROCEDURE X2C_ExtractBaseName(fname: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
+PROCEDURE X2C_ExtractFileExt (fname: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
+
+PROCEDURE X2C_SplitFileName (fname: ARRAY OF CHAR;
+                         VAR path,name,ext: ARRAY OF CHAR);
+
+
+END xrFName.

Docs/xrFName.mod

@@ -0,0 +1,115 @@
+(* Copyright (c) 2000 Excelsior, Russia. All Rights Reserved. *)
+<*+ M2EXTENSIONS *>
+IMPLEMENTATION MODULE xrFName; (* paul 27-Jan-00 *)
+
+IMPORT  env:=platform;
+
+
+(* similar to M2 ISO Strings.Extract *)
+PROCEDURE Extract(s: ARRAY OF CHAR; p,len: CARDINAL; VAR d: ARRAY OF CHAR);
+  VAR i: CARDINAL;
+BEGIN
+  i:=0;
+  WHILE (len>0) & (i<=HIGH(d)) & (p<=HIGH(s)) & (s[p]#0C) DO
+    d[i]:=s[p]; DEC(len); INC(i); INC(p)
+  END;
+  IF i<=HIGH(d) THEN d[i]:=0C END;
+END Extract;
+
+(*----------------------------------------------------------------*)
+
+PROCEDURE X2C_ParseFileName(s-: ARRAY OF CHAR; VAR f: Format);
+  VAR len,i: CARDINAL;
+      checkDrvSep: BOOLEAN;
+BEGIN
+  f.ok:=FALSE;
+  f.dirPos:=0;  f.dirLen:=0;
+  f.namePos:=0; f.nameLen:=0;
+  f.extPos:=0;  f.extLen:=0;
+  len:=LENGTH(s);
+  IF len = 0 THEN RETURN END;
+  i:=len;
+  checkDrvSep := env.pl_msdos OR env.pl_vms OR env.pl_amiga;
+
+  REPEAT DEC(i)
+  UNTIL (i=0) OR (s[i]=env.extSep) OR (s[i]=env.pathEnd)
+              OR checkDrvSep & (s[i]=env.drvSep);
+
+  IF s[i]=env.extSep THEN
+    f.extPos:=i+1;
+    f.extLen:=len-i-1;
+    len:=i;
+  END;
+
+  WHILE (i>0) & (s[i]#env.pathEnd) & NOT( checkDrvSep & (s[i]=env.drvSep) )
+  DO DEC(i) END;
+
+  IF s[i]=env.pathEnd THEN
+    f.namePos:=i+1;
+    f.nameLen:=len-i-1;
+    f.dirLen:=i;
+    IF i=0 THEN
+      f.dirLen:=1;
+    ELSIF env.pl_vms OR env.pl_msdos & (i=2) & (s[1]=env.drvSep) THEN
+      INC(f.dirLen)
+    END;
+  ELSIF checkDrvSep & (s[i]=env.drvSep) THEN
+    IF env.pl_msdos & (i#1) THEN RETURN END;
+    f.namePos:=i+1;
+    f.nameLen:=len-i-1;
+    f.dirLen:=i+1;
+  ELSE
+    f.nameLen:=len;
+  END;
+
+  f.ok:=(f.nameLen + f.extLen > 0);
+END X2C_ParseFileName;
+
+PROCEDURE X2C_SplitFileName (fname: ARRAY OF CHAR;
+                 VAR path,name,ext: ARRAY OF CHAR);
+  VAR f: Format;
+BEGIN
+  X2C_ParseFileName(fname, f);
+  IF f.ok THEN
+    Extract(fname, f.dirPos, f.dirLen, path);
+    Extract(fname, f.namePos, f.nameLen, name);
+    Extract(fname, f.extPos, f.extLen, ext);
+  ELSE
+    path[0]:=0C; name[0]:=0C; ext[0]:=0C;
+  END;
+END X2C_SplitFileName;
+
+PROCEDURE X2C_ExtractPath(fname: ARRAY OF CHAR; VAR path: ARRAY OF CHAR);
+  VAR f: Format;
+BEGIN
+  X2C_ParseFileName(fname, f);
+  IF f.ok THEN
+    Extract(fname, f.dirPos, f.dirLen, path);
+  ELSE
+    path[0]:=0C;
+  END;
+END X2C_ExtractPath;
+
+PROCEDURE X2C_ExtractBaseName(fname: ARRAY OF CHAR; VAR n: ARRAY OF CHAR);
+  VAR f: Format;
+BEGIN
+  X2C_ParseFileName(fname, f);
+  IF f.ok THEN
+    Extract(fname, f.namePos, f.nameLen, n);
+  ELSE
+    n[0]:=0C;
+  END;
+END X2C_ExtractBaseName;
+
+PROCEDURE X2C_ExtractFileExt(fname: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
+  VAR f: Format;
+BEGIN
+  X2C_ParseFileName(fname, f);
+  IF f.ok THEN
+    Extract(fname, f.extPos, f.extLen, ext);
+  ELSE
+    ext[0]:=0C;
+  END;
+END X2C_ExtractFileExt;
+
+END xrFName.

FIO.def

@@ -0,0 +1,373 @@
+(* FIO.def provides a simple buffered file input/output library.
+
+Copyright (C) 2001-2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  *)
+
+DEFINITION MODULE FIO ;
+
+(* Provides a simple buffered file input/output library.  *)
+
+
+FROM SYSTEM IMPORT ADDRESS, BYTE ;
+
+EXPORT QUALIFIED (* types *)
+                 File,
+                 (* procedures *)
+                 OpenToRead, OpenToWrite, OpenForRandom, Close, Unlink, Delete,
+                 EOF, EOLN, WasEOLN, IsNoError, Exists, IsActive,
+                 exists, openToRead, openToWrite, openForRandom,
+                 SetPositionFromBeginning,
+                 SetPositionFromEnd,
+                 FindPosition,
+                 ReadChar, ReadString,
+                 WriteChar, WriteString, WriteLine,
+                 WriteCardinal, ReadCardinal,
+                 UnReadChar,
+                 WriteNBytes, ReadNBytes,
+                 FlushBuffer,
+                 GetUnixFileDescriptor,
+                 GetFileName, getFileName, getFileNameLength,GetFDesc,
+                 FlushOutErr,
+                 (* variables *)
+                 StdIn, StdOut, StdErr ;
+
+TYPE
+   File = CARDINAL ;
+
+(* the following variables are initialized to their UNIX equivalents *)
+VAR
+   StdIn, StdOut, StdErr: File ;
+
+
+
+(*
+   IsNoError - returns a TRUE if no error has occured on file, f.
+*)
+
+PROCEDURE IsNoError (f: File) : BOOLEAN ;
+
+
+(*
+   IsActive - returns TRUE if the file, f, is still active.
+*)
+
+PROCEDURE IsActive (f: File) : BOOLEAN ;
+
+
+(*
+   Exists - returns TRUE if a file named, fname exists for reading.
+*)
+
+PROCEDURE Exists (fname: ARRAY OF CHAR) : BOOLEAN ;
+
+
+(*
+   OpenToRead - attempts to open a file, fname, for reading and
+                it returns this file.
+                The success of this operation can be checked by
+                calling IsNoError.
+*)
+
+PROCEDURE OpenToRead (fname: ARRAY OF CHAR) : File ;
+
+
+(*
+   OpenToWrite - attempts to open a file, fname, for write and
+                 it returns this file.
+                 The success of this operation can be checked by
+                 calling IsNoError.
+*)
+
+PROCEDURE OpenToWrite (fname: ARRAY OF CHAR) : File ;
+
+
+(*
+   OpenForRandom - attempts to open a file, fname, for random access
+                   read or write and it returns this file.
+                   The success of this operation can be checked by
+                   calling IsNoError.
+                   towrite, determines whether the file should be
+                   opened for writing or reading.
+                   newfile, determines whether a file should be
+                   created if towrite is TRUE or whether the
+                   previous file should be left alone,
+                   allowing this descriptor to seek
+                   and modify an existing file.
+*)
+
+PROCEDURE OpenForRandom (fname: ARRAY OF CHAR;
+                         towrite, newfile: BOOLEAN) : File ;
+
+(*
+   Unlink - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Unlink ( f : File );
+
+
+(*
+   Delete - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Delete (fname: ARRAY OF CHAR ) ;
+
+(*
+   Close - close a file which has been previously opened using:
+           OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Close (f: File) ;
+
+
+
+(*************************************************************************)
+
+(* the following functions are functionally equivalent to the above
+   except they allow C style names.
+*)
+
+PROCEDURE exists        (fname: ADDRESS; flength: CARDINAL) : BOOLEAN ;
+PROCEDURE openToRead    (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openToWrite   (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openForRandom (fname: ADDRESS; flength: CARDINAL;
+                         towrite, newfile: BOOLEAN) : File ;
+
+(*************************************************************************)
+
+(*
+   FlushBuffer - flush contents of the FIO file, f, to libc.
+*)
+
+PROCEDURE FlushBuffer (f: File) ;
+
+
+(*
+   ReadNBytes - reads nBytes of a file into memory area, dest, returning
+                the number of bytes actually read.
+                This function will consume from the buffer and then
+                perform direct libc reads. It is ideal for large reads.
+*)
+
+PROCEDURE ReadNBytes (f: File; nBytes: CARDINAL;
+                      dest: ADDRESS) : CARDINAL ;
+
+
+(*
+   ReadAny - reads HIGH (a) + 1 bytes into, a.  All input
+             is fully buffered, unlike ReadNBytes and thus is more
+             suited to small reads.
+*)
+
+PROCEDURE ReadAny (f: File; VAR a: ARRAY OF BYTE) ;
+
+
+(*
+   WriteNBytes - writes nBytes from memory area src to a file
+                 returning the number of bytes actually written.
+                 This function will flush the buffer and then
+                 write the nBytes using a direct write from libc.
+                 It is ideal for large writes.
+*)
+
+PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL;
+                       src: ADDRESS) : CARDINAL ;
+
+
+(*
+   WriteAny - writes HIGH (a) + 1 bytes onto, file, f.  All output
+              is fully buffered, unlike WriteNBytes and thus is more
+              suited to small writes.
+*)
+
+PROCEDURE WriteAny (f: File; VAR a: ARRAY OF BYTE) ;
+
+
+(*
+   WriteChar - writes a single character to file, f.
+*)
+
+PROCEDURE WriteChar (f: File; ch: CHAR) ;
+
+
+(*
+   EOF - tests to see whether a file, f, has reached end of file.
+*)
+
+PROCEDURE EOF (f: File) : BOOLEAN ;
+
+
+(*
+   EOLN - tests to see whether a file, f, is about to read a newline.
+          It does NOT consume the newline.  It reads the next character
+          and then immediately unreads the character.
+*)
+
+PROCEDURE EOLN (f: File) : BOOLEAN ;
+
+
+(*
+   WasEOLN - tests to see whether a file, f, has just read a newline
+             character.
+*)
+
+PROCEDURE WasEOLN (f: File) : BOOLEAN ;
+
+
+(*
+   ReadChar - returns a character read from file, f.
+              Sensible to check with IsNoError or EOF after calling
+              this function.
+*)
+
+PROCEDURE ReadChar (f: File) : CHAR ;
+
+
+(*
+   UnReadChar - replaces a character, ch, back into file, f.
+                This character must have been read by ReadChar
+                and it does not allow successive calls.  It may
+                only be called if the previous read was successful,
+                end of file or end of line seen.
+*)
+
+PROCEDURE UnReadChar (f: File ; ch: CHAR) ;
+
+
+(*
+   WriteLine - writes out a linefeed to file, f.
+*)
+
+PROCEDURE WriteLine (f: File) ;
+
+
+(*
+   WriteString - writes a string to file, f.
+*)
+
+PROCEDURE WriteString (f: File; a: ARRAY OF CHAR) ;
+
+
+(*
+   ReadString - reads a string from file, f, into string, a.
+                It terminates the string if HIGH is reached or
+                if a newline is seen or an error occurs.
+*)
+
+PROCEDURE ReadString (f: File; VAR a: ARRAY OF CHAR) ;
+
+
+(*
+   WriteCardinal - writes a CARDINAL to file, f.
+                   It writes the binary image of the CARDINAL.
+                   to file, f.
+*)
+
+PROCEDURE WriteCardinal (f: File; c: CARDINAL) ;
+
+
+(*
+   ReadCardinal - reads a CARDINAL from file, f.
+                  It reads a bit image of a CARDINAL
+                  from file, f.
+*)
+
+PROCEDURE ReadCardinal (f: File) : CARDINAL ;
+
+
+(*
+   GetUnixFileDescriptor - returns the UNIX file descriptor of a file.
+                           Useful when combining FIO.mod with select
+                           (in Selective.def - but note the comments in
+                            Selective about using read/write primatives)
+*)
+
+PROCEDURE GetUnixFileDescriptor (f: File) : INTEGER ;
+
+
+(*
+   SetPositionFromBeginning - sets the position from the beginning
+                              of the file.
+*)
+
+PROCEDURE SetPositionFromBeginning (f: File; pos: LONGINT) ;
+
+
+(*
+   SetPositionFromEnd - sets the position from the end of the file.
+*)
+
+PROCEDURE SetPositionFromEnd (f: File; pos: LONGINT) ;
+
+
+(*
+   FindPosition - returns the current absolute position in file, f.
+*)
+
+PROCEDURE FindPosition (f: File) : LONGINT ;
+
+(*
+   GetFDesc - return the file descriptor associated with File name,  fname
+*)
+
+
+PROCEDURE GetFDesc (fname : ARRAY OF CHAR ) : File;
+
+(*
+   GetFileName - assigns, a, with the filename associated with, f.
+*)
+
+PROCEDURE GetFileName (f: File; VAR a: ARRAY OF CHAR) ;
+
+
+(**********************************************************************)
+
+(* here ADDRESS is a PONITER TO CHAR like in the C lib *)
+(*
+   getFileName - returns the address of the filename associated with, f.
+*)
+
+PROCEDURE getFileName (f: File) : ADDRESS ;
+
+
+(*
+   getFileNameLength - returns the number of characters associated with
+                       filename, f.
+*)
+
+PROCEDURE getFileNameLength (f: File) : CARDINAL ;
+
+(**********************************************************************)
+
+(*
+   FlushOutErr - flushes, StdOut, and, StdErr.
+*)
+
+PROCEDURE FlushOutErr ;
+
+
+END FIO.

FIO.mod

@@ -0,0 +1,1761 @@
+(* FIO.mod provides a simple buffered file input/output library.
+
+Copyright (C) 2001-2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  *)
+
+IMPLEMENTATION MODULE FIO ;
+
+(*
+    Title      : FIO
+    Author     : Gaius Mulley
+    System     : UNIX (gm2)
+    Date       : Thu Sep  2 22:07:21 1999
+    Last edit  : Thu Sep  2 22:07:21 1999
+    Description: a complete reimplememtation of FIO.mod
+                 provides a simple buffered file input/output library.
+*)
+
+IMPORT Strings;
+FROM SYSTEM IMPORT ADR, TSIZE, WORD, COFF_T ;
+FROM ASCII IMPORT nl, nul, tab ;
+FROM StrLib IMPORT StrLen, StrConCat, StrCopy ;
+FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
+FROM NumberIO IMPORT CardToStr ;
+FROM Indexing IMPORT Index, InitIndex, InBounds, HighIndice, LowIndice, PutIndice, GetIndice ;
+FROM M2RTS IMPORT InstallTerminationProcedure ;
+FROM libc IMPORT exit, open, creat, read, write, close, lseek, strncpy, memcpy, unlink ;
+FROM wrapc IMPORT SeekSet, SeekEnd, ReadOnly, WriteOnly ;
+
+
+CONST
+   MaxBufferLength     = 1024*16 ;
+   MaxErrorString      = 1024* 8 ;
+   CreatePermissions   =     666B;
+
+TYPE
+   FileUsage         = (unused, openedforread, openedforwrite, openedforrandom) ;
+   FileStatus        = (successful, outofmemory, toomanyfilesopen, failed, connectionfailure, endofline, endoffile) ;
+
+   NameInfo          = RECORD
+                          address: ADDRESS ;
+                          size   : CARDINAL ;
+                       END ;
+
+   Buffer            = POINTER TO buf ;
+   buf               =            RECORD
+                                     valid   : BOOLEAN ;   (* are the field valid?             *)
+                                     bufstart: LONGINT ;   (* the position of buffer in file   *)
+                                     position: CARDINAL ;  (* where are we through this buffer *)
+                                     address : ADDRESS ;   (* dynamic buffer address           *)
+                                     filled  : CARDINAL ;  (* length of the buffer filled      *)
+                                     size    : CARDINAL ;  (* maximum space in this buffer     *)
+                                     left    : CARDINAL ;  (* number of bytes left to read     *)
+                                     contents: POINTER TO ARRAY [0..MaxBufferLength] OF CHAR ;
+                                  END ;
+
+   FileDescriptor   = POINTER TO fds ;
+   fds               =            RECORD
+                                     unixfd: INTEGER ;
+                                     name  : NameInfo ;
+                                     state : FileStatus ;
+                                     usage : FileUsage ;
+                                     output: BOOLEAN ;     (* is this file going to write data *)
+                                     buffer: Buffer ;
+                                     abspos: LONGINT ;     (* absolute position into file.     *)
+                                  END ;                    (* reflects low level reads which   *)
+                                                           (* means this value will normally   *)
+                                                           (* be further through the file than *)
+                                                           (* bufstart above.                  *)
+   PtrToChar         = POINTER TO CHAR ;
+
+
+VAR
+   FileInfo: Index ;
+   Error   : File ;   (* not stderr, this is an unused file handle
+                         which only serves to hold status values
+                         when we cannot create a new file handle *)
+
+
+(*
+   GetUnixFileDescriptor - returns the UNIX file descriptor of a file.
+*)
+
+PROCEDURE GetUnixFileDescriptor (f: File) : INTEGER ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         RETURN( fd^.unixfd )
+      END
+   END ;
+   FormatError1('file %d has not been opened or is out of range\n', f) ;
+   RETURN( -1 )
+END GetUnixFileDescriptor ;
+
+
+(*
+   WriteString - writes a string to file, f.
+*)
+
+PROCEDURE WriteString (f: File; a: ARRAY OF CHAR) ;
+VAR
+   l: CARDINAL ;
+BEGIN
+   l := StrLen(a) ;
+   IF WriteNBytes(f, l, ADR(a))#l
+   THEN
+   END
+END WriteString ;
+
+
+(*
+   Max - returns the maximum of two values.
+*)
+
+PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
+BEGIN
+   IF a>b
+   THEN
+      RETURN( a )
+   ELSE
+      RETURN( b )
+   END
+END Max ;
+
+
+(*
+   Min - returns the minimum of two values.
+*)
+
+PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
+BEGIN
+   IF a<b
+   THEN
+      RETURN( a )
+   ELSE
+      RETURN( b )
+   END
+END Min ;
+
+
+(*
+   GetNextFreeDescriptor - returns the index to the FileInfo array indicating
+                           the next free slot.
+*)
+
+PROCEDURE GetNextFreeDescriptor () : File ;
+VAR
+   f, h: File ;
+   fd  : FileDescriptor ;
+BEGIN
+   f := Error+1 ;
+   h := HighIndice(FileInfo) ;
+   LOOP
+      IF f<=h
+      THEN
+         fd := GetIndice(FileInfo, f) ;
+         IF fd=NIL
+         THEN
+            RETURN( f )
+         END
+      END ;
+      INC(f) ;
+      IF f>h
+      THEN
+         PutIndice(FileInfo, f, NIL) ;  (* create new slot *)
+         RETURN( f )
+      END
+   END
+END GetNextFreeDescriptor ;
+
+
+(*
+   IsNoError - returns a TRUE if no error has occured on file, f.
+*)
+
+PROCEDURE IsNoError (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f=Error
+   THEN
+      RETURN( FALSE )
+   ELSE
+      fd := GetIndice(FileInfo, f) ;
+      RETURN( (fd#NIL) AND ((fd^.state=successful) OR (fd^.state=endoffile) OR (fd^.state=endofline)) )
+   END
+END IsNoError ;
+
+
+(*
+   IsActive - returns TRUE if the file, f, is still active.
+*)
+
+PROCEDURE IsActive (f: File) : BOOLEAN ;
+BEGIN
+   IF f=Error
+   THEN
+      RETURN( FALSE )
+   ELSE
+      RETURN( GetIndice(FileInfo, f)#NIL )
+   END
+END IsActive ;
+
+
+(*
+   openToRead - attempts to open a file, fname, for reading and
+                it returns this file.
+                The success of this operation can be checked by
+                calling IsNoError.
+*)
+
+PROCEDURE openToRead (fname: ADDRESS; flength: CARDINAL) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforread, FALSE, MaxBufferLength) ;
+      ConnectToUnix(f, FALSE, FALSE)
+   END ;
+   RETURN( f )
+END openToRead ;
+
+
+(*
+   openToWrite - attempts to open a file, fname, for write and
+                 it returns this file.
+                 The success of this operation can be checked by
+                 calling IsNoError.
+*)
+
+PROCEDURE openToWrite (fname: ADDRESS; flength: CARDINAL) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforwrite, TRUE, MaxBufferLength) ;
+      ConnectToUnix(f, TRUE, TRUE)
+   END ;
+   RETURN( f )
+END openToWrite ;
+
+
+(*
+   openForRandom - attempts to open a file, fname, for random access
+                   read or write and it returns this file.
+                   The success of this operation can be checked by
+                   calling IsNoError.
+                   towrite, determines whether the file should be
+                   opened for writing or reading.
+*)
+
+PROCEDURE openForRandom (fname: ADDRESS; flength: CARDINAL;
+                         towrite, newfile: BOOLEAN) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforrandom, towrite, MaxBufferLength) ;
+      ConnectToUnix(f, towrite, newfile)
+   END ;
+   RETURN( f )
+END openForRandom ;
+
+
+(*
+   exists - returns TRUE if a file named, fname exists for reading.
+*)
+
+PROCEDURE exists (fname: ADDRESS; flength: CARDINAL) : BOOLEAN ;
+VAR
+   f: File ;
+BEGIN
+   f := openToRead(fname, flength) ;
+   IF IsNoError(f)
+   THEN
+      Close(f) ;
+      RETURN( TRUE )
+   ELSE
+      Close(f) ;
+      RETURN( FALSE )
+   END
+END exists ;
+
+
+(*
+   SetState - sets the field, state, of file, f, to, s.
+*)
+
+PROCEDURE SetState (f: File; s: FileStatus) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   fd := GetIndice(FileInfo, f) ;
+   fd^.state := s
+END SetState ;
+
+
+(*
+   InitializeFile - initialize a file descriptor
+*)
+
+PROCEDURE InitializeFile (f: File; fname: ADDRESS;
+                          flength: CARDINAL; fstate: FileStatus;
+                          use: FileUsage;
+                          towrite: BOOLEAN; buflength: CARDINAL) : File ;
+VAR
+   p : PtrToChar ;
+   fd: FileDescriptor ;
+BEGIN
+   NEW(fd) ;
+   IF fd=NIL
+   THEN
+      SetState(Error, outofmemory) ;
+      RETURN( Error )
+   ELSE
+      PutIndice(FileInfo, f, fd) ;
+      WITH fd^ DO
+         name.size := flength+1 ;  (* need to guarantee the nul for C *)
+         usage     := use ;
+         output    := towrite ;
+         ALLOCATE(name.address, name.size) ;
+         IF name.address=NIL
+         THEN
+            state := outofmemory ;
+            RETURN( f )
+         END ;
+         name.address := strncpy(name.address, fname, flength) ;
+         (* and assign nul to the last byte *)
+         p := name.address ;
+         INC(p, flength) ;
+         p^ := nul ;
+         abspos := 0 ;
+         (* now for the buffer *)
+         NEW(buffer) ;
+         IF buffer=NIL
+         THEN
+            SetState(Error, outofmemory) ;
+            RETURN( Error )
+         ELSE
+            WITH buffer^ DO
+               valid    := FALSE ;
+               bufstart := 0 ;
+               size     := buflength ;
+               position := 0 ;
+               filled   := 0 ;
+               IF size=0
+               THEN
+                  address := NIL
+               ELSE
+                  ALLOCATE(address, size) ;
+                  IF address=NIL
+                  THEN
+                     state := outofmemory ;
+                     RETURN( f )
+                  END
+               END ;
+               IF towrite
+               THEN
+                  left := size
+               ELSE
+                  left := 0
+               END ;
+               contents := address ;  (* provides easy access for reading characters *)
+            END ;
+            state := fstate
+         END
+      END
+   END ;
+   RETURN( f )
+END InitializeFile ;
+
+(*
+   ConnectToUnix - connects a FIO file to a UNIX file descriptor.
+*)
+
+PROCEDURE ConnectToUnix (f: File; towrite, newfile: BOOLEAN) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF towrite
+            THEN
+               IF newfile
+               THEN
+                  unixfd := creat(name.address, CreatePermissions)
+               ELSE
+                  unixfd := open(name.address, INTEGER (WriteOnly ()), 0)
+               END
+            ELSE
+               unixfd := open(name.address, INTEGER (ReadOnly ()), 0)
+            END ;
+            IF unixfd<0
+            THEN
+               state := connectionfailure
+            END
+         END
+      END
+   END
+END ConnectToUnix ;
+
+
+(*
+   The following functions are wrappers for the above.
+*)
+
+PROCEDURE Exists (fname: ARRAY OF CHAR) : BOOLEAN ;
+BEGIN
+   RETURN( exists(ADR(fname), StrLen(fname)) )
+END Exists ;
+
+
+PROCEDURE OpenToRead (fname: ARRAY OF CHAR) : File ;
+BEGIN
+   RETURN( openToRead(ADR(fname), StrLen(fname)) )
+END OpenToRead ;
+
+
+PROCEDURE OpenToWrite (fname: ARRAY OF CHAR) : File ;
+BEGIN
+   RETURN( openToWrite(ADR(fname), StrLen(fname)) )
+END OpenToWrite ;
+
+
+PROCEDURE OpenForRandom (fname: ARRAY OF CHAR;
+                         towrite: BOOLEAN; newfile: BOOLEAN) : File ;
+BEGIN
+   RETURN( openForRandom(ADR(fname), StrLen(fname), towrite, newfile) )
+END OpenForRandom ;
+
+(*
+   Close - close a file which has been previously opened using:
+           OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Close (f: File) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      (*
+         we allow users to close files which have an error status
+      *)
+      IF fd#NIL
+      THEN
+         FlushBuffer(f) ;
+         WITH fd^ DO
+            IF unixfd>=0
+            THEN
+               IF close(unixfd)#0
+               THEN
+                  FormatError1('failed to close file (%s)\n', name.address) ;
+                  state := failed   (* --fixme-- too late to notify user (unless we return a BOOLEAN) *)
+               END
+            END ;
+            IF name.address#NIL
+            THEN
+               DEALLOCATE(name.address, name.size)
+            END ;
+            IF buffer#NIL
+            THEN
+               WITH buffer^ DO
+                  IF address#NIL
+                  THEN
+                     DEALLOCATE(address, size)
+                  END
+               END ;
+               DISPOSE(buffer) ;
+               buffer := NIL
+            END
+         END ;
+         DISPOSE(fd) ;
+         PutIndice(FileInfo, f, NIL)
+      END
+   END
+END Close ;
+
+(*
+   Unlink - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Unlink ( f : File );
+
+VAR
+   fname: ARRAY[0..256] OF CHAR ;
+
+BEGIN
+  GetFileName(f,fname);
+  fd := GetIndice(FileInfo, f) ;
+  Close(f);
+  unlink(ADR(fname));
+END Unlink;
+
+(*
+   Delete - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Delete (fname: ARRAY OF CHAR ) ;
+
+VAR
+   fd: FileDescriptor ;
+     
+BEGIN
+  fd := GetFDesc(fname);
+  IF fd # NIL THEN 
+    Close(fd);
+    (*Unlink(ADR(fname));*)     
+  END;
+END Delete;
+
+(*
+   ReadFromBuffer - attempts to read, nBytes, from file, f.
+                    It firstly consumes the buffer and then performs
+                    direct unbuffered reads. This should only be used
+                    when wishing to read large files.
+
+                    The actual number of bytes read is returned.
+                    -1 is returned if EOF is reached.
+*)
+
+PROCEDURE ReadFromBuffer (f: File; a: ADDRESS; nBytes: CARDINAL) : INTEGER ;
+VAR
+   t     : ADDRESS ;
+   result: INTEGER ;
+   total,
+   n     : CARDINAL ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      total := 0 ;   (* how many bytes have we read *)
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         (* extract from the buffer first *)
+         IF (buffer#NIL) AND (buffer^.valid)
+         THEN
+            WITH buffer^ DO
+               IF left>0
+               THEN
+                  IF nBytes=1
+                  THEN
+                     (* too expensive to call memcpy for 1 character *)
+                     p := a ;
+                     p^ := contents^[position] ;
+                     DEC(left) ;         (* remove consumed bytes               *)
+                     INC(position) ;     (* move onwards n bytes                *)
+                     nBytes := 0 ;       (* reduce the amount for future direct *)
+                                         (* read                                *)
+                     RETURN( 1 )
+                  ELSE
+                     n := Min(left, nBytes) ;
+                     t := address ;
+                     INC(t, position) ;
+                     p := memcpy(a, t, n) ;
+                     DEC(left, n) ;      (* remove consumed bytes               *)
+                     INC(position, n) ;  (* move onwards n bytes                *)
+                                         (* move onwards ready for direct reads *)
+                     INC(a, n) ;
+                     DEC(nBytes, n) ;    (* reduce the amount for future direct *)
+                                         (* read                                *)
+                     INC(total, n) ;
+                     RETURN( total )     (* much cleaner to return now,         *)
+                  END                    (* difficult to record an error if     *)
+               END                       (* the read below returns -1           *)
+            END
+         END ;
+         IF nBytes>0
+         THEN
+            (* still more to read *)
+            result := read(unixfd, a, INTEGER(nBytes)) ;
+            IF result>0
+            THEN
+               INC(total, result) ;
+               INC(abspos, result) ;
+               (* now disable the buffer as we read directly into, a. *)
+               IF buffer#NIL
+               THEN
+                  buffer^.valid := FALSE
+               END ;
+            ELSE
+               IF result=0
+               THEN
+                  (* eof reached *)
+                  state := endoffile
+               ELSE
+                  state := failed
+               END ;
+               (* indicate buffer is empty *)
+               IF buffer#NIL
+               THEN
+                  WITH buffer^ DO
+                     valid    := FALSE ;
+                     left     := 0 ;
+                     position := 0 ;
+                     IF address#NIL
+                     THEN
+                        contents^[position] := nul
+                     END
+                  END
+               END ;
+               RETURN( -1 )
+            END
+         END
+      END ;
+      RETURN( total )
+   ELSE
+      RETURN( -1 )
+   END
+END ReadFromBuffer ;
+
+
+(*
+   ReadNBytes - reads nBytes of a file into memory area, dest, returning
+                the number of bytes actually read.
+                This function will consume from the buffer and then
+                perform direct libc reads. It is ideal for large reads.
+*)
+
+PROCEDURE ReadNBytes (f: File; nBytes: CARDINAL; dest: ADDRESS) : CARDINAL ;
+VAR
+   n: INTEGER ;
+   p: POINTER TO CHAR ;
+BEGIN
+   IF f # Error
+   THEN
+      CheckAccess (f, openedforread, FALSE) ;
+      n := ReadFromBuffer (f, dest, nBytes) ;
+      IF n <= 0
+      THEN
+         RETURN 0
+      ELSE
+         p := dest ;
+         INC (p, n-1) ;
+         SetEndOfLine (f, p^) ;
+         RETURN n
+      END
+   ELSE
+      RETURN 0
+   END
+END ReadNBytes ;
+
+
+(*
+   BufferedRead - will read, nBytes, through the buffer.
+                  Similar to ReadFromBuffer, but this function will always
+                  read into the buffer before copying into memory.
+
+                  Useful when performing small reads.
+*)
+
+PROCEDURE BufferedRead (f: File; nBytes: CARDINAL; dest: ADDRESS) : INTEGER ;
+VAR
+   src   : ADDRESS ;
+   total,
+   n     : INTEGER ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      total := 0 ;   (* how many bytes have we read *)
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            (* extract from the buffer first *)
+            IF buffer # NIL
+            THEN
+               WITH buffer^ DO
+                  WHILE nBytes > 0 DO
+                     IF (left > 0) AND valid
+                     THEN
+                        IF nBytes = 1
+                        THEN
+                           (* too expensive to call memcpy for 1 character *)
+                           p := dest ;
+                           p^ := contents^[position] ;
+                           DEC (left) ;         (* remove consumed byte                *)
+                           INC (position) ;     (* move onwards n byte                 *)
+                           INC (total) ;
+                           RETURN( total )
+                        ELSE
+                           n := Min (left, nBytes) ;
+                           src := address ;
+                           INC (src, position) ;
+                           p := memcpy (dest, src, n) ;
+                           DEC (left, n) ;      (* remove consumed bytes               *)
+                           INC (position, n) ;  (* move onwards n bytes                *)
+                                               (* move onwards ready for direct reads *)
+                           INC (dest, n) ;
+                           DEC (nBytes, n) ;    (* reduce the amount for future direct *)
+                                               (* read                                *)
+                           INC (total, n)
+                        END
+                     ELSE
+                        (* refill buffer *)
+                        n := read (unixfd, address, size) ;
+                        IF n >= 0
+                        THEN
+                           valid    := TRUE ;
+                           position := 0 ;
+                           left     := n ;
+                           filled   := n ;
+                           bufstart := abspos ;
+                           INC (abspos, n) ;
+                           IF n = 0
+                           THEN
+                              (* eof reached *)
+                              state := endoffile ;
+                              RETURN( -1 )
+                           END
+                        ELSE
+                           valid    := FALSE ;
+                           position := 0 ;
+                           left     := 0 ;
+                           filled   := 0 ;
+                           state    := failed ;
+                           RETURN( total )
+                        END
+                     END
+                  END
+               END ;
+               RETURN( total )
+            END
+         END
+      END
+   END ;
+   RETURN( -1 )
+END BufferedRead ;
+
+
+(*
+   HandleEscape - translates \n and \t into their respective ascii codes.
+*)
+
+PROCEDURE HandleEscape (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR;
+                        VAR i, j: CARDINAL; HighSrc, HighDest: CARDINAL) ;
+BEGIN
+   IF (i+1<HighSrc) AND (src[i]='\') AND (j<HighDest)
+   THEN
+      IF src[i+1]='n'
+      THEN
+         (* requires a newline *)
+         dest[j] := nl ;
+         INC(j) ;
+         INC(i, 2)
+      ELSIF src[i+1]='t'
+      THEN
+         (* requires a tab (yuck) tempted to fake this but I better not.. *)
+         dest[j] := tab ;
+         INC(j) ;
+         INC(i, 2)
+      ELSE
+         (* copy escaped character *)
+         INC(i) ;
+         dest[j] := src[i] ;
+         INC(j) ;
+         INC(i)
+      END
+   END
+END HandleEscape ;
+
+
+(*
+   Cast - casts a := b
+*)
+
+PROCEDURE Cast (VAR a: ARRAY OF BYTE; b: ARRAY OF BYTE) ;
+VAR
+   i: CARDINAL ;
+BEGIN
+   IF HIGH(a)=HIGH(b)
+   THEN
+      FOR i := 0 TO HIGH(a) DO
+         a[i] := b[i]
+      END
+   ELSE
+      FormatError('cast failed')
+   END
+END Cast ;
+
+
+(*
+   StringFormat1 - converts string, src, into, dest, together with encapsulated
+                   entity, w. It only formats the first %s or %d with n.
+*)
+
+PROCEDURE StringFormat1 (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR;
+                         w: ARRAY OF BYTE) ;
+VAR
+   HighSrc,
+   HighDest,
+   c, i, j : CARDINAL ;
+   str     : ARRAY [0..MaxErrorString] OF CHAR ;
+   p       : POINTER TO CHAR ;
+BEGIN
+   HighSrc := StrLen(src) ;
+   HighDest := HIGH(dest) ;
+   p := NIL ;
+   c := 0 ;
+   i := 0 ;
+   j := 0 ;
+   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) AND (src[i]#'%') DO
+      IF src[i]='\'
+      THEN
+         HandleEscape(dest, src, i, j, HighSrc, HighDest)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+
+   IF (i+1<HighSrc) AND (src[i]='%') AND (j<HighDest)
+   THEN
+      IF src[i+1]='s'
+      THEN
+         Cast(p, w) ;
+         WHILE (j<HighDest) AND (p^#nul) DO
+            dest[j] := p^ ;
+            INC(j) ;
+            INC(p)
+         END ;
+         IF j<HighDest
+         THEN
+            dest[j] := nul
+         END ;
+         j := StrLen(dest) ;
+         INC(i, 2)
+      ELSIF src[i+1]='d'
+      THEN
+         dest[j] := nul ;
+         Cast(c, w) ;
+         CardToStr(c, 0, str) ;
+         StrConCat(dest, str, dest) ;
+         j := StrLen(dest) ;
+         INC(i, 2)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+   (* and finish off copying src into dest *)
+   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) DO
+      IF src[i]='\'
+      THEN
+         HandleEscape(dest, src, i, j, HighSrc, HighDest)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+   IF j<HighDest
+   THEN
+      dest[j] := nul
+   END ;
+END StringFormat1 ;
+
+
+(*
+   FormatError - provides a orthoganal counterpart to the procedure below.
+*)
+
+PROCEDURE FormatError (a: ARRAY OF CHAR) ;
+BEGIN
+   WriteString (StdErr, a)
+END FormatError ;
+
+
+(*
+   FormatError1 - generic error procedure taking standard format string
+                  and single parameter.
+*)
+
+PROCEDURE FormatError1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
+VAR
+   s: ARRAY [0..MaxErrorString] OF CHAR ;
+BEGIN
+   StringFormat1 (s, a, w) ;
+   FormatError (s)
+END FormatError1 ;
+
+
+(*
+   FormatError2 - generic error procedure taking standard format string
+                  and two parameters.
+*)
+
+PROCEDURE FormatError2 (a: ARRAY OF CHAR;
+                        w1, w2: ARRAY OF BYTE) ;
+VAR
+   s: ARRAY [0..MaxErrorString] OF CHAR ;
+BEGIN
+   StringFormat1 (s, a, w1) ;
+   FormatError1 (s, w2)
+END FormatError2 ;
+
+
+(*
+   CheckAccess - checks to see whether a file f has been
+                 opened for read/write.
+*)
+
+PROCEDURE CheckAccess (f: File; use: FileUsage; towrite: BOOLEAN) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         IF f#StdErr
+         THEN
+            FormatError ('this file has probably been closed and not reopened successfully or alternatively never opened\n')
+         END ;
+         HALT
+      ELSE
+         WITH fd^ DO
+            IF (use=openedforwrite) AND (usage=openedforread)
+            THEN
+               FormatError1 ('this file (%s) has been opened for reading but is now being written\n',
+                             name.address) ;
+               HALT
+            ELSIF (use=openedforread) AND (usage=openedforwrite)
+            THEN
+               FormatError1('this file (%s) has been opened for writing but is now being read\n',
+                            name.address) ;
+               HALT
+            ELSIF state=connectionfailure
+            THEN
+               FormatError1('this file (%s) was not successfully opened\n',
+                            name.address) ;
+               HALT
+            ELSIF towrite#output
+            THEN
+               IF output
+               THEN
+                  FormatError1('this file (%s) was opened for writing but is now being read\n',
+                               name.address) ;
+                  HALT
+               ELSE
+                  FormatError1('this file (%s) was opened for reading but is now being written\n',
+                               name.address) ;
+                  HALT
+               END
+            END
+         END
+      END
+   ELSE
+      FormatError('this file has not been opened successfully\n') ;
+      HALT
+   END
+END CheckAccess ;
+
+
+(*
+   ReadChar - returns a character read from file f.
+              Sensible to check with IsNoError or EOF after calling
+              this function.
+*)
+
+PROCEDURE ReadChar (f: File) : CHAR ;
+VAR
+   ch: CHAR ;
+BEGIN
+   CheckAccess (f, openedforread, FALSE) ;
+   IF BufferedRead (f, SIZE (ch), ADR (ch)) = VAL (INTEGER, SIZE (ch))
+   THEN
+      SetEndOfLine (f, ch) ;
+      RETURN ch
+   ELSE
+      RETURN nul
+   END
+END ReadChar ;
+
+
+(*
+   SetEndOfLine -
+*)
+
+PROCEDURE SetEndOfLine (f: File; ch: CHAR) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         IF ch=nl
+         THEN
+            state := endofline
+         ELSE
+            state := successful
+         END
+      END
+   END
+END SetEndOfLine ;
+
+
+(*
+   UnReadChar - replaces a character, ch, back into file f.
+                This character must have been read by ReadChar
+                and it does not allow successive calls.  It may
+                only be called if the previous read was successful
+                or end of file was seen.
+                If the state was previously endoffile then it
+                is altered to successful.
+                Otherwise it is left alone.
+*)
+
+PROCEDURE UnReadChar (f: File; ch: CHAR) ;
+VAR
+   fd  : FileDescriptor ;
+   n   : CARDINAL ;
+   a, b: ADDRESS ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         IF (state=successful) OR (state=endoffile) OR (state=endofline)
+         THEN
+            IF (buffer#NIL) AND (buffer^.valid)
+            THEN
+               WITH buffer^ DO
+                  (* we assume that a ReadChar has occurred, we will check just in case. *)
+                  IF state=endoffile
+                  THEN
+                     position := MaxBufferLength ;
+                     left := 0 ;
+                     filled := 0 ;
+                     state := successful
+                  END ;
+                  IF position>0
+                  THEN
+                     DEC(position) ;
+                     INC(left) ;
+                     contents^[position] := ch ;
+                  ELSE
+                     (* position=0 *)
+                     (* if possible make room and store ch *)
+                     IF filled=size
+                     THEN
+                        FormatError1('performing too many UnReadChar calls on file (%d)\n', f)
+                     ELSE
+                        n := filled-position ;
+                        b := ADR(contents^[position]) ;
+                        a := ADR(contents^[position+1]) ;
+                        a := memcpy(a, b, n) ;
+                        INC(filled) ;
+                        contents^[position] := ch ;
+                     END
+                  END
+               END
+            END
+         ELSE
+            FormatError1('UnReadChar can only be called if the previous read was successful or end of file, error on file (%d)\n', f)
+         END
+      END
+   END
+END UnReadChar ;
+
+
+(*
+   ReadAny - reads HIGH (a) + 1 bytes into, a.  All input
+             is fully buffered, unlike ReadNBytes and thus is more
+             suited to small reads.
+*)
+
+PROCEDURE ReadAny (f: File; VAR a: ARRAY OF BYTE) ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF BufferedRead (f, HIGH (a) + 1, ADR (a)) = VAL (INTEGER, HIGH (a) + 1)
+   THEN
+      SetEndOfLine (f, a[HIGH(a)])
+   END
+END ReadAny ;
+
+
+(*
+   EOF - tests to see whether a file, f, has reached end of file.
+*)
+
+PROCEDURE EOF (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         RETURN( fd^.state=endoffile )
+      END
+   END ;
+   RETURN( TRUE )
+END EOF ;
+
+
+(*
+   EOLN - tests to see whether a file, f, is upon a newline.
+          It does NOT consume the newline.
+*)
+
+PROCEDURE EOLN (f: File) : BOOLEAN ;
+VAR
+   ch: CHAR ;
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   (*
+      we will read a character and then push it back onto the input stream,
+      having noted the file status, we also reset the status.
+   *)
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         IF (fd^.state=successful) OR (fd^.state=endofline)
+         THEN
+            ch := ReadChar(f) ;
+            IF (fd^.state=successful) OR (fd^.state=endofline)
+            THEN
+               UnReadChar(f, ch)
+            END ;
+            RETURN( ch=nl )
+         END
+      END
+   END ;
+   RETURN( FALSE )
+END EOLN ;
+
+
+(*
+   WasEOLN - tests to see whether a file, f, has just seen a newline.
+*)
+
+PROCEDURE WasEOLN (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f=Error
+   THEN
+      RETURN FALSE
+   ELSE
+      fd := GetIndice(FileInfo, f) ;
+      RETURN( (fd#NIL) AND (fd^.state=endofline) )
+   END
+END WasEOLN ;
+
+
+(*
+   WriteLine - writes out a linefeed to file, f.
+*)
+
+PROCEDURE WriteLine (f: File) ;
+BEGIN
+   WriteChar(f, nl)
+END WriteLine ;
+
+
+(*
+   WriteNBytes - writes nBytes from memory area src to a file
+                 returning the number of bytes actually written.
+                 This function will flush the buffer and then
+                 write the nBytes using a direct write from libc.
+                 It is ideal for large writes.
+*)
+
+PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL; src: ADDRESS) : CARDINAL ;
+VAR
+   total: INTEGER ;
+   fd   : FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforwrite, TRUE) ;
+   FlushBuffer(f) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            total := write(unixfd, src, INTEGER(nBytes)) ;
+            IF total<0
+            THEN
+               state := failed ;
+               RETURN( 0 )
+            ELSE
+               INC(abspos, CARDINAL(total)) ;
+               IF buffer#NIL
+               THEN
+                  buffer^.bufstart := abspos
+               END ;
+               RETURN( CARDINAL(total) )
+            END
+         END
+      END
+   END ;
+   RETURN( 0 )
+END WriteNBytes ;
+
+
+(*
+   BufferedWrite - will write, nBytes, through the buffer.
+                   Similar to WriteNBytes, but this function will always
+                   write into the buffer before copying into memory.
+
+                   Useful when performing small writes.
+*)
+
+PROCEDURE BufferedWrite (f: File; nBytes: CARDINAL; src: ADDRESS) : INTEGER ;
+VAR
+   dest  : ADDRESS ;
+   total,
+   n     : INTEGER ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f # Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         total := 0 ;   (* how many bytes have we read *)
+         WITH fd^ DO
+            IF buffer # NIL
+            THEN
+               WITH buffer^ DO
+                  WHILE nBytes > 0 DO
+                     (* place into the buffer first *)
+                     IF left > 0
+                     THEN
+                        IF nBytes = 1
+                        THEN
+                           (* too expensive to call memcpy for 1 character *)
+                           p := src ;
+                           contents^[position] := p^ ;
+                           DEC (left) ;         (* reduce space                        *)
+                           INC (position) ;     (* move onwards n byte                 *)
+                           INC (total) ;
+                           RETURN( total )
+                        ELSE
+                           n := Min (left, nBytes) ;
+                           dest := address ;
+                           INC (dest, position) ;
+                           p := memcpy (dest, src, CARDINAL (n)) ;
+                           DEC (left, n) ;      (* remove consumed bytes               *)
+                           INC (position, n) ;  (* move onwards n bytes                *)
+                                                (* move ready for further writes       *)
+                           INC (src, n) ;
+                           DEC (nBytes, n) ;    (* reduce the amount for future writes *)
+                           INC (total, n)
+                        END
+                     ELSE
+                        FlushBuffer (f) ;
+                        IF (state#successful) AND (state#endofline)
+                        THEN
+                           nBytes := 0
+                        END
+                     END
+                  END
+               END ;
+               RETURN( total )
+            END
+         END
+      END
+   END ;
+   RETURN( -1 )
+END BufferedWrite ;
+
+
+(*
+   FlushBuffer - flush contents of file, f.
+*)
+
+PROCEDURE FlushBuffer (f: File) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF output AND (buffer#NIL)
+            THEN
+               WITH buffer^ DO
+                  IF (position=0) OR (write(unixfd, address, position)=VAL(INTEGER, position))
+                  THEN
+                     INC(abspos, position) ;
+                     bufstart := abspos ;
+                     position := 0 ;
+                     filled   := 0 ;
+                     left     := size
+                  ELSE
+                     state := failed
+                  END
+               END
+            END
+         END
+      END
+   END
+END FlushBuffer ;
+
+
+(*
+   WriteAny - writes HIGH (a) + 1 bytes onto, file, f.  All output
+              is fully buffered, unlike WriteNBytes and thus is more
+              suited to small writes.
+*)
+
+PROCEDURE WriteAny (f: File; VAR a: ARRAY OF BYTE) ;
+BEGIN
+   CheckAccess (f, openedforwrite, TRUE) ;
+   IF BufferedWrite (f, HIGH (a) + 1, ADR (a)) = VAL (INTEGER, HIGH (a) + 1)
+   THEN
+   END
+END WriteAny ;
+
+
+(*
+   WriteChar - writes a single character to file, f.
+*)
+
+PROCEDURE WriteChar (f: File; ch: CHAR) ;
+BEGIN
+   CheckAccess (f, openedforwrite, TRUE) ;
+   IF BufferedWrite (f, SIZE (ch), ADR (ch)) = VAL (INTEGER, SIZE (ch))
+   THEN
+   END
+END WriteChar ;
+
+
+(*
+   WriteCardinal - writes a CARDINAL to file, f.
+                   It writes the binary image of the cardinal
+                   to file, f.
+*)
+
+PROCEDURE WriteCardinal (f: File; c: CARDINAL) ;
+BEGIN
+   WriteAny(f, c)
+END WriteCardinal ;
+
+
+(*
+   ReadCardinal - reads a CARDINAL from file, f.
+                  It reads a binary image of a CARDINAL
+                  from a file, f.
+*)
+
+PROCEDURE ReadCardinal (f: File) : CARDINAL ;
+VAR
+   c: CARDINAL ;
+BEGIN
+   ReadAny(f, c) ;
+   RETURN( c )
+END ReadCardinal ;
+
+
+(*
+   ReadString - reads a string from file, f, into string, a.
+                It terminates the string if HIGH is reached or
+                if a newline is seen or an error occurs.
+*)
+
+PROCEDURE ReadString (f: File; VAR a: ARRAY OF CHAR) ;
+VAR
+   high,
+   i   : CARDINAL ;
+   ch  : CHAR ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   high := HIGH(a) ;
+   i := 0 ;
+   REPEAT
+      ch := ReadChar(f) ;
+      IF i<=high
+      THEN
+         IF (ch=nl) OR (NOT IsNoError(f)) OR EOF(f)
+         THEN
+            a[i] := nul ;
+            INC(i)
+         ELSE
+            a[i] := ch ;
+            INC(i)
+         END
+      END
+   UNTIL (ch=nl) OR (i>high) OR (NOT IsNoError(f)) OR EOF(f)
+END ReadString ;
+
+
+(*
+   SetPositionFromBeginning - sets the position from the beginning of the file.
+*)
+
+PROCEDURE SetPositionFromBeginning (f: File; pos: LONGINT) ;
+VAR
+   offset: LONGINT ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            (* always force the lseek, until we are confident that abspos is always correct,
+               basically it needs some hard testing before we should remove the OR TRUE. *)
+            IF (abspos#pos) OR TRUE
+            THEN
+               FlushBuffer(f) ;
+               IF buffer#NIL
+               THEN
+                  WITH buffer^ DO
+                     IF output
+                     THEN
+                        left := size
+                     ELSE
+                        left := 0
+                     END ;
+                     position := 0 ;
+                     filled   := 0
+                  END
+               END ;
+               offset := lseek (unixfd, VAL (COFF_T, pos), SeekSet ()) ;
+               IF (offset>=0) AND (pos=offset)
+               THEN
+                  abspos := pos
+               ELSE
+                  state  := failed ;
+                  abspos := 0
+               END ;
+               IF buffer#NIL
+               THEN
+                  buffer^.valid := FALSE ;
+                  buffer^.bufstart := abspos
+               END
+            END
+         END
+      END
+   END
+END SetPositionFromBeginning ;
+
+
+(*
+   SetPositionFromEnd - sets the position from the end of the file.
+*)
+
+PROCEDURE SetPositionFromEnd (f: File; pos: LONGINT) ;
+VAR
+   offset: LONGINT ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            FlushBuffer(f) ;
+            IF buffer#NIL
+            THEN
+               WITH buffer^ DO
+                  IF output
+                  THEN
+                     left := size
+                  ELSE
+                     left := 0
+                  END ;
+                  position := 0 ;
+                  filled   := 0
+               END
+            END ;
+            offset := lseek (unixfd, VAL (COFF_T, pos), SeekEnd ()) ;
+            IF offset>=0
+            THEN
+               abspos := offset ;
+            ELSE
+               state  := failed ;
+               abspos := 0 ;
+               offset := 0
+            END ;
+            IF buffer#NIL
+            THEN
+               buffer^.valid := FALSE ;
+               buffer^.bufstart := offset
+            END
+         END
+      END
+   END
+END SetPositionFromEnd ;
+
+
+(*
+   FindPosition - returns the current absolute position in file, f.
+*)
+
+PROCEDURE FindPosition (f: File) : LONGINT ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF (buffer=NIL) OR (NOT buffer^.valid)
+            THEN
+               RETURN( abspos )
+            ELSE
+               WITH buffer^ DO
+                  RETURN( bufstart+VAL(LONGINT, position) )
+               END
+            END
+         END
+      END
+   END ;
+   RETURN( 0 )
+END FindPosition ;
+
+
+(*
+   GetFDesc - return the file descriptor associated with File name,  fname
+*)
+
+PROCEDURE GetFDesc (fname : ARRAY OF CHAR ) : File;
+
+VAR 
+  i : CARDINAL;
+  fd : File;
+  name : ARRAY[0..256] OF CHAR;
+
+BEGIN 
+  FOR i := LowIndice(FileInfo) TO HighIndice(FileInfo) DO 
+    fd := GetIndice (FileInfo, i);
+    GetFileName(fd, name);
+    IF Strings.Compare (fname,name) = equal THEN 
+      RETURN fd
+    END;  
+  END;
+  RETURN NIL 
+END GetFDesc;
+(*
+   GetFileName - assigns, a, with the filename associated with, f.
+*)
+
+PROCEDURE GetFileName (f: File; VAR a: ARRAY OF CHAR) ;
+VAR
+   i : CARDINAL ;
+   p : POINTER TO CHAR ;
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         WITH fd^.name DO
+            IF address=NIL
+            THEN
+               StrCopy('', a)
+            ELSE
+               p := address ;
+               i := 0 ;
+               WHILE (p^#nul) AND (i<=HIGH(a)) DO
+                  a[i] := p^ ;
+                  INC(p) ;
+                  INC(i)
+               END
+            END
+         END
+      END
+   END
+END GetFileName ;
+
+
+(*
+   getFileName - returns the address of the filename associated with, f.
+*)
+
+PROCEDURE getFileName (f: File) : ADDRESS ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         RETURN fd^.name.address
+      END
+   END ;
+   RETURN NIL
+END getFileName ;
+
+
+(*
+   getFileNameLength - returns the number of characters associated with filename, f.
+*)
+
+PROCEDURE getFileNameLength (f: File) : CARDINAL ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         RETURN fd^.name.size
+      END
+   END ;
+   RETURN 0
+END getFileNameLength ;
+
+
+(*
+   PreInitialize - preinitialize the file descriptor.
+*)
+
+PROCEDURE PreInitialize (f: File; fname: ARRAY OF CHAR;
+                         state: FileStatus; use: FileUsage;
+                         towrite: BOOLEAN; osfd: INTEGER; bufsize: CARDINAL) ;
+VAR
+   fd, fe: FileDescriptor ;
+BEGIN
+   IF InitializeFile(f, ADR(fname), StrLen(fname), state, use, towrite, bufsize)=f
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF f=Error
+      THEN
+         fe := GetIndice(FileInfo, StdErr) ;
+         IF fe=NIL
+         THEN
+            HALT
+         ELSE
+            fd^.unixfd := fe^.unixfd    (* the error channel *)
+         END
+      ELSE
+         fd^.unixfd := osfd
+      END
+   ELSE
+      HALT
+   END
+END PreInitialize ;
+
+
+(*
+   FlushOutErr - flushes, StdOut, and, StdErr.
+                 It is also called when the application calls M2RTS.Terminate.
+                 (which is automatically placed in program modules by the GM2
+                 scaffold).
+*)
+
+PROCEDURE FlushOutErr ;
+BEGIN
+   IF IsNoError(StdOut)
+   THEN
+      FlushBuffer(StdOut)
+   END ;
+   IF IsNoError(StdErr)
+   THEN
+      FlushBuffer(StdErr)
+   END
+END FlushOutErr ;
+
+
+(*
+   Init - initialize the modules, global variables.
+*)
+
+PROCEDURE Init ;
+BEGIN
+   FileInfo := InitIndex(0) ;
+   Error := 0 ;
+   PreInitialize(Error       , 'error'   , toomanyfilesopen, unused        , FALSE, -1, 0) ;
+   StdIn := 1 ;
+   PreInitialize(StdIn       , '<stdin>' , successful      , openedforread , FALSE, 0, MaxBufferLength) ;
+   StdOut := 2 ;
+   PreInitialize(StdOut      , '<stdout>', successful      , openedforwrite,  TRUE, 1, MaxBufferLength) ;
+   StdErr := 3 ;
+   PreInitialize(StdErr      , '<stderr>', successful      , openedforwrite,  TRUE, 2, MaxBufferLength) ;
+   IF NOT InstallTerminationProcedure(FlushOutErr)
+   THEN
+      HALT
+   END
+END Init ;
+
+
+BEGIN
+   Init
+FINALLY
+   FlushOutErr
+END FIO.

FileIO.def

@@ -0,0 +1,330 @@
+DEFINITION MODULE FileIO;
+(* This module attempts to provide several potentially non-portable
+   facilities for Coco/R.
+
+   (a)  A general file input/output module, with all routines required for
+        Coco/R itself, as well as several other that would be useful in
+        Coco-generated applications.
+   (b)  Definition of the "LONGINT" type needed by Coco.
+   (c)  Some conversion functions to handle this long type.
+   (d)  Some "long" and other constant literals that may be problematic
+        on some implementations.
+   (e)  Some string handling primitives needed to interface to a variety
+        of known implementations.
+
+   The intention is that the rest of the code of Coco and its generated
+   parsers should be as portable as possible.  Provided the definition
+   module given, and the associated implementation, satisfy the
+   specification given here, this should be almost 100% possible (with
+   the exception of a few constants, avoid changing anything in this
+   specification).
+
+   FileIO is based on code by MB 1990/11/25; heavily modified and extended
+   by PDT and others between 1992/1/6 and the present day. *)
+
+(* This is the ISO Gardens Point Modula (Linux/FreeBSD) version *)
+
+IMPORT SYSTEM, Strings;
+
+TYPE
+  File;                (* Preferably opaque *)
+  INT32 = INTEGER;     (* This may require a special import; on 32 bit
+                          systems INT32 = INTEGER may even suffice. *)
+
+CONST
+  EOF = 0C;            (* FileIO.Read returns EOF when eof is reached. *)
+  EOL = 12C;           (* 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). *)
+
+  BitSetSize = 16;     (* number of bits actually used in BITSET type *)
+
+  Long0 = VAL(INT32, 0); (* Some systems allow 0 or require 0L. *)
+  Long1 = VAL(INT32, 1); (* Some systems allow 1 or require 1L. *)
+  Long2 = VAL(INT32, 2); (* Some systems allow 2 or require 2L. *)
+
+  FrmExt = ".frm";     (* supplied frame files have this extension. *)
+  TxtExt = ".txt";     (* generated text files may have this extension. *)
+  ErrExt = ".err";     (* generated error files may have this extension. *)
+  DefExt = ".def";     (* generated definition modules have this extension. *)
+  PasExt = ".pas";     (* generated Pascal units have this extension. *)
+  ModExt = ".mod";     (* generated implementation/program modules have this
+                          extension. *)
+  PathSep = ":";       (* separate components in path environment variables
+                          DOS = ";"  UNIX = ":" *)
+  DirSep  = "/";       (* separate directory element of file specifiers
+                          DOS = "\"  UNIX = "/" *)
+
+VAR
+  Okay: BOOLEAN;       (* Status of last I/O operation. *)
+  con, err:  File;     (* Standard terminal and error channels. *)
+  StdIn, StdOut: File; (* standard input/output - redirectable *)
+  EOFChar: CHAR;       (* Signal EOF interactively *)
+
+(* The following routines provide access to command line parameters and
+   the environment. *)
+
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+(* Extracts next parameter from command line.
+   Returns empty string (s[0] = 0C) if no further parameter can be found. *)
+
+PROCEDURE GetEnv (envVar: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+(* Returns s as the value of environment variable envVar, or empty string
+   if that variable is not defined. *)
+
+(* The following routines provide a minimal set of file opening routines
+   and closing routines. *)
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+(* Opens file f whose full name is specified by fileName.
+   Opening mode is specified by newFile:
+       TRUE:  the specified file is opened for output only.  Any existing
+              file with the same name is deleted.
+      FALSE:  the specified file is opened for input only.
+   FileIO.Okay indicates whether the file f has been opened successfully. *)
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+(* As for Open, but tries to open file of given fileName by searching each
+   directory specified by the environment variable named by envVar. *)
+
+PROCEDURE Close (VAR f: File);
+(* Closes file f.  f becomes NIL.
+   If possible, Close should be called automatically for all files that
+   remain open when the application terminates.  This will be possible on
+   implementations that provide some sort of termination or at-exit
+   facility. *)
+
+PROCEDURE CloseAll;
+(* Closes all files opened by Open or SearchFile.
+   On systems that allow this, CloseAll should be automatically installed
+   as the termination (at-exit) procedure *)
+
+(* The following utility procedure is not used by Coco, but may be useful.
+   However, some operating systems may not allow for its implementation. *)
+
+PROCEDURE Delete (VAR f: File);
+(* Deletes file f.  f becomes NIL. *)
+
+(* The following routines provide a minimal set of file name manipulation
+   routines.  These are modelled after MS-DOS conventions, where a file
+   specifier is of a form exemplified by D:\DIR\SUBDIR\PRIMARY.EXT
+   Other conventions may be introduced; these routines are used by Coco to
+   derive names for the generated modules from the grammar name and the
+   directory in which the grammar specification is located. *)
+
+PROCEDURE ExtractDirectory (fullName: ARRAY OF CHAR;
+                            VAR directory: ARRAY OF CHAR);
+(* Extracts D:\DIRECTORY\ portion of fullName. *)
+
+PROCEDURE ExtractFileName (fullName: ARRAY OF CHAR;
+                           VAR fileName: ARRAY OF CHAR);
+(* Extracts PRIMARY.EXT portion of fullName. *)
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as complete file name by appending ext to oldName
+   if it doesn't end with "."  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as a complete file name by changing extension of
+   oldName to ext.  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.EXT
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+
+(* The following routines provide a minimal set of file positioning routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+
+PROCEDURE Length (f: File): INT32;
+(* Returns length of file f. *)
+
+PROCEDURE GetPos (f: File): INT32;
+(* Returns the current read/write position in f. *)
+
+PROCEDURE SetPos (f: File; pos: INT32);
+(* Sets the current position for f to pos. *)
+
+(* The following routines provide a minimal set of file rewinding routines.
+   These two are not currently used by Coco itself.
+   Success of each operation is recorded in FileIO.Okay *)
+
+PROCEDURE Reset (f: File);
+(* Sets the read/write position to the start of the file *)
+
+PROCEDURE Rewrite (f: File);
+(* Truncates the file, leaving open for writing *)
+
+(* The following routines provide a minimal set of input routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of a line, or at end of file. *)
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of file. *)
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+(* Reads a character ch from file f.
+   Maps filing system line mark sequence to FileIO.EOL. *)
+
+PROCEDURE ReadAgain (f: File);
+(* Prepares to re-read the last character read from f.
+   There is no buffer, so at most one character can be re-read. *)
+
+PROCEDURE ReadLn (f: File);
+(* Reads to start of next line on file f, or to end of file if no next
+   line.  Skips to, and consumes next line mark. *)
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are skipped, and str is delimited by line mark.
+   Line mark is not consumed. *)
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are not skipped, and str is terminated by line mark or
+   control character, which is not consumed. *)
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks and line feeds are skipped, and token is terminated by a
+   character <= ' ', which is not consumed. *)
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+(* Reads an integer value from file f. *)
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+(* Reads a cardinal value from file f. *)
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+(* Attempts to read len bytes from the current file position into buf.
+   After the call, len contains the number of bytes actually read. *)
+
+(* The following routines provide a minimal set of output routines.
+   Others may be introduced, but at least these should be implemented. *)
+
+PROCEDURE Write (f: File; ch: CHAR);
+(* Writes a character ch to file f.
+   If ch = FileIO.EOL, writes line mark appropriate to filing system. *)
+
+PROCEDURE WriteLn (f: File);
+(* Skips to the start of the next line on file f.
+   Writes line mark appropriate to filing system. *)
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+(* Writes entire string str to file f. *)
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+(* Writes text to file f.
+   At most len characters are written.  Trailing spaces are introduced
+   if necessary (thus providing left justification). *)
+
+PROCEDURE WriteInt (f: File; int: INTEGER; wid: CARDINAL);
+(* Writes an INTEGER int into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+
+PROCEDURE WriteCard (f: File; card, wid: CARDINAL);
+(* Writes a CARDINAL card into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+(* Writes len bytes from buf to f at the current file position. *)
+
+(* The following procedures are not currently used by Coco, and may be
+   safely omitted, or implemented as null procedures.  They might be
+   useful in measuring performance. *)
+
+PROCEDURE WriteDate (f: File);
+(* Write current date DD/MM/YYYY to file f. *)
+
+PROCEDURE WriteTime (f: File);
+(* Write time HH:MM:SS to file f. *)
+
+PROCEDURE WriteElapsedTime (f: File);
+(* Write elapsed time in seconds since last call of this procedure. *)
+
+PROCEDURE WriteExecutionTime (f: File);
+(* Write total execution time in seconds thus far to file f. *)
+
+(* The following procedures are a minimal set used within Coco for
+   string manipulation.  They almost follow the conventions of the ISO
+   routines, and are provided here to interface onto whatever Strings
+   library is available.  On ISO compilers it should be possible to
+   implement most of these with CONST declarations, and even replace
+   SLENGTH with the pervasive function LENGTH at the points where it is
+   called.
+
+CONST
+  SLENGTH = Strings.Length;
+  Assign  = Strings.Assign;
+  Extract = Strings.Extract;
+  Concat  = Strings.Concat;
+
+*)
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+(* Returns number of characters in stringVal, not including nul *)
+
+PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+(* Copies as much of source to destination as possible, truncating if too
+   long, and nul terminating if shorter.
+   Be careful - some libraries have the parameters reversed! *)
+
+PROCEDURE Extract (source: ARRAY OF CHAR;
+                   startIndex, numberToExtract: CARDINAL;
+                   VAR destination: ARRAY OF CHAR);
+(* Extracts at most numberToExtract characters from source[startIndex]
+   to destination.  If source is too short, fewer will be extracted, even
+   zero perhaps *)
+
+PROCEDURE Concat (stringVal1, stringVal2: ARRAY OF CHAR;
+                  VAR destination: ARRAY OF CHAR);
+(* Concatenates stringVal1 and stringVal2 to form destination.
+   Nul terminated if concatenation is short enough, truncated if it is
+   too long *)
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+(* Returns -1, 0, 1 depending whether stringVal1 < = > stringVal2.
+   This is not directly ISO compatible *)
+
+(* The following routines are for conversions to and from the INT32 type.
+   Their names are modelled after the ISO pervasive routines that would
+   achieve the same end.  Where possible, replacing calls to these routines
+   by the pervasives would improve performance markedly.  As used in Coco,
+   these routines should not give range problems. *)
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+(* Convert long integer n to corresponding (short) cardinal value.
+   Potentially FileIO.ORDL(n) = VAL(CARDINAL, n) *)
+
+PROCEDURE INTL (n: INT32): INTEGER;
+(* Convert long integer n to corresponding short integer value.
+   Potentially FileIO.INTL(n) = VAL(INTEGER, n) *)
+
+PROCEDURE INT (n: CARDINAL): INT32;
+(* Convert cardinal n to corresponding long integer value.
+   Potentially FileIO.INT(n) = VAL(INT32, n) *)
+
+PROCEDURE QuitExecution;
+(* Close all files and halt execution.
+   On some implementations QuitExecution will be simply implemented as HALT *)
+
+END FileIO.

FileIO.mod

@@ -0,0 +1,795 @@
+IMPLEMENTATION MODULE FileIO;
+
+IMPORT Strings,FIO,SysClock, NumberIO, InOut, Storage,FileName;
+
+CONST
+  MaxFiles = BitSetSize;
+  NameLength = 256;
+  
+TYPE
+  File = POINTER TO FileRec;
+  FileRec = RECORD
+              ref: FIO.File;
+              self: File;
+              handle: CARDINAL;
+              savedCh: CHAR;
+              textOK, eof, eol, noOutput, noInput, haveCh: BOOLEAN;
+              name: ARRAY [0 .. NameLength] OF CHAR;
+            END;
+VAR 
+  theTime : SysClock.DateTime;
+  FromKeyboard, ToScreen: BOOLEAN;
+
+(***********************************************)
+
+PROCEDURE NotRead (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noInput);
+  END NotRead;
+
+PROCEDURE NotWrite (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (f^.noOutput);
+  END NotWrite;
+
+PROCEDURE NotFile (f: File): BOOLEAN;
+  BEGIN
+    RETURN (f = NIL) OR (f^.self # f) OR (File(f) = con) OR (File(f) = err)
+      OR (File(f) = StdIn) & FromKeyboard
+      OR (File(f) = StdOut) & ToScreen
+  END NotFile;
+  
+PROCEDURE NextParameter (VAR s: ARRAY OF CHAR);
+(* Extracts next parameter from command line.
+   Returns empty string (s[0] = 0C) if no further parameter can be found. *)
+   
+BEGIN 
+
+END NextParameter;
+
+PROCEDURE GetEnv (envVar: ARRAY OF CHAR; VAR s: ARRAY OF CHAR);
+(* Returns s as the value of environment variable envVar, or empty string
+   if that variable is not defined. *)
+
+(* The following routines provide a minimal set of file opening routines
+   and closing routines. *)
+   
+BEGIN 
+
+END GetEnv;
+
+PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN);
+(* Opens file f whose full name is specified by fileName.
+   Opening mode is specified by newFile:
+       TRUE:  the specified file is opened for output only.  Any existing
+              file with the same name is deleted.
+      FALSE:  the specified file is opened for input only.
+   FileIO.Okay indicates whether the file f has been opened successfully. *)
+   
+BEGIN 
+
+END Open;
+
+PROCEDURE SearchFile (VAR f: File; envVar, fileName: ARRAY OF CHAR;
+                      newFile: BOOLEAN);
+(* As for Open, but tries to open file of given fileName by searching each
+   directory specified by the environment variable named by envVar. *)
+   
+BEGIN 
+
+END SearchFile;
+
+PROCEDURE Close (VAR f: File);
+(* Closes file f.  f becomes NIL.
+   If possible, Close should be called automatically for all files that
+   remain open when the application terminates.  This will be possible on
+   implementations that provide some sort of termination or at-exit
+   facility. *)
+   
+BEGIN 
+
+END Close;
+
+PROCEDURE CloseAll;
+(* Closes all files opened by Open or SearchFile.
+   On systems that allow this, CloseAll should be automatically installed
+   as the termination (at-exit) procedure *)
+
+(* The following utility procedure is not used by Coco, but may be useful.
+   However, some operating systems may not allow for its implementation. *)
+   
+BEGIN 
+
+END CloseAll;
+
+PROCEDURE Delete (VAR f: File);
+(* Deletes file f.  f becomes NIL. *)
+
+(* The following routines provide a minimal set of file name manipulation
+   routines.  These are modelled after MS-DOS conventions, where a file
+   specifier is of a form exemplified by D:\DIR\SUBDIR\PRIMARY.EXT
+   Other conventions may be introduced; these routines are used by Coco to
+   derive names for the generated modules from the grammar name and the
+   directory in which the grammar specification is located. *)
+   
+BEGIN 
+
+END Delete;
+
+(**********************************************************)
+
+PROCEDURE ExtractDirectory (fullName: ARRAY OF CHAR;
+                            VAR directory: ARRAY OF CHAR);
+(* Extracts /home/eric/Projects/ from  /home/eric/Projects/essai.txt *)
+   
+BEGIN 
+ FileName.GetDir(fullName,directory)
+END ExtractDirectory;
+
+PROCEDURE ExtractFileName (fullName: ARRAY OF CHAR;
+                           VAR fileName: ARRAY OF CHAR);
+(* Extracts PRIMARY.EXT portion of fullName. *)
+   
+VAR
+  a,b,c : ARRAY[0..256] OF CHAR;
+   
+BEGIN 
+  FileName.Get(fullName,a,b,c);
+  Strings.Concat(b,c,fileName)
+END ExtractFileName;
+
+PROCEDURE AppendExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as complete file name by appending ext to oldName
+   if it doesn't end with "."  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+   
+VAR
+  dIr,nAme,eXt    : ARRAY[0..256] OF CHAR;
+  L               : CARDINAL;
+  save            : CARDINAL;
+  extPos, extLen, 
+  namePos, nameLen, 
+  dirPos, dirLen  : CARDINAL;
+  
+BEGIN 
+  L := LENGTH(oldName);
+  save := L;
+   (* separating the dir part from the filename+ext part *)
+  REPEAT 
+    DEC(save);
+    IF oldName[save] = "." THEN
+     extPos := save + 1;
+     extLen := L - extPos ;
+   END; 
+  UNTIL oldName[save] = "/";
+  dirPos := 0;
+  dirLen := save;
+  
+END AppendExtension;
+
+PROCEDURE ChangeExtension (oldName, ext: ARRAY OF CHAR;
+                           VAR newName: ARRAY OF CHAR);
+(* Constructs newName as a complete file name by changing extension of
+   oldName to ext.  Examples: (assume ext = "EXT")
+         old.any ==> OLD.EXT
+         old.    ==> OLD.EXT
+         old     ==> OLD.EXT
+   This is not a file renaming facility, merely a string manipulation
+   routine. *)
+
+(* The following routines provide a minimal set of file positioning routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+   
+BEGIN 
+
+END ChangeExtension;
+
+(*********************************************)
+
+PROCEDURE Length (f: File): INT32;
+(* Returns length of file f. *)
+   
+BEGIN 
+  IF NotFile(f) THEN
+    Okay := FALSE; 
+    RETURN Long0
+  ELSE
+    Okay := TRUE;
+    FIO.SetPositionFromEnd(f^.ref,0);
+    RETURN VAL(INT32,FIO.FindPosition(f^.ref))
+  END;
+END Length;
+
+PROCEDURE GetPos (f: File): INT32;
+(* Returns the current read/write position in f. *)
+   
+BEGIN 
+  IF NotFile(f) THEN
+    Okay := FALSE; 
+    RETURN Long0
+  ELSE
+    Okay := TRUE;
+    RETURN VAL(INT32,FIO.FindPosition(f^.ref))
+  END;
+END GetPos;
+
+PROCEDURE SetPos (f: File; pos: INT32);
+(* Sets the current position for f to pos. *)
+
+(* The following routines provide a minimal set of file rewinding routines.
+   These two are not currently used by Coco itself.
+   Success of each operation is recorded in FileIO.Okay *)
+   
+BEGIN 
+  IF NotFile(f) THEN
+    Okay := FALSE
+  ELSE
+    Okay := TRUE; 
+    f^.haveCh := FALSE;
+    FIO.SetPositionFromBeginning(f^.ref,VAL(LONGINT,pos));
+  END;
+END SetPos;
+
+PROCEDURE Reset (f: File);
+(* Sets the read/write position to the start of the file *)
+   
+BEGIN 
+  IF NotFile(f) THEN
+    Okay := FALSE
+  ELSE
+    FIO.SetPositionFromBeginning(f^.ref,0);
+    SetPos(f, 0);
+    IF Okay THEN
+      f^.haveCh := FALSE; 
+      f^.eof := f^.noInput; 
+      f^.eol := f^.noInput
+    END
+ END
+END Reset;
+
+PROCEDURE Rewrite (f: File);
+(* Truncates the file, leaving open for writing *)
+
+(* The following routines provide a minimal set of input routines.
+   Others may be introduced, but at least these should be implemented.
+   Success of each operation is recorded in FileIO.Okay. *)
+   
+BEGIN 
+  IF NotFile(f) THEN
+    Okay := FALSE
+  ELSE
+    FIO.Close(f^.ref);
+    f^.ref := FIO.OpenToWrite(f^.name);
+    Okay := FIO.IsNoError(f^.ref);
+    IF ~ Okay THEN
+      Storage.DEALLOCATE(f, SYSTEM.TSIZE(FileRec)); f := NIL
+    ELSE
+      f^.savedCh := 0C; f^.haveCh := FALSE;
+      f^.eof := TRUE; f^.eol := TRUE; 
+      f^.noInput := TRUE; f^.noOutput := FALSE;
+    END
+  END;
+END Rewrite;
+
+PROCEDURE EndOfLine (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of a line, or at end of file. *)
+   
+BEGIN 
+  IF NotRead(f) THEN 
+    Okay := FALSE; 
+    RETURN TRUE
+  ELSE 
+    Okay := TRUE; 
+    RETURN f^.eol OR f^.eof
+  END
+END EndOfLine;
+
+PROCEDURE EndOfFile (f: File): BOOLEAN;
+(* TRUE if f is currently at the end of file. *)
+   
+BEGIN 
+  IF NotRead(f)THEN 
+    Okay := FALSE; 
+    RETURN TRUE
+  ELSE Okay := TRUE; 
+    RETURN f^.eof
+  END
+END EndOfFile;
+
+
+(****************************************************)
+
+PROCEDURE Read (f: File; VAR ch: CHAR);
+(* Reads a character ch from file f.
+   Maps filing system line mark sequence to FileIO.EOL. *)
+   
+BEGIN 
+
+END Read;
+
+PROCEDURE ReadAgain (f: File);
+(* Prepares to re-read the last character read from f.
+   There is no buffer, so at most one character can be re-read. *)
+   
+BEGIN 
+
+END ReadAgain;
+
+PROCEDURE ReadLn (f: File);
+(* Reads to start of next line on file f, or to end of file if no next
+   line.  Skips to, and consumes next line mark. *)
+   
+BEGIN 
+
+END ReadLn;
+
+PROCEDURE ReadString (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are skipped, and str is delimited by line mark.
+   Line mark is not consumed. *)
+   
+BEGIN 
+
+END ReadString;
+
+PROCEDURE ReadLine (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks are not skipped, and str is terminated by line mark or
+   control character, which is not consumed. *)
+   
+BEGIN 
+
+END ReadLine;
+
+PROCEDURE ReadToken (f: File; VAR str: ARRAY OF CHAR);
+(* Reads a string of characters from file f.
+   Leading blanks and line feeds are skipped, and token is terminated by a
+   character <= ' ', which is not consumed. *)
+   
+BEGIN 
+
+END ReadToken;
+
+PROCEDURE ReadInt (f: File; VAR i: INTEGER);
+(* Reads an integer value from file f. *)
+   
+BEGIN 
+
+END ReadInt;
+
+PROCEDURE ReadCard (f: File; VAR i: CARDINAL);
+(* Reads a cardinal value from file f. *)
+   
+BEGIN 
+
+END ReadCard;
+
+PROCEDURE ReadBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; VAR len: CARDINAL);
+(* Attempts to read len bytes from the current file position into buf.
+   After the call, len contains the number of bytes actually read. *)
+
+(* The following routines provide a minimal set of output routines.
+   Others may be introduced, but at least these should be implemented. *)
+   
+BEGIN 
+
+END ReadBytes;
+
+(*****************************************************)
+
+PROCEDURE Write (f: File; ch: CHAR);
+  (* Writes a character ch to file f.  If ch = FileIO.EOL, writes line mark appropriate to filing system. *)
+
+  BEGIN
+    IF NotWrite(f) THEN 
+      Okay := FALSE; 
+      RETURN 
+    END;
+    Okay := TRUE;
+    FIO.WriteChar(f^.ref, ch)
+  END Write;
+
+PROCEDURE WriteLn (f: File);
+(* Skips to the start of the next line on file f.
+   Writes line mark appropriate to filing system. *)
+   
+BEGIN 
+  IF NotWrite(f) THEN 
+    Okay := FALSE;
+  ELSE 
+    Write(f, EOL)
+  END
+END WriteLn;
+
+PROCEDURE WriteString (f: File; str: ARRAY OF CHAR);
+(* Writes entire string str to file f. *)
+   
+BEGIN 
+  IF NotWrite(f) THEN 
+    Okay := FALSE; 
+    RETURN 
+  END;
+  FIO.WriteString(f^.ref, str)
+END WriteString;
+
+PROCEDURE WriteText (f: File; text: ARRAY OF CHAR; len: INTEGER);
+(* Writes text to file f.
+   At most len characters are written.  Trailing spaces are introduced
+   if necessary (thus providing left justification). *)
+VAR 
+  i, slen: INTEGER;
+BEGIN 
+   IF NotWrite(f) THEN 
+     Okay := FALSE; 
+     RETURN 
+   END;
+  slen := Strings.Length(text);
+  FOR i := 0 TO len - 1 DO
+    IF i < slen THEN 
+      Write(f, text[i]) 
+    ELSE
+      Write(f, " ") 
+    END;
+  END
+END WriteText;
+
+PROCEDURE WriteInt (f: File; n: INTEGER; wid: CARDINAL);
+(* Writes an INTEGER int into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+VAR
+    l, d: CARDINAL;
+    x: INTEGER;
+    t: ARRAY [1 .. 25] OF CHAR;
+    sign: CHAR;
+    
+BEGIN
+  IF NotWrite(f) THEN 
+    Okay := FALSE; 
+    RETURN 
+  END;
+  IF n < 0 THEN 
+    sign := "-"; 
+    x := - n;
+  ELSE 
+     sign := " "; 
+     x := n;
+  END;
+  l := 0;
+  REPEAT
+    d := x MOD 10; 
+    x := x DIV 10;
+    INC(l); 
+    t[l] := CHR(ORD("0") + d);
+  UNTIL x = 0;
+  IF wid = 0 THEN 
+    Write(f, " ") 
+  END;
+  WHILE wid > l + 1 DO 
+    Write(f, " "); 
+    DEC(wid); 
+  END;
+  IF (sign = "-") OR (wid > l) THEN 
+    Write(f, sign); 
+  END;
+  WHILE l > 0 DO 
+    Write(f, t[l]); 
+    DEC(l); 
+  END;   
+END WriteInt;
+
+PROCEDURE WriteCard (f: File; n, wid: CARDINAL);
+(* Writes a CARDINAL card into a field of wid characters width.
+   If the number does not fit into wid characters, wid is expanded.
+   If wid = 0, exactly one leading space is introduced. *)
+   
+VAR
+  l, d: CARDINAL;
+  t: ARRAY [1 .. 25] OF CHAR;
+  
+BEGIN
+  IF NotWrite(f) THEN 
+    Okay := FALSE; 
+    RETURN 
+  END;
+  l := 0;
+  REPEAT
+    d := n MOD 10; 
+    n := n DIV 10;
+    INC(l); t[l] := CHR(ORD("0") + d);
+  UNTIL n = 0;
+  IF wid = 0 THEN 
+    Write(f, " ") 
+  END;
+  WHILE wid > l DO
+    Write(f, " "); 
+    DEC(wid); 
+  END;
+  WHILE l > 0 DO 
+    Write(f, t[l]); 
+    DEC(l);
+  END;
+END WriteCard;
+
+PROCEDURE WriteBytes (f: File; VAR buf: ARRAY OF SYSTEM.BYTE; len: CARDINAL);
+(* Writes len bytes from buf to f at the current file position. *)
+
+(* The following procedures are not currently used by Coco, and may be
+   safely omitted, or implemented as null procedures.  They might be
+   useful in measuring performance. *)
+   (*PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL;
+                       src: ADDRESS) : CARDINAL ;*)
+VAR
+  TooMany: BOOLEAN;
+  number : CARDINAL;
+  
+BEGIN
+  TooMany := (len > 0) & (len - 1 > HIGH(buf));
+  IF NotWrite(f) OR (File(f) = con) OR (File(f) = err) THEN
+    Okay := FALSE
+  ELSE
+    IF TooMany THEN 
+      len := HIGH(buf) + 1 
+    END;
+    number := FIO.WriteNBytes(f^.ref, len, SYSTEM.ADR(buf));
+    Okay := FIO.IsNoError(f^.ref) = TRUE;
+    Okay := number = len;
+  END;
+  IF TooMany THEN 
+    Okay := FALSE 
+  END;
+END WriteBytes;
+
+PROCEDURE Write2 (f: File; i: CARDINAL);
+  BEGIN
+    Write(f, CHR(i DIV 10 + ORD("0")));
+    Write(f, CHR(i MOD 10 + ORD("0")));
+  END Write2;
+
+PROCEDURE WriteDate (f: File);
+(* Write current date DD/MM/YYYY to file f. *)
+
+VAR
+    Year, Month, Day: CARDINAL;
+    
+BEGIN 
+   IF NotWrite(f) THEN Okay := FALSE; RETURN END;
+    SysClock.GetClock(theTime);
+    WITH theTime DO 
+      Write2(f, day); 
+      Write(f, "/"); 
+      Write2(f, month); 
+      Write(f, "/");
+      WriteCard(f, year, 1)
+    END;
+END WriteDate;
+
+PROCEDURE WriteTime (f: File);
+(* Write time HH:MM:SS to file f. *)
+ (*
+ PROCEDURE GetClock(VAR userData: DateTime);
+(* Assigns local date and time of the day to userData *)
+
+ *)
+VAR 
+  theTimeString : ARRAY[0..40] OF CHAR;
+  yearStr, monthStr, dayStr : ARRAY[0..12] OF CHAR;
+ 
+BEGIN 
+  IF NotWrite(f) THEN
+    Okay := FALSE; 
+    RETURN 
+  END;
+  SysClock.GetClock(theTime);
+  WITH theTime DO 
+    Write2(f, hour); 
+    Write(f, ":"); 
+    Write2(f, minute); 
+    Write(f, ":");
+    Write2(f, second)
+  END;
+END WriteTime;
+
+(***************************************************)
+
+VAR
+  Hrs0, Mins0, Secs0, Hsecs0: CARDINAL;
+  Hrs1, Mins1, Secs1, Hsecs1: CARDINAL;
+
+PROCEDURE WriteElapsedTime (f: File);
+(* Write elapsed time in seconds since last call of this procedure. *)
+
+VAR
+    theTimeNow : SysClock.DateTime;
+    Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+    
+BEGIN
+  IF NotWrite(f) THEN 
+    Okay := FALSE; 
+    RETURN 
+  END;
+    SysClock.GetClock(theTimeNow);
+    WITH theTimeNow DO 
+      Hrs   := hour;
+      Mins  := minute;
+      Secs  := second;
+      Hsecs := fractions;
+    END;
+    WriteString(f, "Elapsed time: ");
+    IF Hrs >= Hrs1
+      THEN s := (Hrs - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+      ELSE s := (Hrs + 24 - Hrs1) * 3600 + (Mins - Mins1) * 60 + Secs - Secs1
+    END;
+    IF Hsecs >= Hsecs1
+      THEN hs := Hsecs - Hsecs1
+      ELSE hs := (Hsecs + 100) - Hsecs1; DEC(s);
+    END;
+    (** Updating**)
+    WriteCard(f, s, 1); 
+    Write(f, ".");
+    Write2(f, hs); 
+    WriteString(f, " s"); 
+    WriteLn(f);
+    (** Writing to file**)
+    Hrs1 := Hrs; 
+    Mins1 := Mins; 
+    Secs1 := Secs; 
+    Hsecs1 := Hsecs;
+END WriteElapsedTime;
+
+PROCEDURE WriteExecutionTime (f: File);
+(* Write total execution time in seconds thus far to file f. *)
+   
+VAR
+  theTimeNow : SysClock.DateTime;
+  Hrs, Mins, Secs, Hsecs, s, hs: CARDINAL;
+  
+BEGIN
+    IF NotWrite(f) THEN 
+      Okay := FALSE; 
+      RETURN 
+    END;
+    SysClock.GetClock(theTimeNow);
+    WITH theTimeNow DO 
+      Hrs   := hour;
+      Mins  := minute;
+      Secs  := second;
+      Hsecs := fractions;
+    END;
+    WriteString(f, "Execution time: ");
+    IF Hrs >= Hrs0
+      THEN s := (Hrs - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+      ELSE s := (Hrs + 24 - Hrs0) * 3600 + (Mins - Mins0) * 60 + Secs - Secs0
+    END;
+    IF Hsecs >= Hsecs0
+      THEN hs := Hsecs - Hsecs0
+      ELSE hs := (Hsecs + 100) - Hsecs0; DEC(s);
+    END;
+    WriteCard(f, s, 1); 
+    Write(f, "."); 
+    Write2(f, hs);
+    WriteString(f, " s"); 
+    WriteLn(f);
+END WriteExecutionTime;
+
+(***************************************************)
+
+
+
+PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;
+(* Returns number of characters in stringVal, not including nul *)
+   
+BEGIN 
+  RETURN LENGTH(stringVal)
+END SLENGTH;
+
+PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+(* Copies as much of source to destination as possible, truncating if too
+   long, and nul terminating if shorter.
+   Be careful - some libraries have the parameters reversed! *)
+ (*  
+   PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+(* Copies source to destination *)
+*)
+
+BEGIN 
+  Strings.Assign(source, destination)
+END Assign;
+
+PROCEDURE Extract (source: ARRAY OF CHAR;
+                   startIndex, numberToExtract: CARDINAL;
+                   VAR destination: ARRAY OF CHAR);
+   
+BEGIN 
+  Strings.Extract(source, startIndex, numberToExtract, destination)
+END Extract;
+
+PROCEDURE Concat (stringVal1, stringVal2: ARRAY OF CHAR;
+                  VAR destination: ARRAY OF CHAR);
+(* Concatenates stringVal1 and stringVal2 to form destination.
+   Nul terminated if concatenation is short enough, truncated if it is
+   too long *)
+
+(*PROCEDURE Concat (source1, source2: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
+(* Concatenates source2 onto source1 and copies the result into destination. *)
+*)
+   
+BEGIN 
+  Strings.Concat(stringVal1,stringVal2,destination)
+END Concat;
+
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;
+ 
+(* Returns -1, 0, 1 depending whether stringVal1 < = > stringVal2.
+   This is not directly ISO compatible *)
+(*   
+TYPE
+  CompareResults = (less, equal, greater);
+  
+PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): CompareResults;
+  (* Returns less, equal, or greater, according as stringVal1 is lexically less than,
+  equal to, or greater than stringVal2.
+  *)
+  
+*)   
+BEGIN 
+  CASE Strings.Compare( stringVal1, stringVal2 ) OF 
+    Strings.less : RETURN -1;   |
+    Strings.equal : RETURN 0;   |
+    Strings.greater : RETURN 1; |
+  END;  
+END Compare;
+
+(***************************************************)
+
+
+(* The following routines are for conversions to and from the INT32 type.
+   Their names are modelled after the ISO pervasive routines that would
+   achieve the same end.  Where possible, replacing calls to these routines
+   by the pervasives would improve performance markedly.  As used in Coco,
+   these routines should not give range problems. *)
+
+PROCEDURE ORDL (n: INT32): CARDINAL;
+(* Convert long integer n to corresponding (short) cardinal value.
+   Potentially FileIO.ORDL(n) = VAL(CARDINAL, n) *)
+   
+BEGIN 
+ RETURN VAL(CARDINAL, n)
+END ORDL;
+
+PROCEDURE INTL (n: INT32): INTEGER;
+(* Convert long integer n to corresponding short integer value.
+   Potentially FileIO.INTL(n) = VAL(INTEGER, n) *)
+   
+BEGIN 
+ RETURN VAL(INTEGER, n)
+END INTL;
+
+PROCEDURE INT (n: CARDINAL): INT32;
+   
+BEGIN 
+ RETURN VAL(INT32, n)
+END INT;
+
+PROCEDURE QuitExecution;
+   
+BEGIN 
+  HALT;
+END QuitExecution;
+
+BEGIN 
+  SysClock.GetClock(theTime);
+  WITH theTime DO 
+    Hrs0   := hour;
+    Mins0  := minute;
+    Secs0  := second;
+    Hsecs0 := fractions;
+    Hrs1 := Hrs0; Mins1 := Mins0; Secs1 := Secs0; Hsecs1 := Hsecs0;
+  END;
+END FileIO.

FileName.def

@@ -0,0 +1,30 @@
+DEFINITION MODULE FileName; 
+
+(* File name procedures.
+   File name consists of three parts:
+        - path
+        - name
+        - extensions.
+*)
+
+TYPE
+  Format = RECORD
+    ok: BOOLEAN;               (* result *)
+    dirPos, dirLen : CARDINAL; (* directory position and length *)
+    namePos,nameLen: CARDINAL; (* name position and length *)
+    extPos, extLen : CARDINAL; (* extension position and length *)
+  END;
+
+(*----------------------------------------------------------------*)
+
+PROCEDURE Get(fname: ARRAY OF CHAR; VAR dir,name,ext: ARRAY OF CHAR);
+
+(*----------------------------------------------------------------*)
+
+PROCEDURE GetDir (fname: ARRAY OF CHAR; VAR dir: ARRAY OF CHAR);
+PROCEDURE GetName(fname: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
+PROCEDURE GetExt (fname: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
+
+(*----------------------------------------------------------------*)
+
+END FileName.

FileName.mod

@@ -0,0 +1,66 @@
+IMPLEMENTATION MODULE FileName; 
+
+IMPORT  InOut, Strings;
+
+(*----------------------------------------------------------------*)
+
+PROCEDURE Get(fname: ARRAY OF CHAR; VAR dir,name,ext: ARRAY OF CHAR);
+
+VAR 
+  LocalFname : Format;
+  L          : CARDINAL;
+  save       : CARDINAL;
+  
+BEGIN
+  L := LENGTH(fname);
+  save := L;
+   (* separating the dir part from the filename+ext part *)
+  REPEAT 
+    DEC(save);
+    IF fname[save] = "." THEN
+     LocalFname.extPos := save + 1;
+     LocalFname.extLen := L - LocalFname.extPos ;
+   END; 
+  UNTIL fname[save] = "/";
+  LocalFname.namePos := save + 1;
+  LocalFname.nameLen := LocalFname.extPos - LocalFname.namePos -1;
+  (* now, directory part *)
+  LocalFname.dirPos := 0;
+  LocalFname.dirLen := save + 1;
+  (* PROCEDURE Extract (source: ARRAY OF CHAR; startIndex, numberToExtract: CARDINAL; VAR destination: ARRAY OF CHAR);  *)
+  Strings.Extract(fname,LocalFname.namePos, LocalFname.nameLen,name);
+  Strings.Extract(fname,LocalFname.dirPos, LocalFname.dirLen,dir);
+  Strings.Extract(fname,LocalFname.extPos, LocalFname.extLen,ext);
+END Get;
+
+
+PROCEDURE GetDir(fname: ARRAY OF CHAR; VAR dir: ARRAY OF CHAR);
+
+VAR
+  Dir, Name, Ext : ARRAY[0..256] OF CHAR;
+
+BEGIN
+  Get(fname,Dir,Name,Ext);
+  Strings.Assign(Dir,dir);
+END GetDir;
+
+PROCEDURE GetName(fname: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
+
+VAR
+  Dir, Name, Ext : ARRAY[0..256] OF CHAR;
+  
+BEGIN
+  Get(fname,Dir,Name,Ext);
+  Strings.Assign(Name, name);
+END GetName;
+
+PROCEDURE GetExt(fname: ARRAY OF CHAR; VAR ext: ARRAY OF CHAR);
+
+VAR
+  Dir, Name, Ext : ARRAY[0..256] OF CHAR;
+BEGIN
+  Get(fname,Dir,Name,Ext);
+  Strings.Assign(Ext,ext);
+END GetExt;
+
+END FileName.

Libs/FIO.def

@@ -0,0 +1,373 @@
+(* FIO.def provides a simple buffered file input/output library.
+
+Copyright (C) 2001-2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  *)
+
+DEFINITION MODULE FIO ;
+
+(* Provides a simple buffered file input/output library.  *)
+
+
+FROM SYSTEM IMPORT ADDRESS, BYTE ;
+
+EXPORT QUALIFIED (* types *)
+                 File,
+                 (* procedures *)
+                 OpenToRead, OpenToWrite, OpenForRandom, Close, Unlink, Delete,
+                 EOF, EOLN, WasEOLN, IsNoError, Exists, IsActive,
+                 exists, openToRead, openToWrite, openForRandom,
+                 SetPositionFromBeginning,
+                 SetPositionFromEnd,
+                 FindPosition,
+                 ReadChar, ReadString,
+                 WriteChar, WriteString, WriteLine,
+                 WriteCardinal, ReadCardinal,
+                 UnReadChar,
+                 WriteNBytes, ReadNBytes,
+                 FlushBuffer,
+                 GetUnixFileDescriptor,
+                 GetFileName, getFileName, getFileNameLength,GetFDesc,
+                 FlushOutErr,
+                 (* variables *)
+                 StdIn, StdOut, StdErr ;
+
+TYPE
+   File = CARDINAL ;
+
+(* the following variables are initialized to their UNIX equivalents *)
+VAR
+   StdIn, StdOut, StdErr: File ;
+
+
+
+(*
+   IsNoError - returns a TRUE if no error has occured on file, f.
+*)
+
+PROCEDURE IsNoError (f: File) : BOOLEAN ;
+
+
+(*
+   IsActive - returns TRUE if the file, f, is still active.
+*)
+
+PROCEDURE IsActive (f: File) : BOOLEAN ;
+
+
+(*
+   Exists - returns TRUE if a file named, fname exists for reading.
+*)
+
+PROCEDURE Exists (fname: ARRAY OF CHAR) : BOOLEAN ;
+
+
+(*
+   OpenToRead - attempts to open a file, fname, for reading and
+                it returns this file.
+                The success of this operation can be checked by
+                calling IsNoError.
+*)
+
+PROCEDURE OpenToRead (fname: ARRAY OF CHAR) : File ;
+
+
+(*
+   OpenToWrite - attempts to open a file, fname, for write and
+                 it returns this file.
+                 The success of this operation can be checked by
+                 calling IsNoError.
+*)
+
+PROCEDURE OpenToWrite (fname: ARRAY OF CHAR) : File ;
+
+
+(*
+   OpenForRandom - attempts to open a file, fname, for random access
+                   read or write and it returns this file.
+                   The success of this operation can be checked by
+                   calling IsNoError.
+                   towrite, determines whether the file should be
+                   opened for writing or reading.
+                   newfile, determines whether a file should be
+                   created if towrite is TRUE or whether the
+                   previous file should be left alone,
+                   allowing this descriptor to seek
+                   and modify an existing file.
+*)
+
+PROCEDURE OpenForRandom (fname: ARRAY OF CHAR;
+                         towrite, newfile: BOOLEAN) : File ;
+
+(*
+   Unlink - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Unlink ( f : File );
+
+
+(*
+   Delete - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Delete (fname: ARRAY OF CHAR ) ;
+
+(*
+   Close - close a file which has been previously opened using:
+           OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Close (f: File) ;
+
+
+
+(*************************************************************************)
+
+(* the following functions are functionally equivalent to the above
+   except they allow C style names.
+*)
+
+PROCEDURE exists        (fname: ADDRESS; flength: CARDINAL) : BOOLEAN ;
+PROCEDURE openToRead    (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openToWrite   (fname: ADDRESS; flength: CARDINAL) : File ;
+PROCEDURE openForRandom (fname: ADDRESS; flength: CARDINAL;
+                         towrite, newfile: BOOLEAN) : File ;
+
+(*************************************************************************)
+
+(*
+   FlushBuffer - flush contents of the FIO file, f, to libc.
+*)
+
+PROCEDURE FlushBuffer (f: File) ;
+
+
+(*
+   ReadNBytes - reads nBytes of a file into memory area, dest, returning
+                the number of bytes actually read.
+                This function will consume from the buffer and then
+                perform direct libc reads. It is ideal for large reads.
+*)
+
+PROCEDURE ReadNBytes (f: File; nBytes: CARDINAL;
+                      dest: ADDRESS) : CARDINAL ;
+
+
+(*
+   ReadAny - reads HIGH (a) + 1 bytes into, a.  All input
+             is fully buffered, unlike ReadNBytes and thus is more
+             suited to small reads.
+*)
+
+PROCEDURE ReadAny (f: File; VAR a: ARRAY OF BYTE) ;
+
+
+(*
+   WriteNBytes - writes nBytes from memory area src to a file
+                 returning the number of bytes actually written.
+                 This function will flush the buffer and then
+                 write the nBytes using a direct write from libc.
+                 It is ideal for large writes.
+*)
+
+PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL;
+                       src: ADDRESS) : CARDINAL ;
+
+
+(*
+   WriteAny - writes HIGH (a) + 1 bytes onto, file, f.  All output
+              is fully buffered, unlike WriteNBytes and thus is more
+              suited to small writes.
+*)
+
+PROCEDURE WriteAny (f: File; VAR a: ARRAY OF BYTE) ;
+
+
+(*
+   WriteChar - writes a single character to file, f.
+*)
+
+PROCEDURE WriteChar (f: File; ch: CHAR) ;
+
+
+(*
+   EOF - tests to see whether a file, f, has reached end of file.
+*)
+
+PROCEDURE EOF (f: File) : BOOLEAN ;
+
+
+(*
+   EOLN - tests to see whether a file, f, is about to read a newline.
+          It does NOT consume the newline.  It reads the next character
+          and then immediately unreads the character.
+*)
+
+PROCEDURE EOLN (f: File) : BOOLEAN ;
+
+
+(*
+   WasEOLN - tests to see whether a file, f, has just read a newline
+             character.
+*)
+
+PROCEDURE WasEOLN (f: File) : BOOLEAN ;
+
+
+(*
+   ReadChar - returns a character read from file, f.
+              Sensible to check with IsNoError or EOF after calling
+              this function.
+*)
+
+PROCEDURE ReadChar (f: File) : CHAR ;
+
+
+(*
+   UnReadChar - replaces a character, ch, back into file, f.
+                This character must have been read by ReadChar
+                and it does not allow successive calls.  It may
+                only be called if the previous read was successful,
+                end of file or end of line seen.
+*)
+
+PROCEDURE UnReadChar (f: File ; ch: CHAR) ;
+
+
+(*
+   WriteLine - writes out a linefeed to file, f.
+*)
+
+PROCEDURE WriteLine (f: File) ;
+
+
+(*
+   WriteString - writes a string to file, f.
+*)
+
+PROCEDURE WriteString (f: File; a: ARRAY OF CHAR) ;
+
+
+(*
+   ReadString - reads a string from file, f, into string, a.
+                It terminates the string if HIGH is reached or
+                if a newline is seen or an error occurs.
+*)
+
+PROCEDURE ReadString (f: File; VAR a: ARRAY OF CHAR) ;
+
+
+(*
+   WriteCardinal - writes a CARDINAL to file, f.
+                   It writes the binary image of the CARDINAL.
+                   to file, f.
+*)
+
+PROCEDURE WriteCardinal (f: File; c: CARDINAL) ;
+
+
+(*
+   ReadCardinal - reads a CARDINAL from file, f.
+                  It reads a bit image of a CARDINAL
+                  from file, f.
+*)
+
+PROCEDURE ReadCardinal (f: File) : CARDINAL ;
+
+
+(*
+   GetUnixFileDescriptor - returns the UNIX file descriptor of a file.
+                           Useful when combining FIO.mod with select
+                           (in Selective.def - but note the comments in
+                            Selective about using read/write primatives)
+*)
+
+PROCEDURE GetUnixFileDescriptor (f: File) : INTEGER ;
+
+
+(*
+   SetPositionFromBeginning - sets the position from the beginning
+                              of the file.
+*)
+
+PROCEDURE SetPositionFromBeginning (f: File; pos: LONGINT) ;
+
+
+(*
+   SetPositionFromEnd - sets the position from the end of the file.
+*)
+
+PROCEDURE SetPositionFromEnd (f: File; pos: LONGINT) ;
+
+
+(*
+   FindPosition - returns the current absolute position in file, f.
+*)
+
+PROCEDURE FindPosition (f: File) : LONGINT ;
+
+(*
+   GetFDesc - return the file descriptor associated with File name,  fname
+*)
+
+
+PROCEDURE GetFDesc (fname : ARRAY OF CHAR ) : File;
+
+(*
+   GetFileName - assigns, a, with the filename associated with, f.
+*)
+
+PROCEDURE GetFileName (f: File; VAR a: ARRAY OF CHAR) ;
+
+
+(**********************************************************************)
+
+(* here ADDRESS is a PONITER TO CHAR like in the C lib *)
+(*
+   getFileName - returns the address of the filename associated with, f.
+*)
+
+PROCEDURE getFileName (f: File) : ADDRESS ;
+
+
+(*
+   getFileNameLength - returns the number of characters associated with
+                       filename, f.
+*)
+
+PROCEDURE getFileNameLength (f: File) : CARDINAL ;
+
+(**********************************************************************)
+
+(*
+   FlushOutErr - flushes, StdOut, and, StdErr.
+*)
+
+PROCEDURE FlushOutErr ;
+
+
+END FIO.

Libs/FIO.mod

@@ -0,0 +1,1761 @@
+(* FIO.mod provides a simple buffered file input/output library.
+
+Copyright (C) 2001-2025 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+GNU Modula-2 is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  *)
+
+IMPLEMENTATION MODULE FIO ;
+
+(*
+    Title      : FIO
+    Author     : Gaius Mulley
+    System     : UNIX (gm2)
+    Date       : Thu Sep  2 22:07:21 1999
+    Last edit  : Thu Sep  2 22:07:21 1999
+    Description: a complete reimplememtation of FIO.mod
+                 provides a simple buffered file input/output library.
+*)
+
+IMPORT Strings;
+FROM SYSTEM IMPORT ADR, TSIZE, WORD, COFF_T ;
+FROM ASCII IMPORT nl, nul, tab ;
+FROM StrLib IMPORT StrLen, StrConCat, StrCopy ;
+FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
+FROM NumberIO IMPORT CardToStr ;
+FROM Indexing IMPORT Index, InitIndex, InBounds, HighIndice, LowIndice, PutIndice, GetIndice ;
+FROM M2RTS IMPORT InstallTerminationProcedure ;
+FROM libc IMPORT exit, open, creat, read, write, close, lseek, strncpy, memcpy, unlink ;
+FROM wrapc IMPORT SeekSet, SeekEnd, ReadOnly, WriteOnly ;
+
+
+CONST
+   MaxBufferLength     = 1024*16 ;
+   MaxErrorString      = 1024* 8 ;
+   CreatePermissions   =     666B;
+
+TYPE
+   FileUsage         = (unused, openedforread, openedforwrite, openedforrandom) ;
+   FileStatus        = (successful, outofmemory, toomanyfilesopen, failed, connectionfailure, endofline, endoffile) ;
+
+   NameInfo          = RECORD
+                          address: ADDRESS ;
+                          size   : CARDINAL ;
+                       END ;
+
+   Buffer            = POINTER TO buf ;
+   buf               =            RECORD
+                                     valid   : BOOLEAN ;   (* are the field valid?             *)
+                                     bufstart: LONGINT ;   (* the position of buffer in file   *)
+                                     position: CARDINAL ;  (* where are we through this buffer *)
+                                     address : ADDRESS ;   (* dynamic buffer address           *)
+                                     filled  : CARDINAL ;  (* length of the buffer filled      *)
+                                     size    : CARDINAL ;  (* maximum space in this buffer     *)
+                                     left    : CARDINAL ;  (* number of bytes left to read     *)
+                                     contents: POINTER TO ARRAY [0..MaxBufferLength] OF CHAR ;
+                                  END ;
+
+   FileDescriptor   = POINTER TO fds ;
+   fds               =            RECORD
+                                     unixfd: INTEGER ;
+                                     name  : NameInfo ;
+                                     state : FileStatus ;
+                                     usage : FileUsage ;
+                                     output: BOOLEAN ;     (* is this file going to write data *)
+                                     buffer: Buffer ;
+                                     abspos: LONGINT ;     (* absolute position into file.     *)
+                                  END ;                    (* reflects low level reads which   *)
+                                                           (* means this value will normally   *)
+                                                           (* be further through the file than *)
+                                                           (* bufstart above.                  *)
+   PtrToChar         = POINTER TO CHAR ;
+
+
+VAR
+   FileInfo: Index ;
+   Error   : File ;   (* not stderr, this is an unused file handle
+                         which only serves to hold status values
+                         when we cannot create a new file handle *)
+
+
+(*
+   GetUnixFileDescriptor - returns the UNIX file descriptor of a file.
+*)
+
+PROCEDURE GetUnixFileDescriptor (f: File) : INTEGER ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         RETURN( fd^.unixfd )
+      END
+   END ;
+   FormatError1('file %d has not been opened or is out of range\n', f) ;
+   RETURN( -1 )
+END GetUnixFileDescriptor ;
+
+
+(*
+   WriteString - writes a string to file, f.
+*)
+
+PROCEDURE WriteString (f: File; a: ARRAY OF CHAR) ;
+VAR
+   l: CARDINAL ;
+BEGIN
+   l := StrLen(a) ;
+   IF WriteNBytes(f, l, ADR(a))#l
+   THEN
+   END
+END WriteString ;
+
+
+(*
+   Max - returns the maximum of two values.
+*)
+
+PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
+BEGIN
+   IF a>b
+   THEN
+      RETURN( a )
+   ELSE
+      RETURN( b )
+   END
+END Max ;
+
+
+(*
+   Min - returns the minimum of two values.
+*)
+
+PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
+BEGIN
+   IF a<b
+   THEN
+      RETURN( a )
+   ELSE
+      RETURN( b )
+   END
+END Min ;
+
+
+(*
+   GetNextFreeDescriptor - returns the index to the FileInfo array indicating
+                           the next free slot.
+*)
+
+PROCEDURE GetNextFreeDescriptor () : File ;
+VAR
+   f, h: File ;
+   fd  : FileDescriptor ;
+BEGIN
+   f := Error+1 ;
+   h := HighIndice(FileInfo) ;
+   LOOP
+      IF f<=h
+      THEN
+         fd := GetIndice(FileInfo, f) ;
+         IF fd=NIL
+         THEN
+            RETURN( f )
+         END
+      END ;
+      INC(f) ;
+      IF f>h
+      THEN
+         PutIndice(FileInfo, f, NIL) ;  (* create new slot *)
+         RETURN( f )
+      END
+   END
+END GetNextFreeDescriptor ;
+
+
+(*
+   IsNoError - returns a TRUE if no error has occured on file, f.
+*)
+
+PROCEDURE IsNoError (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f=Error
+   THEN
+      RETURN( FALSE )
+   ELSE
+      fd := GetIndice(FileInfo, f) ;
+      RETURN( (fd#NIL) AND ((fd^.state=successful) OR (fd^.state=endoffile) OR (fd^.state=endofline)) )
+   END
+END IsNoError ;
+
+
+(*
+   IsActive - returns TRUE if the file, f, is still active.
+*)
+
+PROCEDURE IsActive (f: File) : BOOLEAN ;
+BEGIN
+   IF f=Error
+   THEN
+      RETURN( FALSE )
+   ELSE
+      RETURN( GetIndice(FileInfo, f)#NIL )
+   END
+END IsActive ;
+
+
+(*
+   openToRead - attempts to open a file, fname, for reading and
+                it returns this file.
+                The success of this operation can be checked by
+                calling IsNoError.
+*)
+
+PROCEDURE openToRead (fname: ADDRESS; flength: CARDINAL) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforread, FALSE, MaxBufferLength) ;
+      ConnectToUnix(f, FALSE, FALSE)
+   END ;
+   RETURN( f )
+END openToRead ;
+
+
+(*
+   openToWrite - attempts to open a file, fname, for write and
+                 it returns this file.
+                 The success of this operation can be checked by
+                 calling IsNoError.
+*)
+
+PROCEDURE openToWrite (fname: ADDRESS; flength: CARDINAL) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforwrite, TRUE, MaxBufferLength) ;
+      ConnectToUnix(f, TRUE, TRUE)
+   END ;
+   RETURN( f )
+END openToWrite ;
+
+
+(*
+   openForRandom - attempts to open a file, fname, for random access
+                   read or write and it returns this file.
+                   The success of this operation can be checked by
+                   calling IsNoError.
+                   towrite, determines whether the file should be
+                   opened for writing or reading.
+*)
+
+PROCEDURE openForRandom (fname: ADDRESS; flength: CARDINAL;
+                         towrite, newfile: BOOLEAN) : File ;
+VAR
+   f: File ;
+BEGIN
+   f := GetNextFreeDescriptor() ;
+   IF f=Error
+   THEN
+      SetState(f, toomanyfilesopen)
+   ELSE
+      f := InitializeFile(f, fname, flength, successful, openedforrandom, towrite, MaxBufferLength) ;
+      ConnectToUnix(f, towrite, newfile)
+   END ;
+   RETURN( f )
+END openForRandom ;
+
+
+(*
+   exists - returns TRUE if a file named, fname exists for reading.
+*)
+
+PROCEDURE exists (fname: ADDRESS; flength: CARDINAL) : BOOLEAN ;
+VAR
+   f: File ;
+BEGIN
+   f := openToRead(fname, flength) ;
+   IF IsNoError(f)
+   THEN
+      Close(f) ;
+      RETURN( TRUE )
+   ELSE
+      Close(f) ;
+      RETURN( FALSE )
+   END
+END exists ;
+
+
+(*
+   SetState - sets the field, state, of file, f, to, s.
+*)
+
+PROCEDURE SetState (f: File; s: FileStatus) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   fd := GetIndice(FileInfo, f) ;
+   fd^.state := s
+END SetState ;
+
+
+(*
+   InitializeFile - initialize a file descriptor
+*)
+
+PROCEDURE InitializeFile (f: File; fname: ADDRESS;
+                          flength: CARDINAL; fstate: FileStatus;
+                          use: FileUsage;
+                          towrite: BOOLEAN; buflength: CARDINAL) : File ;
+VAR
+   p : PtrToChar ;
+   fd: FileDescriptor ;
+BEGIN
+   NEW(fd) ;
+   IF fd=NIL
+   THEN
+      SetState(Error, outofmemory) ;
+      RETURN( Error )
+   ELSE
+      PutIndice(FileInfo, f, fd) ;
+      WITH fd^ DO
+         name.size := flength+1 ;  (* need to guarantee the nul for C *)
+         usage     := use ;
+         output    := towrite ;
+         ALLOCATE(name.address, name.size) ;
+         IF name.address=NIL
+         THEN
+            state := outofmemory ;
+            RETURN( f )
+         END ;
+         name.address := strncpy(name.address, fname, flength) ;
+         (* and assign nul to the last byte *)
+         p := name.address ;
+         INC(p, flength) ;
+         p^ := nul ;
+         abspos := 0 ;
+         (* now for the buffer *)
+         NEW(buffer) ;
+         IF buffer=NIL
+         THEN
+            SetState(Error, outofmemory) ;
+            RETURN( Error )
+         ELSE
+            WITH buffer^ DO
+               valid    := FALSE ;
+               bufstart := 0 ;
+               size     := buflength ;
+               position := 0 ;
+               filled   := 0 ;
+               IF size=0
+               THEN
+                  address := NIL
+               ELSE
+                  ALLOCATE(address, size) ;
+                  IF address=NIL
+                  THEN
+                     state := outofmemory ;
+                     RETURN( f )
+                  END
+               END ;
+               IF towrite
+               THEN
+                  left := size
+               ELSE
+                  left := 0
+               END ;
+               contents := address ;  (* provides easy access for reading characters *)
+            END ;
+            state := fstate
+         END
+      END
+   END ;
+   RETURN( f )
+END InitializeFile ;
+
+(*
+   ConnectToUnix - connects a FIO file to a UNIX file descriptor.
+*)
+
+PROCEDURE ConnectToUnix (f: File; towrite, newfile: BOOLEAN) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF towrite
+            THEN
+               IF newfile
+               THEN
+                  unixfd := creat(name.address, CreatePermissions)
+               ELSE
+                  unixfd := open(name.address, INTEGER (WriteOnly ()), 0)
+               END
+            ELSE
+               unixfd := open(name.address, INTEGER (ReadOnly ()), 0)
+            END ;
+            IF unixfd<0
+            THEN
+               state := connectionfailure
+            END
+         END
+      END
+   END
+END ConnectToUnix ;
+
+
+(*
+   The following functions are wrappers for the above.
+*)
+
+PROCEDURE Exists (fname: ARRAY OF CHAR) : BOOLEAN ;
+BEGIN
+   RETURN( exists(ADR(fname), StrLen(fname)) )
+END Exists ;
+
+
+PROCEDURE OpenToRead (fname: ARRAY OF CHAR) : File ;
+BEGIN
+   RETURN( openToRead(ADR(fname), StrLen(fname)) )
+END OpenToRead ;
+
+
+PROCEDURE OpenToWrite (fname: ARRAY OF CHAR) : File ;
+BEGIN
+   RETURN( openToWrite(ADR(fname), StrLen(fname)) )
+END OpenToWrite ;
+
+
+PROCEDURE OpenForRandom (fname: ARRAY OF CHAR;
+                         towrite: BOOLEAN; newfile: BOOLEAN) : File ;
+BEGIN
+   RETURN( openForRandom(ADR(fname), StrLen(fname), towrite, newfile) )
+END OpenForRandom ;
+
+(*
+   Close - close a file which has been previously opened using:
+           OpenToRead, OpenToWrite, OpenForRandom.
+           It is correct to close a file which has an error status.
+*)
+
+PROCEDURE Close (f: File) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      (*
+         we allow users to close files which have an error status
+      *)
+      IF fd#NIL
+      THEN
+         FlushBuffer(f) ;
+         WITH fd^ DO
+            IF unixfd>=0
+            THEN
+               IF close(unixfd)#0
+               THEN
+                  FormatError1('failed to close file (%s)\n', name.address) ;
+                  state := failed   (* --fixme-- too late to notify user (unless we return a BOOLEAN) *)
+               END
+            END ;
+            IF name.address#NIL
+            THEN
+               DEALLOCATE(name.address, name.size)
+            END ;
+            IF buffer#NIL
+            THEN
+               WITH buffer^ DO
+                  IF address#NIL
+                  THEN
+                     DEALLOCATE(address, size)
+                  END
+               END ;
+               DISPOSE(buffer) ;
+               buffer := NIL
+            END
+         END ;
+         DISPOSE(fd) ;
+         PutIndice(FileInfo, f, NIL)
+      END
+   END
+END Close ;
+
+(*
+   Unlink - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Unlink ( f : File );
+
+VAR
+   fname: ARRAY[0..256] OF CHAR ;
+
+BEGIN
+  GetFileName(f,fname);
+  fd := GetIndice(FileInfo, f) ;
+  Close(f);
+  unlink(ADR(fname));
+END Unlink;
+
+(*
+   Delete - Delete a file which has been opened using 
+          OpenToRead, OpenToWrite, OpenForRandom.
+*)
+
+PROCEDURE Delete (fname: ARRAY OF CHAR ) ;
+
+VAR
+   fd: FileDescriptor ;
+     
+BEGIN
+  fd := GetFDesc(fname);
+  IF fd # NIL THEN 
+    Close(fd);
+    (*Unlink(ADR(fname));*)     
+  END;
+END Delete;
+
+(*
+   ReadFromBuffer - attempts to read, nBytes, from file, f.
+                    It firstly consumes the buffer and then performs
+                    direct unbuffered reads. This should only be used
+                    when wishing to read large files.
+
+                    The actual number of bytes read is returned.
+                    -1 is returned if EOF is reached.
+*)
+
+PROCEDURE ReadFromBuffer (f: File; a: ADDRESS; nBytes: CARDINAL) : INTEGER ;
+VAR
+   t     : ADDRESS ;
+   result: INTEGER ;
+   total,
+   n     : CARDINAL ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      total := 0 ;   (* how many bytes have we read *)
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         (* extract from the buffer first *)
+         IF (buffer#NIL) AND (buffer^.valid)
+         THEN
+            WITH buffer^ DO
+               IF left>0
+               THEN
+                  IF nBytes=1
+                  THEN
+                     (* too expensive to call memcpy for 1 character *)
+                     p := a ;
+                     p^ := contents^[position] ;
+                     DEC(left) ;         (* remove consumed bytes               *)
+                     INC(position) ;     (* move onwards n bytes                *)
+                     nBytes := 0 ;       (* reduce the amount for future direct *)
+                                         (* read                                *)
+                     RETURN( 1 )
+                  ELSE
+                     n := Min(left, nBytes) ;
+                     t := address ;
+                     INC(t, position) ;
+                     p := memcpy(a, t, n) ;
+                     DEC(left, n) ;      (* remove consumed bytes               *)
+                     INC(position, n) ;  (* move onwards n bytes                *)
+                                         (* move onwards ready for direct reads *)
+                     INC(a, n) ;
+                     DEC(nBytes, n) ;    (* reduce the amount for future direct *)
+                                         (* read                                *)
+                     INC(total, n) ;
+                     RETURN( total )     (* much cleaner to return now,         *)
+                  END                    (* difficult to record an error if     *)
+               END                       (* the read below returns -1           *)
+            END
+         END ;
+         IF nBytes>0
+         THEN
+            (* still more to read *)
+            result := read(unixfd, a, INTEGER(nBytes)) ;
+            IF result>0
+            THEN
+               INC(total, result) ;
+               INC(abspos, result) ;
+               (* now disable the buffer as we read directly into, a. *)
+               IF buffer#NIL
+               THEN
+                  buffer^.valid := FALSE
+               END ;
+            ELSE
+               IF result=0
+               THEN
+                  (* eof reached *)
+                  state := endoffile
+               ELSE
+                  state := failed
+               END ;
+               (* indicate buffer is empty *)
+               IF buffer#NIL
+               THEN
+                  WITH buffer^ DO
+                     valid    := FALSE ;
+                     left     := 0 ;
+                     position := 0 ;
+                     IF address#NIL
+                     THEN
+                        contents^[position] := nul
+                     END
+                  END
+               END ;
+               RETURN( -1 )
+            END
+         END
+      END ;
+      RETURN( total )
+   ELSE
+      RETURN( -1 )
+   END
+END ReadFromBuffer ;
+
+
+(*
+   ReadNBytes - reads nBytes of a file into memory area, dest, returning
+                the number of bytes actually read.
+                This function will consume from the buffer and then
+                perform direct libc reads. It is ideal for large reads.
+*)
+
+PROCEDURE ReadNBytes (f: File; nBytes: CARDINAL; dest: ADDRESS) : CARDINAL ;
+VAR
+   n: INTEGER ;
+   p: POINTER TO CHAR ;
+BEGIN
+   IF f # Error
+   THEN
+      CheckAccess (f, openedforread, FALSE) ;
+      n := ReadFromBuffer (f, dest, nBytes) ;
+      IF n <= 0
+      THEN
+         RETURN 0
+      ELSE
+         p := dest ;
+         INC (p, n-1) ;
+         SetEndOfLine (f, p^) ;
+         RETURN n
+      END
+   ELSE
+      RETURN 0
+   END
+END ReadNBytes ;
+
+
+(*
+   BufferedRead - will read, nBytes, through the buffer.
+                  Similar to ReadFromBuffer, but this function will always
+                  read into the buffer before copying into memory.
+
+                  Useful when performing small reads.
+*)
+
+PROCEDURE BufferedRead (f: File; nBytes: CARDINAL; dest: ADDRESS) : INTEGER ;
+VAR
+   src   : ADDRESS ;
+   total,
+   n     : INTEGER ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      total := 0 ;   (* how many bytes have we read *)
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            (* extract from the buffer first *)
+            IF buffer # NIL
+            THEN
+               WITH buffer^ DO
+                  WHILE nBytes > 0 DO
+                     IF (left > 0) AND valid
+                     THEN
+                        IF nBytes = 1
+                        THEN
+                           (* too expensive to call memcpy for 1 character *)
+                           p := dest ;
+                           p^ := contents^[position] ;
+                           DEC (left) ;         (* remove consumed byte                *)
+                           INC (position) ;     (* move onwards n byte                 *)
+                           INC (total) ;
+                           RETURN( total )
+                        ELSE
+                           n := Min (left, nBytes) ;
+                           src := address ;
+                           INC (src, position) ;
+                           p := memcpy (dest, src, n) ;
+                           DEC (left, n) ;      (* remove consumed bytes               *)
+                           INC (position, n) ;  (* move onwards n bytes                *)
+                                               (* move onwards ready for direct reads *)
+                           INC (dest, n) ;
+                           DEC (nBytes, n) ;    (* reduce the amount for future direct *)
+                                               (* read                                *)
+                           INC (total, n)
+                        END
+                     ELSE
+                        (* refill buffer *)
+                        n := read (unixfd, address, size) ;
+                        IF n >= 0
+                        THEN
+                           valid    := TRUE ;
+                           position := 0 ;
+                           left     := n ;
+                           filled   := n ;
+                           bufstart := abspos ;
+                           INC (abspos, n) ;
+                           IF n = 0
+                           THEN
+                              (* eof reached *)
+                              state := endoffile ;
+                              RETURN( -1 )
+                           END
+                        ELSE
+                           valid    := FALSE ;
+                           position := 0 ;
+                           left     := 0 ;
+                           filled   := 0 ;
+                           state    := failed ;
+                           RETURN( total )
+                        END
+                     END
+                  END
+               END ;
+               RETURN( total )
+            END
+         END
+      END
+   END ;
+   RETURN( -1 )
+END BufferedRead ;
+
+
+(*
+   HandleEscape - translates \n and \t into their respective ascii codes.
+*)
+
+PROCEDURE HandleEscape (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR;
+                        VAR i, j: CARDINAL; HighSrc, HighDest: CARDINAL) ;
+BEGIN
+   IF (i+1<HighSrc) AND (src[i]='\') AND (j<HighDest)
+   THEN
+      IF src[i+1]='n'
+      THEN
+         (* requires a newline *)
+         dest[j] := nl ;
+         INC(j) ;
+         INC(i, 2)
+      ELSIF src[i+1]='t'
+      THEN
+         (* requires a tab (yuck) tempted to fake this but I better not.. *)
+         dest[j] := tab ;
+         INC(j) ;
+         INC(i, 2)
+      ELSE
+         (* copy escaped character *)
+         INC(i) ;
+         dest[j] := src[i] ;
+         INC(j) ;
+         INC(i)
+      END
+   END
+END HandleEscape ;
+
+
+(*
+   Cast - casts a := b
+*)
+
+PROCEDURE Cast (VAR a: ARRAY OF BYTE; b: ARRAY OF BYTE) ;
+VAR
+   i: CARDINAL ;
+BEGIN
+   IF HIGH(a)=HIGH(b)
+   THEN
+      FOR i := 0 TO HIGH(a) DO
+         a[i] := b[i]
+      END
+   ELSE
+      FormatError('cast failed')
+   END
+END Cast ;
+
+
+(*
+   StringFormat1 - converts string, src, into, dest, together with encapsulated
+                   entity, w. It only formats the first %s or %d with n.
+*)
+
+PROCEDURE StringFormat1 (VAR dest: ARRAY OF CHAR; src: ARRAY OF CHAR;
+                         w: ARRAY OF BYTE) ;
+VAR
+   HighSrc,
+   HighDest,
+   c, i, j : CARDINAL ;
+   str     : ARRAY [0..MaxErrorString] OF CHAR ;
+   p       : POINTER TO CHAR ;
+BEGIN
+   HighSrc := StrLen(src) ;
+   HighDest := HIGH(dest) ;
+   p := NIL ;
+   c := 0 ;
+   i := 0 ;
+   j := 0 ;
+   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) AND (src[i]#'%') DO
+      IF src[i]='\'
+      THEN
+         HandleEscape(dest, src, i, j, HighSrc, HighDest)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+
+   IF (i+1<HighSrc) AND (src[i]='%') AND (j<HighDest)
+   THEN
+      IF src[i+1]='s'
+      THEN
+         Cast(p, w) ;
+         WHILE (j<HighDest) AND (p^#nul) DO
+            dest[j] := p^ ;
+            INC(j) ;
+            INC(p)
+         END ;
+         IF j<HighDest
+         THEN
+            dest[j] := nul
+         END ;
+         j := StrLen(dest) ;
+         INC(i, 2)
+      ELSIF src[i+1]='d'
+      THEN
+         dest[j] := nul ;
+         Cast(c, w) ;
+         CardToStr(c, 0, str) ;
+         StrConCat(dest, str, dest) ;
+         j := StrLen(dest) ;
+         INC(i, 2)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+   (* and finish off copying src into dest *)
+   WHILE (i<HighSrc) AND (src[i]#nul) AND (j<HighDest) DO
+      IF src[i]='\'
+      THEN
+         HandleEscape(dest, src, i, j, HighSrc, HighDest)
+      ELSE
+         dest[j] := src[i] ;
+         INC(i) ;
+         INC(j)
+      END
+   END ;
+   IF j<HighDest
+   THEN
+      dest[j] := nul
+   END ;
+END StringFormat1 ;
+
+
+(*
+   FormatError - provides a orthoganal counterpart to the procedure below.
+*)
+
+PROCEDURE FormatError (a: ARRAY OF CHAR) ;
+BEGIN
+   WriteString (StdErr, a)
+END FormatError ;
+
+
+(*
+   FormatError1 - generic error procedure taking standard format string
+                  and single parameter.
+*)
+
+PROCEDURE FormatError1 (a: ARRAY OF CHAR; w: ARRAY OF BYTE) ;
+VAR
+   s: ARRAY [0..MaxErrorString] OF CHAR ;
+BEGIN
+   StringFormat1 (s, a, w) ;
+   FormatError (s)
+END FormatError1 ;
+
+
+(*
+   FormatError2 - generic error procedure taking standard format string
+                  and two parameters.
+*)
+
+PROCEDURE FormatError2 (a: ARRAY OF CHAR;
+                        w1, w2: ARRAY OF BYTE) ;
+VAR
+   s: ARRAY [0..MaxErrorString] OF CHAR ;
+BEGIN
+   StringFormat1 (s, a, w1) ;
+   FormatError1 (s, w2)
+END FormatError2 ;
+
+
+(*
+   CheckAccess - checks to see whether a file f has been
+                 opened for read/write.
+*)
+
+PROCEDURE CheckAccess (f: File; use: FileUsage; towrite: BOOLEAN) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         IF f#StdErr
+         THEN
+            FormatError ('this file has probably been closed and not reopened successfully or alternatively never opened\n')
+         END ;
+         HALT
+      ELSE
+         WITH fd^ DO
+            IF (use=openedforwrite) AND (usage=openedforread)
+            THEN
+               FormatError1 ('this file (%s) has been opened for reading but is now being written\n',
+                             name.address) ;
+               HALT
+            ELSIF (use=openedforread) AND (usage=openedforwrite)
+            THEN
+               FormatError1('this file (%s) has been opened for writing but is now being read\n',
+                            name.address) ;
+               HALT
+            ELSIF state=connectionfailure
+            THEN
+               FormatError1('this file (%s) was not successfully opened\n',
+                            name.address) ;
+               HALT
+            ELSIF towrite#output
+            THEN
+               IF output
+               THEN
+                  FormatError1('this file (%s) was opened for writing but is now being read\n',
+                               name.address) ;
+                  HALT
+               ELSE
+                  FormatError1('this file (%s) was opened for reading but is now being written\n',
+                               name.address) ;
+                  HALT
+               END
+            END
+         END
+      END
+   ELSE
+      FormatError('this file has not been opened successfully\n') ;
+      HALT
+   END
+END CheckAccess ;
+
+
+(*
+   ReadChar - returns a character read from file f.
+              Sensible to check with IsNoError or EOF after calling
+              this function.
+*)
+
+PROCEDURE ReadChar (f: File) : CHAR ;
+VAR
+   ch: CHAR ;
+BEGIN
+   CheckAccess (f, openedforread, FALSE) ;
+   IF BufferedRead (f, SIZE (ch), ADR (ch)) = VAL (INTEGER, SIZE (ch))
+   THEN
+      SetEndOfLine (f, ch) ;
+      RETURN ch
+   ELSE
+      RETURN nul
+   END
+END ReadChar ;
+
+
+(*
+   SetEndOfLine -
+*)
+
+PROCEDURE SetEndOfLine (f: File; ch: CHAR) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         IF ch=nl
+         THEN
+            state := endofline
+         ELSE
+            state := successful
+         END
+      END
+   END
+END SetEndOfLine ;
+
+
+(*
+   UnReadChar - replaces a character, ch, back into file f.
+                This character must have been read by ReadChar
+                and it does not allow successive calls.  It may
+                only be called if the previous read was successful
+                or end of file was seen.
+                If the state was previously endoffile then it
+                is altered to successful.
+                Otherwise it is left alone.
+*)
+
+PROCEDURE UnReadChar (f: File; ch: CHAR) ;
+VAR
+   fd  : FileDescriptor ;
+   n   : CARDINAL ;
+   a, b: ADDRESS ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      WITH fd^ DO
+         IF (state=successful) OR (state=endoffile) OR (state=endofline)
+         THEN
+            IF (buffer#NIL) AND (buffer^.valid)
+            THEN
+               WITH buffer^ DO
+                  (* we assume that a ReadChar has occurred, we will check just in case. *)
+                  IF state=endoffile
+                  THEN
+                     position := MaxBufferLength ;
+                     left := 0 ;
+                     filled := 0 ;
+                     state := successful
+                  END ;
+                  IF position>0
+                  THEN
+                     DEC(position) ;
+                     INC(left) ;
+                     contents^[position] := ch ;
+                  ELSE
+                     (* position=0 *)
+                     (* if possible make room and store ch *)
+                     IF filled=size
+                     THEN
+                        FormatError1('performing too many UnReadChar calls on file (%d)\n', f)
+                     ELSE
+                        n := filled-position ;
+                        b := ADR(contents^[position]) ;
+                        a := ADR(contents^[position+1]) ;
+                        a := memcpy(a, b, n) ;
+                        INC(filled) ;
+                        contents^[position] := ch ;
+                     END
+                  END
+               END
+            END
+         ELSE
+            FormatError1('UnReadChar can only be called if the previous read was successful or end of file, error on file (%d)\n', f)
+         END
+      END
+   END
+END UnReadChar ;
+
+
+(*
+   ReadAny - reads HIGH (a) + 1 bytes into, a.  All input
+             is fully buffered, unlike ReadNBytes and thus is more
+             suited to small reads.
+*)
+
+PROCEDURE ReadAny (f: File; VAR a: ARRAY OF BYTE) ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF BufferedRead (f, HIGH (a) + 1, ADR (a)) = VAL (INTEGER, HIGH (a) + 1)
+   THEN
+      SetEndOfLine (f, a[HIGH(a)])
+   END
+END ReadAny ;
+
+
+(*
+   EOF - tests to see whether a file, f, has reached end of file.
+*)
+
+PROCEDURE EOF (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         RETURN( fd^.state=endoffile )
+      END
+   END ;
+   RETURN( TRUE )
+END EOF ;
+
+
+(*
+   EOLN - tests to see whether a file, f, is upon a newline.
+          It does NOT consume the newline.
+*)
+
+PROCEDURE EOLN (f: File) : BOOLEAN ;
+VAR
+   ch: CHAR ;
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   (*
+      we will read a character and then push it back onto the input stream,
+      having noted the file status, we also reset the status.
+   *)
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         IF (fd^.state=successful) OR (fd^.state=endofline)
+         THEN
+            ch := ReadChar(f) ;
+            IF (fd^.state=successful) OR (fd^.state=endofline)
+            THEN
+               UnReadChar(f, ch)
+            END ;
+            RETURN( ch=nl )
+         END
+      END
+   END ;
+   RETURN( FALSE )
+END EOLN ;
+
+
+(*
+   WasEOLN - tests to see whether a file, f, has just seen a newline.
+*)
+
+PROCEDURE WasEOLN (f: File) : BOOLEAN ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   IF f=Error
+   THEN
+      RETURN FALSE
+   ELSE
+      fd := GetIndice(FileInfo, f) ;
+      RETURN( (fd#NIL) AND (fd^.state=endofline) )
+   END
+END WasEOLN ;
+
+
+(*
+   WriteLine - writes out a linefeed to file, f.
+*)
+
+PROCEDURE WriteLine (f: File) ;
+BEGIN
+   WriteChar(f, nl)
+END WriteLine ;
+
+
+(*
+   WriteNBytes - writes nBytes from memory area src to a file
+                 returning the number of bytes actually written.
+                 This function will flush the buffer and then
+                 write the nBytes using a direct write from libc.
+                 It is ideal for large writes.
+*)
+
+PROCEDURE WriteNBytes (f: File; nBytes: CARDINAL; src: ADDRESS) : CARDINAL ;
+VAR
+   total: INTEGER ;
+   fd   : FileDescriptor ;
+BEGIN
+   CheckAccess(f, openedforwrite, TRUE) ;
+   FlushBuffer(f) ;
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            total := write(unixfd, src, INTEGER(nBytes)) ;
+            IF total<0
+            THEN
+               state := failed ;
+               RETURN( 0 )
+            ELSE
+               INC(abspos, CARDINAL(total)) ;
+               IF buffer#NIL
+               THEN
+                  buffer^.bufstart := abspos
+               END ;
+               RETURN( CARDINAL(total) )
+            END
+         END
+      END
+   END ;
+   RETURN( 0 )
+END WriteNBytes ;
+
+
+(*
+   BufferedWrite - will write, nBytes, through the buffer.
+                   Similar to WriteNBytes, but this function will always
+                   write into the buffer before copying into memory.
+
+                   Useful when performing small writes.
+*)
+
+PROCEDURE BufferedWrite (f: File; nBytes: CARDINAL; src: ADDRESS) : INTEGER ;
+VAR
+   dest  : ADDRESS ;
+   total,
+   n     : INTEGER ;
+   p     : POINTER TO BYTE ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f # Error
+   THEN
+      fd := GetIndice (FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         total := 0 ;   (* how many bytes have we read *)
+         WITH fd^ DO
+            IF buffer # NIL
+            THEN
+               WITH buffer^ DO
+                  WHILE nBytes > 0 DO
+                     (* place into the buffer first *)
+                     IF left > 0
+                     THEN
+                        IF nBytes = 1
+                        THEN
+                           (* too expensive to call memcpy for 1 character *)
+                           p := src ;
+                           contents^[position] := p^ ;
+                           DEC (left) ;         (* reduce space                        *)
+                           INC (position) ;     (* move onwards n byte                 *)
+                           INC (total) ;
+                           RETURN( total )
+                        ELSE
+                           n := Min (left, nBytes) ;
+                           dest := address ;
+                           INC (dest, position) ;
+                           p := memcpy (dest, src, CARDINAL (n)) ;
+                           DEC (left, n) ;      (* remove consumed bytes               *)
+                           INC (position, n) ;  (* move onwards n bytes                *)
+                                                (* move ready for further writes       *)
+                           INC (src, n) ;
+                           DEC (nBytes, n) ;    (* reduce the amount for future writes *)
+                           INC (total, n)
+                        END
+                     ELSE
+                        FlushBuffer (f) ;
+                        IF (state#successful) AND (state#endofline)
+                        THEN
+                           nBytes := 0
+                        END
+                     END
+                  END
+               END ;
+               RETURN( total )
+            END
+         END
+      END
+   END ;
+   RETURN( -1 )
+END BufferedWrite ;
+
+
+(*
+   FlushBuffer - flush contents of file, f.
+*)
+
+PROCEDURE FlushBuffer (f: File) ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF output AND (buffer#NIL)
+            THEN
+               WITH buffer^ DO
+                  IF (position=0) OR (write(unixfd, address, position)=VAL(INTEGER, position))
+                  THEN
+                     INC(abspos, position) ;
+                     bufstart := abspos ;
+                     position := 0 ;
+                     filled   := 0 ;
+                     left     := size
+                  ELSE
+                     state := failed
+                  END
+               END
+            END
+         END
+      END
+   END
+END FlushBuffer ;
+
+
+(*
+   WriteAny - writes HIGH (a) + 1 bytes onto, file, f.  All output
+              is fully buffered, unlike WriteNBytes and thus is more
+              suited to small writes.
+*)
+
+PROCEDURE WriteAny (f: File; VAR a: ARRAY OF BYTE) ;
+BEGIN
+   CheckAccess (f, openedforwrite, TRUE) ;
+   IF BufferedWrite (f, HIGH (a) + 1, ADR (a)) = VAL (INTEGER, HIGH (a) + 1)
+   THEN
+   END
+END WriteAny ;
+
+
+(*
+   WriteChar - writes a single character to file, f.
+*)
+
+PROCEDURE WriteChar (f: File; ch: CHAR) ;
+BEGIN
+   CheckAccess (f, openedforwrite, TRUE) ;
+   IF BufferedWrite (f, SIZE (ch), ADR (ch)) = VAL (INTEGER, SIZE (ch))
+   THEN
+   END
+END WriteChar ;
+
+
+(*
+   WriteCardinal - writes a CARDINAL to file, f.
+                   It writes the binary image of the cardinal
+                   to file, f.
+*)
+
+PROCEDURE WriteCardinal (f: File; c: CARDINAL) ;
+BEGIN
+   WriteAny(f, c)
+END WriteCardinal ;
+
+
+(*
+   ReadCardinal - reads a CARDINAL from file, f.
+                  It reads a binary image of a CARDINAL
+                  from a file, f.
+*)
+
+PROCEDURE ReadCardinal (f: File) : CARDINAL ;
+VAR
+   c: CARDINAL ;
+BEGIN
+   ReadAny(f, c) ;
+   RETURN( c )
+END ReadCardinal ;
+
+
+(*
+   ReadString - reads a string from file, f, into string, a.
+                It terminates the string if HIGH is reached or
+                if a newline is seen or an error occurs.
+*)
+
+PROCEDURE ReadString (f: File; VAR a: ARRAY OF CHAR) ;
+VAR
+   high,
+   i   : CARDINAL ;
+   ch  : CHAR ;
+BEGIN
+   CheckAccess(f, openedforread, FALSE) ;
+   high := HIGH(a) ;
+   i := 0 ;
+   REPEAT
+      ch := ReadChar(f) ;
+      IF i<=high
+      THEN
+         IF (ch=nl) OR (NOT IsNoError(f)) OR EOF(f)
+         THEN
+            a[i] := nul ;
+            INC(i)
+         ELSE
+            a[i] := ch ;
+            INC(i)
+         END
+      END
+   UNTIL (ch=nl) OR (i>high) OR (NOT IsNoError(f)) OR EOF(f)
+END ReadString ;
+
+
+(*
+   SetPositionFromBeginning - sets the position from the beginning of the file.
+*)
+
+PROCEDURE SetPositionFromBeginning (f: File; pos: LONGINT) ;
+VAR
+   offset: LONGINT ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            (* always force the lseek, until we are confident that abspos is always correct,
+               basically it needs some hard testing before we should remove the OR TRUE. *)
+            IF (abspos#pos) OR TRUE
+            THEN
+               FlushBuffer(f) ;
+               IF buffer#NIL
+               THEN
+                  WITH buffer^ DO
+                     IF output
+                     THEN
+                        left := size
+                     ELSE
+                        left := 0
+                     END ;
+                     position := 0 ;
+                     filled   := 0
+                  END
+               END ;
+               offset := lseek (unixfd, VAL (COFF_T, pos), SeekSet ()) ;
+               IF (offset>=0) AND (pos=offset)
+               THEN
+                  abspos := pos
+               ELSE
+                  state  := failed ;
+                  abspos := 0
+               END ;
+               IF buffer#NIL
+               THEN
+                  buffer^.valid := FALSE ;
+                  buffer^.bufstart := abspos
+               END
+            END
+         END
+      END
+   END
+END SetPositionFromBeginning ;
+
+
+(*
+   SetPositionFromEnd - sets the position from the end of the file.
+*)
+
+PROCEDURE SetPositionFromEnd (f: File; pos: LONGINT) ;
+VAR
+   offset: LONGINT ;
+   fd    : FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            FlushBuffer(f) ;
+            IF buffer#NIL
+            THEN
+               WITH buffer^ DO
+                  IF output
+                  THEN
+                     left := size
+                  ELSE
+                     left := 0
+                  END ;
+                  position := 0 ;
+                  filled   := 0
+               END
+            END ;
+            offset := lseek (unixfd, VAL (COFF_T, pos), SeekEnd ()) ;
+            IF offset>=0
+            THEN
+               abspos := offset ;
+            ELSE
+               state  := failed ;
+               abspos := 0 ;
+               offset := 0
+            END ;
+            IF buffer#NIL
+            THEN
+               buffer^.valid := FALSE ;
+               buffer^.bufstart := offset
+            END
+         END
+      END
+   END
+END SetPositionFromEnd ;
+
+
+(*
+   FindPosition - returns the current absolute position in file, f.
+*)
+
+PROCEDURE FindPosition (f: File) : LONGINT ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd#NIL
+      THEN
+         WITH fd^ DO
+            IF (buffer=NIL) OR (NOT buffer^.valid)
+            THEN
+               RETURN( abspos )
+            ELSE
+               WITH buffer^ DO
+                  RETURN( bufstart+VAL(LONGINT, position) )
+               END
+            END
+         END
+      END
+   END ;
+   RETURN( 0 )
+END FindPosition ;
+
+
+(*
+   GetFDesc - return the file descriptor associated with File name,  fname
+*)
+
+PROCEDURE GetFDesc (fname : ARRAY OF CHAR ) : File;
+
+VAR 
+  i : CARDINAL;
+  fd : File;
+  name : ARRAY[0..256] OF CHAR;
+
+BEGIN 
+  FOR i := LowIndice(FileInfo) TO HighIndice(FileInfo) DO 
+    fd := GetIndice (FileInfo, i);
+    GetFileName(fd, name);
+    IF Strings.Compare (fname,name) = equal THEN 
+      RETURN fd
+    END;  
+  END;
+  RETURN NIL 
+END GetFDesc;
+(*
+   GetFileName - assigns, a, with the filename associated with, f.
+*)
+
+PROCEDURE GetFileName (f: File; VAR a: ARRAY OF CHAR) ;
+VAR
+   i : CARDINAL ;
+   p : POINTER TO CHAR ;
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         WITH fd^.name DO
+            IF address=NIL
+            THEN
+               StrCopy('', a)
+            ELSE
+               p := address ;
+               i := 0 ;
+               WHILE (p^#nul) AND (i<=HIGH(a)) DO
+                  a[i] := p^ ;
+                  INC(p) ;
+                  INC(i)
+               END
+            END
+         END
+      END
+   END
+END GetFileName ;
+
+
+(*
+   getFileName - returns the address of the filename associated with, f.
+*)
+
+PROCEDURE getFileName (f: File) : ADDRESS ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         RETURN fd^.name.address
+      END
+   END ;
+   RETURN NIL
+END getFileName ;
+
+
+(*
+   getFileNameLength - returns the number of characters associated with filename, f.
+*)
+
+PROCEDURE getFileNameLength (f: File) : CARDINAL ;
+VAR
+   fd: FileDescriptor ;
+BEGIN
+   IF f#Error
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF fd=NIL
+      THEN
+         FormatError('this file has probably been closed and not reopened successfully or alternatively never opened\n') ;
+         HALT
+      ELSE
+         RETURN fd^.name.size
+      END
+   END ;
+   RETURN 0
+END getFileNameLength ;
+
+
+(*
+   PreInitialize - preinitialize the file descriptor.
+*)
+
+PROCEDURE PreInitialize (f: File; fname: ARRAY OF CHAR;
+                         state: FileStatus; use: FileUsage;
+                         towrite: BOOLEAN; osfd: INTEGER; bufsize: CARDINAL) ;
+VAR
+   fd, fe: FileDescriptor ;
+BEGIN
+   IF InitializeFile(f, ADR(fname), StrLen(fname), state, use, towrite, bufsize)=f
+   THEN
+      fd := GetIndice(FileInfo, f) ;
+      IF f=Error
+      THEN
+         fe := GetIndice(FileInfo, StdErr) ;
+         IF fe=NIL
+         THEN
+            HALT
+         ELSE
+            fd^.unixfd := fe^.unixfd    (* the error channel *)
+         END
+      ELSE
+         fd^.unixfd := osfd
+      END
+   ELSE
+      HALT
+   END
+END PreInitialize ;
+
+
+(*
+   FlushOutErr - flushes, StdOut, and, StdErr.
+                 It is also called when the application calls M2RTS.Terminate.
+                 (which is automatically placed in program modules by the GM2
+                 scaffold).
+*)
+
+PROCEDURE FlushOutErr ;
+BEGIN
+   IF IsNoError(StdOut)
+   THEN
+      FlushBuffer(StdOut)
+   END ;
+   IF IsNoError(StdErr)
+   THEN
+      FlushBuffer(StdErr)
+   END
+END FlushOutErr ;
+
+
+(*
+   Init - initialize the modules, global variables.
+*)
+
+PROCEDURE Init ;
+BEGIN
+   FileInfo := InitIndex(0) ;
+   Error := 0 ;
+   PreInitialize(Error       , 'error'   , toomanyfilesopen, unused        , FALSE, -1, 0) ;
+   StdIn := 1 ;
+   PreInitialize(StdIn       , '<stdin>' , successful      , openedforread , FALSE, 0, MaxBufferLength) ;
+   StdOut := 2 ;
+   PreInitialize(StdOut      , '<stdout>', successful      , openedforwrite,  TRUE, 1, MaxBufferLength) ;
+   StdErr := 3 ;
+   PreInitialize(StdErr      , '<stderr>', successful      , openedforwrite,  TRUE, 2, MaxBufferLength) ;
+   IF NOT InstallTerminationProcedure(FlushOutErr)
+   THEN
+      HALT
+   END
+END Init ;
+
+
+BEGIN
+   Init
+FINALLY
+   FlushOutErr
+END FIO.

ListHandler.def

@@ -0,0 +1,7 @@
+DEFINITION MODULE Listhandler;
+
+PROCEDURE StoreError (nr, line, col: INTEGER; pos: INT32);
+
+PROCEDURE PrintListing;
+
+END ListHandler.

ListHandler.mod

@@ -0,0 +1,235 @@
+  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.
+

Readme.txt

@@ -0,0 +1,92 @@
+This directory and its subdirectories contain the sources of Coco/R itself,
+and also source code for various implementations of the compiler-specific
+module FileIO used by Coco/R itself for I/O, and also, in many cases, by
+the applications it produces.
+
+Coco/R can be recompiled and bootstrapped from these sources - but PLEASE
+BE CAREFUL!
+
+Recompiling Coco/R
+==================
+
+To do so you are advised to create a working directory, copy all of the
+files from this directory to it, and then copy all the files from the
+subdirectory specific to your compiler.  For example, assuming you have the
+XDS compiler (used here for illustration only):
+
+     MD C:\WORK
+     CD C:\WORK
+     COPY C:\COCO\SOURCES\*.*
+     COPY C:\COCO\SOURCES\XDSISO\*.*
+     SET CRFRAMES=C:\COCO\FRAMES
+
+(The "traditional" FileIO-based frame files must be used).
+
+followed by
+
+     XC =m CR
+
+which will produce a new executable CR.EXE that you might rename to
+COCOR.EXE when you are satisfied.
+
+Note that some compilers will require you to choose between various memory
+models, and may provide various optimization options that we cannot discuss
+here.  For example, the StonyBrook 16 bit DOS compiler require you to use a
+large data model.
+
+Some compilers _require_ FORWARD declarations to be generated before they
+will accept the code generated by Coco/R, others require that no such
+directives be present.  The $M pragma (or -m command line option) will
+suppress the generation of the FORWARD declarations (or, more honestly,
+will comment them out).  The XDS and JPI compilers require that they be
+present.
+
+Coco/R itself makes use of 32-bit integers.  This should be handled
+automagically by the appropriate definition of the INT32 type in
+FileIO.DEF.
+
+Modifying and bootstrapping Coco/R
+==================================
+
+Executing
+
+      COCOR CR.ATG
+
+will cause Coco to regenerate the parser (CRP), scanner (CRS) and main module
+(CR) from the attribute grammar CR.ATG.
+
+Thus, if you wish, you can modify CR.ATG and/or CR.FRM and subtly modify
+the behaviour od Coco/R, or he form of the grammars that it will accept.
+For example, you might want to add to the possible command line
+options/pragmas, or modify Coco/R so that it suppresses the generation of
+FORWARD declarations in the parser, or produce error messages in a
+different format.
+
+It is recommended that if you want to experiment with this, that you work
+in a very different directory from the one in which you have filed the
+original sources, lest you erase valuable original files.
+
+Table size limitations
+======================
+
+The symbol tables used internally by Coco/R make use of fixed length arrays
+- always a rather dangerous thing to do.  The dimensions of these arrays
+have been chosen to ensure that the data segments for the modules will
+remain within the limits imposed by MS-DOS system compilers that typically
+impose a 64K limit on structures.  The limits can be extended for compilers
+that allow this (such as 32 bit compilers) by editing CRT.DEF and CRT.MOD
+appropriately, and recompiling Coco/R.  This may have to be done if a user
+wishes to handle large grammars with many productions, for example.
+
+Alternative versions of Coco/R
+==============================
+
+CRQ.FRM and CR.FRM are alternative compiler frame files.  They produce the
+main driver routines CR.MOD and CRQ.MOD.  The first of these is the
+"classic" Coco/R driver program; CRQ is an alternative that produces error
+messages in a format that can be used to interface easily to various
+editors that provide for constructing IDE environments.  By simply renaming
+CRQ.FRM as CR.FRM and recompiling Coco/R you can easily generate this
+"editor oriented" version.
+
+=END=

Sets.def

@@ -0,0 +1,26 @@
+DEFINITION MODULE Sets;
+(* General set handling primitives / HM 1.11.89 *)
+
+IMPORT FileIO;
+
+CONST
+  size = FileIO.BitSetSize;
+
+PROCEDURE Clear (VAR s: ARRAY OF BITSET);                    (* s := {}       *)
+PROCEDURE Fill (VAR s: ARRAY OF BITSET);                     (* s := full set *)
+PROCEDURE In (VAR s: ARRAY OF BITSET; x: CARDINAL): BOOLEAN; (* x IN s ?      *)
+PROCEDURE Incl (VAR s: ARRAY OF BITSET; x: CARDINAL);        (* INCL(s, x)    *)
+PROCEDURE Excl (VAR s: ARRAY OF BITSET; x: CARDINAL);        (* EXCL(s, x)    *)
+PROCEDURE Includes (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;   (* s2 <= s1 ?    *)
+PROCEDURE Elements (VAR s: ARRAY OF BITSET;                  (* | s |         *)
+                    VAR lastElem: INTEGER): INTEGER;         (*               *)
+PROCEDURE Empty (VAR s: ARRAY OF BITSET): BOOLEAN;           (* s1 = {} ?     *)
+PROCEDURE Equal (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;      (* s1 = s2 ?     *)
+PROCEDURE Different (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;  (* s1 * s2 = 0 ? *)
+PROCEDURE Unite (VAR s1, s2: ARRAY OF BITSET);               (* s1 := s1 + s2 *)
+PROCEDURE Differ (VAR s1, s2: ARRAY OF BITSET);              (* s1 := s1 - s2 *)
+PROCEDURE Intersect (VAR s1, s2, s3: ARRAY OF BITSET);       (* s3 := s1 * s2 *)
+
+PROCEDURE Print (f: FileIO.File; s: ARRAY OF BITSET; w, indent: INTEGER);
+
+END Sets.

Sets.mod

@@ -0,0 +1,176 @@
+IMPLEMENTATION MODULE Sets;
+
+IMPORT FileIO;
+
+(* Clear                Clear all elements in set s      
+---------------------------------------------------------------------------*)
+PROCEDURE Clear (VAR s: ARRAY OF BITSET);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0; WHILE i <= HIGH(s) DO s[i] := BITSET{}; INC(i) END
+  END Clear;
+
+
+(* Fill                 Set all elements in set s
+---------------------------------------------------------------------------*)
+PROCEDURE Fill (VAR s: ARRAY OF BITSET);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0; WHILE i <= HIGH(s) DO s[i] := BITSET{0 .. size - 1}; INC(i) END
+  END Fill;
+
+
+(* Incl                 Include element x in set s
+---------------------------------------------------------------------------*)
+PROCEDURE Incl (VAR s: ARRAY OF BITSET; x: CARDINAL);
+  BEGIN
+    INCL(s[x DIV size], x MOD size)
+  END Incl;
+
+
+(* Excl
+---------------------------------------------------------------------------*)
+PROCEDURE Excl (VAR s: ARRAY OF BITSET; x: CARDINAL);
+  BEGIN
+    EXCL(s[x DIV size], x MOD size)
+  END Excl;
+
+
+(* In                   TRUE, if element x is contained in set s
+---------------------------------------------------------------------------*)
+PROCEDURE In (VAR s: ARRAY OF BITSET; x: CARDINAL): BOOLEAN;
+  BEGIN
+    RETURN x MOD size IN s[x DIV size]
+  END In;
+
+
+(* Includes             TRUE, if s2 in s1
+---------------------------------------------------------------------------*)
+PROCEDURE Includes (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE i <= HIGH(s1) DO
+      IF ~ (s2[i] <= s1[i]) THEN RETURN FALSE END;
+      INC(i)
+    END;
+    RETURN TRUE;
+  END Includes;
+
+
+(* Elements             Return number of elements in set s
+---------------------------------------------------------------------------*)
+PROCEDURE Elements (VAR s: ARRAY OF BITSET; VAR lastElem: INTEGER): INTEGER;
+  VAR
+    i, n, max: CARDINAL;
+  BEGIN
+    i := 0; n := 0; max := (HIGH(s) + 1) * size;
+    WHILE i < max DO
+      IF i MOD size IN s[i DIV size] THEN INC(n); lastElem := i END;
+      INC(i)
+    END;
+    RETURN n
+  END Elements;
+
+
+(* Empty                TRUE, if set s i sempty
+---------------------------------------------------------------------------*)
+PROCEDURE Empty (VAR s: ARRAY OF BITSET): BOOLEAN;
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE i <= HIGH(s) DO
+      IF s[i] # BITSET{} THEN RETURN FALSE END;
+      INC(i)
+    END;
+    RETURN TRUE
+  END Empty;
+
+
+(* Equal                TRUE, if set s1 and s2 are equal
+---------------------------------------------------------------------------*)
+PROCEDURE Equal (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE i <= HIGH(s1) DO
+      IF s1[i] # s2[i] THEN RETURN FALSE END;
+      INC(i)
+    END;
+    RETURN TRUE
+  END Equal;
+
+
+(* Different            TRUE, if set s1 and s2 are totally different
+---------------------------------------------------------------------------*)
+PROCEDURE Different (VAR s1, s2: ARRAY OF BITSET): BOOLEAN;
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0;
+    WHILE i <= HIGH(s1) DO
+      IF s1[i] * s2[i] # BITSET{} THEN RETURN FALSE END;
+      INC(i)
+    END;
+    RETURN TRUE
+  END Different;
+
+
+(* Unite                s1 := s1 + s2
+---------------------------------------------------------------------------*)
+PROCEDURE Unite (VAR s1, s2: ARRAY OF BITSET);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0; WHILE i <= HIGH(s1) DO s1[i] := s1[i] + s2[i]; INC(i) END
+  END Unite;
+
+
+(* Differ               s1 := s1 - s2
+---------------------------------------------------------------------------*)
+PROCEDURE Differ (VAR s1, s2: ARRAY OF BITSET);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0; WHILE i <= HIGH(s1) DO s1[i] := s1[i] - s2[i]; INC(i) END
+  END Differ;
+
+
+(* Intersect            s3 := s1 * s2
+---------------------------------------------------------------------------*)
+PROCEDURE Intersect (VAR s1, s2, s3: ARRAY OF BITSET);
+  VAR
+    i: CARDINAL;
+  BEGIN
+    i := 0; WHILE i <= HIGH(s1) DO s3[i] := s1[i] * s2[i]; INC(i) END
+  END Intersect;
+
+
+(* Print                Print set s
+---------------------------------------------------------------------------*)
+PROCEDURE Print (f: FileIO.File; s: ARRAY OF BITSET; w, indent: INTEGER);
+  VAR
+    col, i, max: INTEGER;
+  BEGIN
+    i := 0; col := indent; max := (HIGH(s) + 1) * size;
+    FileIO.Write(f, "{");
+    WHILE i < max DO
+      IF In(s, i) THEN
+        IF col + 4 > w THEN
+          FileIO.WriteLn(f); FileIO.WriteText(f, "", indent); col := indent
+        END;
+        FileIO.WriteInt(f, i, 3); FileIO.Write(f, ",");
+        INC(col, 4)
+      END;
+      INC(i)
+    END;
+    FileIO.Write(f, "}")
+  END Print;
+
+
+END Sets.

Tests/test2.mod

@@ -0,0 +1,15 @@
+MODULE test2;
+
+IMPORT InOut, Strings;
+
+VAR 
+  chaine1, chaine2 : ARRAY[0..10] OF CHAR;
+  result : ARRAY[0..10] OF CHAR;
+
+BEGIN 
+  chaine1 := "bonjour ";
+  chaine2 := "madame.";
+  Strings.Concat(chaine1,chaine2, result);
+  InOut.WriteString(result);
+
+END test2.

Tests/testFileIO.mod

@@ -0,0 +1,86 @@
+MODULE testFileIO;
+
+IMPORT FileIO, InOut, FIO;
+
+VAR 
+  monInt32 : FileIO.INT32;
+  monCardinal : CARDINAL;
+  monLongCardinal : LONGCARD;
+  maChaine1, 
+  maChaine2,
+  maChaine3 : ARRAY[0..30] OF CHAR;
+  leFichier : FileIO.File;
+
+BEGIN 
+  InOut.WriteString("Test des procedures de FileIO");
+  InOut.WriteLn;
+  
+   InOut.WriteString("Test9 : PROCEDURE WriteTime (f: File);");
+   InOut.WriteLn;
+   FileIO.WriteTime(leFichier);
+  
+  InOut.WriteString("Test8 : PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;");
+  InOut.WriteLn;
+  maChaine1 := "Et bonjour";
+  InOut.WriteCard(FileIO.SLENGTH(maChaine1),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test7 : PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "Et bonjour";
+  FileIO.Assign(maChaine1, maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test6 : PROCEDURE Extract (source: ARRAY OF CHAR;startIndex, numberToExtract: CARDINAL;VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "ma maison à Montélimar";
+  InOut.WriteString(maChaine1);
+  InOut.WriteLn;
+  FileIO.Extract (maChaine1,3,6,maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test5 : PROCEDURE Concat (stringVal1, stringVal2: ARRAY OF CHAR;VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "ma maison";
+  maChaine2 := " à Montélimar";
+  FileIO.Concat(maChaine1, maChaine2, maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test4 : PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;");
+  maChaine1 := "ma maison";
+  maChaine2 := "ma maison";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  maChaine2 := "ma maison à Montélimar";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  maChaine2 := "Coiucou";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test3 : PROCEDURE ORDL (n: INT32): CARDINAL;");
+  InOut.WriteLn;
+  monInt32 := 66666;
+  InOut.WriteInt(FileIO.ORDL(monInt32),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test3 : PROCEDURE INTL (n: INT32): INTEGER;");
+  InOut.WriteLn;
+  monInt32 := 55555;
+  InOut.WriteInt(FileIO.INTL(monInt32),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test2 : PROCEDURE INT (n: CARDINAL): INT32;");
+  InOut.WriteLn;
+  monCardinal := 444444;
+  InOut.WriteCard(monCardinal,8);
+  InOut.WriteInt(FileIO.INT(monCardinal),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test1 : QuitExecution");
+  InOut.WriteLn;
+  FileIO.QuitExecution;
+  InOut.WriteString("this will not be printed out");
+  InOut.WriteLn;
+END testFileIO.

Tests/testFileName.mod

@@ -0,0 +1,13 @@
+MODULE testFileName;
+
+IMPORT FileName;
+
+VAR 
+  chaine : ARRAY[0..256] OF CHAR;
+  f : FileName.Format;
+  a, b, c, d : ARRAY[0..256] OF CHAR;
+  
+BEGIN
+  chaine := "/Projets/Projets-Modula2/CocoGm2/test.mod";
+  (*FileName.Get(chaine,a,b,c);*)
+END testFileName.

Tests/testint.mod

@@ -0,0 +1,11 @@
+MODULE  testint;
+
+IMPORT InOut;
+
+BEGIN 
+  InOut.WriteCard(SIZE (INTEGER),8);
+  InOut.WriteLn;
+  InOut.WriteCard(SIZE (LONGCARD ),8);
+  InOut.WriteLn;
+END testint.
+

testFileIO.mod

@@ -0,0 +1,114 @@
+MODULE testFileIO;
+
+IMPORT FileIO, InOut, FIO;
+
+VAR 
+  monInt32 : FileIO.INT32;
+  monCardinal : CARDINAL;
+  monLongCardinal : LONGCARD;
+  maChaine1, 
+  maChaine2,
+  maChaine3 : ARRAY[0..30] OF CHAR;
+  leFichier : FIO.File;
+  leFileIOFichier : FileIO.File;
+  nomFichier : ARRAY[0..256] OF CHAR;
+
+BEGIN 
+  InOut.WriteString("Test des procedures de FileIO");
+  InOut.WriteLn;
+  (*
+  InOut.WriteString("Test : PROCEDURE WriteTime (f: File);");
+  InOut.WriteLn;
+  FileIO.WriteTime(leFichier);
+  *)
+  
+  (* ouverture du fichier en écriture *)
+  InOut.WriteString("Test9 :PROCEDURE Open (VAR f: File; fileName: ARRAY OF CHAR; newFile: BOOLEAN); et PROCEDURE IsNoError (f: File) : BOOLEAN ;");
+  nomFichier := "toto.txt";
+  (* création avec FileIO *)
+  FileIO.Open(leFileIOFichier, nomFichier,TRUE);
+  IF FileIO.Okay THEN
+    InOut.WriteString("Création OK")
+  ELSE
+    InOut.WriteString("la création a échoué")
+  END;
+  InOut.WriteLn;
+  
+  (*
+  création avec FIO
+  leFichier := FIO.OpenToWrite(nomFichier);
+  IF FIO.IsNoError(leFichier) THEN 
+    InOut.WriteString("Création OK!")
+  ELSE
+    InOut.WriteString("la création du fichier a échoué");
+  END;
+  InOut.WriteLn;*)
+  
+  
+  
+      
+  InOut.WriteString("Test8 : PROCEDURE SLENGTH (stringVal: ARRAY OF CHAR): CARDINAL;");
+  InOut.WriteLn;
+  maChaine1 := "Et bonjour";
+  InOut.WriteCard(FileIO.SLENGTH(maChaine1),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test7 : PROCEDURE Assign (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "Et bonjour";
+  FileIO.Assign(maChaine1, maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test6 : PROCEDURE Extract (source: ARRAY OF CHAR;startIndex, numberToExtract: CARDINAL;VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "ma maison à Montélimar";
+  InOut.WriteString(maChaine1);
+  InOut.WriteLn;
+  FileIO.Extract (maChaine1,3,6,maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test5 : PROCEDURE Concat (stringVal1, stringVal2: ARRAY OF CHAR;VAR destination: ARRAY OF CHAR);");
+  InOut.WriteLn;
+  maChaine1 := "ma maison";
+  maChaine2 := " à Montélimar";
+  FileIO.Concat(maChaine1, maChaine2, maChaine3);
+  InOut.WriteString(maChaine3);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test4 : PROCEDURE Compare (stringVal1, stringVal2: ARRAY OF CHAR): INTEGER;");
+  maChaine1 := "ma maison";
+  maChaine2 := "ma maison";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  maChaine2 := "ma maison à Montélimar";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  maChaine2 := "Coiucou";
+  InOut.WriteInt(FileIO.Compare(maChaine1,maChaine2),5);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test3 : PROCEDURE ORDL (n: INT32): CARDINAL;");
+  InOut.WriteLn;
+  monInt32 := 66666;
+  InOut.WriteInt(FileIO.ORDL(monInt32),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test3 : PROCEDURE INTL (n: INT32): INTEGER;");
+  InOut.WriteLn;
+  monInt32 := 55555;
+  InOut.WriteInt(FileIO.INTL(monInt32),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test2 : PROCEDURE INT (n: CARDINAL): INT32;");
+  InOut.WriteLn;
+  monCardinal := 444444;
+  InOut.WriteCard(monCardinal,8);
+  InOut.WriteInt(FileIO.INT(monCardinal),8);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test1 : QuitExecution");
+  InOut.WriteLn;
+  FileIO.QuitExecution;
+  InOut.WriteString("this will not be printed out");
+  InOut.WriteLn;
+END testFileIO.

testFileName.mod

@@ -0,0 +1,34 @@
+MODULE testFileName;
+
+IMPORT FileName, InOut;
+
+VAR 
+  chaine : ARRAY[0..256] OF CHAR;
+  f : FileName.Format;
+  a, b, c : ARRAY[0..256] OF CHAR;
+  
+BEGIN
+  InOut.WriteString("Test 1 : extraction des # éléments ");
+  InOut.WriteLn;
+  chaine := "/Projets/Projets-Modula2/CocoGm2/test.mod";
+  FileName.Get(chaine,a,b,c);
+  InOut.WriteString(a);
+  InOut.WriteLn;
+  InOut.WriteString(b);
+  InOut.WriteLn;
+  InOut.WriteString(c);
+  InOut.WriteLn;
+  
+  InOut.WriteString("Test 2 : GetDir, GetExt,GetName ");
+  InOut.WriteLn;
+  FileName.GetDir(chaine,a);
+  FileName.GetName(chaine,b);
+  FileName.GetExt(chaine,c);
+  InOut.WriteString(a);
+  InOut.WriteLn;
+  InOut.WriteString(b);
+  InOut.WriteLn;
+  InOut.WriteString(c);
+  InOut.WriteLn;
+  
+END testFileName.