M2compiler-V3/compiler/src/compiler.frm

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

  FROM -->Scanner IMPORT lst, src, errors, Error, CharAt, SetFileName;
  FROM -->Parser IMPORT Parse, Successful, GetUnit,
    InInst, InstBegin, InstAddActual, InstEnd, InstNameGet, InstActualGet,
    InstActualKind, InstActualVal, InstActualMod,
    UnitNameGet, UnitIsGeneric, UnitIsDefModule,
    RefineSeen, RefineIsDef, RefineInst, RefineGen,
    RefineActualCount, RefineActualGet, RefineActualKind, RefineActualVal,
    RefineActualMod,
    SetTwoPhase;
  IMPORT
    Strings, Storage, SYSTEM, FileIO, SymTab, QbeGen, AST, Lower;
  FROM libc IMPORT exit;
    (* and any others needed *)

  TYPE
    INT32 = FileIO.INT32 (* 32 bit integers needed *);
    GName = SymTab.Name;
    GPath = ARRAY [0 .. 255] OF CHAR;

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

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

    CONST
      tab = CHR(9);

    VAR
      firstErr, lastErr: Err;
      Extra: INTEGER;

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

    PROCEDURE GetLine (VAR pos: INT32;
                       VAR line: ARRAY OF CHAR;
                       VAR eof: BOOLEAN);
    (* Read a source line. Return empty line if eof *)
      VAR
        ch: CHAR;
        i: CARDINAL;
      BEGIN
        i := 0; eof := FALSE; ch := CharAt(pos); INC(pos);
        WHILE (ch # CR) AND (ch # LF) AND (ch # EOF) DO
          (* bound-check: a line longer than the caller's buffer must
             truncate, not overflow it (stack corruption / segfault) *)
          IF i < HIGH(line) THEN line[i] := ch; INC(i) END;
          ch := CharAt(pos); INC(pos);
        END;
        eof := (i = 0) AND (ch = EOF); line[i] := CHR(0);
        IF ch = CR THEN (* check for MsDos *)
          ch := CharAt(pos);
          IF ch = LF THEN INC(pos); Extra := 0 END
        END
      END GetLine;

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

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

      BEGIN
        CASE nr OF
        -->Errors
        (* add customized cases here *)
        | 200: Msg("duplicate identifier")
        | 201: Msg("undeclared identifier")
        | 202: Msg("module name mismatch")
        | 210: Msg("incompatible assignment")
        | 211: Msg("arithmetic operand must be numeric")
        | 212: Msg("boolean operand required")
        | 213: Msg("incompatible comparison")
        | 214: Msg("BOOLEAN condition required")
        | 215: Msg("not a RECORD type")
        | 216: Msg("unknown field")
        | 217: Msg("not an ARRAY type")
        | 218: Msg("array index must be integer")
        | 219: Msg("not a POINTER type")
        | 220: Msg("FOR needs integer variable and bounds")
        | 221: Msg("not a type name")
        | 222: Msg("set operand mismatch")
        | 223: Msg("cyclical type definition")
        | 224: Msg("ordinal type required")
        | 230: Msg("not supported yet")
        | 231: Msg("opaque type outside definition")
        | 232: Msg("bad RETURN")
        | 233: Msg("invalid call")
        | 234: Msg("invalid UTF-8 in U-literal")
        | 235: Msg("implementation does not match definition")
        | 236: Msg("bad variant record")
        | 237: Msg("RETRY outside EXCEPT")
        | 238: Msg("EXPORT must precede declarations")
        ELSE         Msg("Error: "); WriteInt(f, nr, 0);
        END
      END ErrText;

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

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

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

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

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

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

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

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

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

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

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

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

  PROCEDURE FileExists (path: ARRAY OF CHAR): BOOLEAN;
  (* The self-hosted FileIO has no Exists query; Open in input mode and
     close immediately. *)
    VAR f: FileIO.File; ok: BOOLEAN;
  BEGIN
    FileIO.Open(f, path, FALSE);
    ok := FileIO.Okay;
    IF ok THEN FileIO.Close(f) END;
    RETURN ok
  END FileExists;

  VAR
    sourceName, listName, progName: ARRAY [0 .. 255] OF CHAR;
    files: ARRAY [0 .. 127] OF ARRAY [0 .. 255] OF CHAR;
    bootstrapEnv: ARRAY [0 .. 31] OF CHAR;
    nFiles: CARDINAL;
    f: CARDINAL;
    bad: BOOLEAN;
    doTwoPhase: BOOLEAN; (* two-phase parse: defer procedure bodies *)
    separate: BOOLEAN;   (* M2 -c: one object, defs are interfaces *)
    progIsProgram: BOOLEAN;
    tmpCmd: ARRAY [0 .. 255] OF CHAR;
    defNames: ARRAY [0 .. 127] OF ARRAY [0 .. 63] OF CHAR;
    nDefNames: CARDINAL;

    (* generics (Increment 2): module name -> source path, def and impl *)
    genDefNm:  ARRAY [0 .. 31] OF ARRAY [0 .. 63] OF CHAR;
    genDefPth: ARRAY [0 .. 31] OF ARRAY [0 .. 255] OF CHAR;
    nGenDef: CARDINAL;
    genImpNm:  ARRAY [0 .. 31] OF ARRAY [0 .. 63] OF CHAR;
    genImpPth: ARRAY [0 .. 31] OF ARRAY [0 .. 255] OF CHAR;
    nGenImp: CARDINAL;
    uname, iname, gname: GName;
    gpath: GPath;
    isDef: BOOLEAN;
    (* -I interface search + transitive .def resolution for M2 -c *)
    incDirs: ARRAY [0 .. 15] OF ARRAY [0 .. 255] OF CHAR;
    nIncDirs: CARDINAL;
    scanMods: ARRAY [0 .. 127] OF GName;
    nScanMods: CARDINAL;
    sepNames: ARRAY [0 .. 127] OF GName;
    sepPaths: ARRAY [0 .. 127] OF ARRAY [0 .. 255] OF CHAR;
    sepState: ARRAY [0 .. 127] OF INTEGER;
    sepOrder: ARRAY [0 .. 127] OF CARDINAL;
    nSep, nSepOrder: CARDINAL;
    scanBuf: ARRAY [0 .. 65535] OF CHAR;
    scanPath, scanDir: ARRAY [0 .. 255] OF CHAR;
    scanWantFrom, scanFromSeen, scanImporting: BOOLEAN;

  PROCEDURE EqNm (a, b: ARRAY OF CHAR): BOOLEAN;
  (* NUL comparison.  Do not use HIGH on the right-hand string literal:
     V3 literal descriptors use the literal length, so HIGH would stop
     before the NUL terminator in a separately compiled compiler. *)
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < 256 DO
      IF a[i] # b[i] THEN RETURN FALSE END;
      IF a[i] = CHR(0) THEN RETURN TRUE END;
      INC(i)
    END;
    RETURN FALSE
  END EqNm;

  PROCEDURE EqNmCI (a, b: ARRAY OF CHAR): BOOLEAN;
  (* Case-insensitive module/file-name comparison.  Source file names
     are lower-case in many corpora while module identifiers are not. *)
    VAR i: CARDINAL; ca, cb: CHAR;
  BEGIN
    i := 0;
    WHILE i < 64 DO
      ca := a[i]; cb := b[i];
      IF (ca >= "A") AND (ca <= "Z") THEN ca := CHR(ORD(ca) + 32) END;
      IF (cb >= "A") AND (cb <= "Z") THEN cb := CHR(ORD(cb) + 32) END;
      IF ca # cb THEN RETURN FALSE END;
      IF ca = CHR(0) THEN RETURN TRUE END;
      INC(i)
    END;
    RETURN FALSE
  END EqNmCI;

  PROCEDURE IsOpt (s, opt: ARRAY OF CHAR): BOOLEAN;
  (* Option comparison without relying on HIGH of a string literal:
     V3 string-literal descriptors use the literal length, while the
     caller's fixed buffer is NUL-padded. *)
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < 64 DO
      IF s[i] # opt[i] THEN RETURN FALSE END;
      IF s[i] = CHR(0) THEN RETURN TRUE END;
      INC(i)
    END;
    RETURN FALSE
  END IsOpt;

  PROCEDURE CopySlice (src: ARRAY OF CHAR; start, count: CARDINAL;
                       VAR dst: ARRAY OF CHAR);
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < count) AND (start + i <= HIGH(src)) AND (i <= HIGH(dst)) DO
      dst[i] := src[start + i]; INC(i)
    END;
    IF i <= HIGH(dst) THEN dst[i] := CHR(0) END
  END CopySlice;

  PROCEDURE StrCopy (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i <= HIGH(src)) AND (i <= HIGH(dst)) AND (src[i] # CHR(0)) DO
      dst[i] := src[i]; INC(i)
    END;
    IF i <= HIGH(dst) THEN dst[i] := CHR(0) END
  END StrCopy;

  PROCEDURE StrCat (a, b: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
    VAR i, j: CARDINAL;
  BEGIN
    i := 0;
    WHILE (i <= HIGH(a)) AND (i <= HIGH(dst)) AND (a[i] # CHR(0)) DO
      dst[i] := a[i]; INC(i)
    END;
    j := 0;
    WHILE (j <= HIGH(b)) AND (i <= HIGH(dst)) AND (b[j] # CHR(0)) DO
      dst[i] := b[j]; INC(i); INC(j)
    END;
    IF i <= HIGH(dst) THEN dst[i] := CHR(0) END
  END StrCat;

  PROCEDURE LowerCopy (src: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
    VAR i: CARDINAL; ch: CHAR;
  BEGIN
    i := 0;
    WHILE (i <= HIGH(src)) AND (i <= HIGH(dst)) AND (src[i] # CHR(0)) DO
      ch := src[i];
      IF (ch >= "A") AND (ch <= "Z") THEN
        ch := CHR(ORD(ch) + ORD("a") - ORD("A"))
      END;
      dst[i] := ch; INC(i)
    END;
    IF i <= HIGH(dst) THEN dst[i] := CHR(0) END
  END LowerCopy;

  PROCEDURE DirOfPath (path: ARRAY OF CHAR; VAR dir: ARRAY OF CHAR);
    VAR i, k: CARDINAL;
  BEGIN
    dir[0] := CHR(0); k := 0; i := 0;
    WHILE (i <= HIGH(path)) AND (path[i] # CHR(0)) DO
      IF (path[i] = "/") OR (path[i] = CHR(92)) THEN k := i + 1 END;
      INC(i)
    END;
    i := 0;
    WHILE i < k DO dir[i] := path[i]; INC(i) END;
    dir[i] := CHR(0)
  END DirOfPath;

  PROCEDURE TryDef (dir, name, ext: ARRAY OF CHAR;
                    VAR path: ARRAY OF CHAR): BOOLEAN;
    VAR n: CARDINAL; i: CARDINAL;
  BEGIN
    path[0] := CHR(0);
    n := 0;
    i := 0;
    WHILE (i <= HIGH(dir)) AND (dir[i] # CHR(0)) DO
      IF n <= HIGH(path) THEN path[n] := dir[i] END;
      INC(n); INC(i)
    END;
    IF (n > 0) AND (path[n - 1] # "/") THEN
      IF n <= HIGH(path) THEN path[n] := "/" END;
      INC(n)
    END;
    i := 0;
    WHILE (i <= HIGH(name)) AND (name[i] # CHR(0)) DO
      IF n <= HIGH(path) THEN path[n] := name[i] END;
      INC(n); INC(i)
    END;
    i := 0;
    WHILE (i <= HIGH(ext)) AND (ext[i] # CHR(0)) DO
      IF n <= HIGH(path) THEN path[n] := ext[i] END;
      INC(n); INC(i)
    END;
    IF n <= HIGH(path) THEN path[n] := CHR(0) END;
    RETURN FileExists(path)
  END TryDef;

  PROCEDURE FindDef (name, targetDir: ARRAY OF CHAR;
                     VAR path: ARRAY OF CHAR): BOOLEAN;
    VAR i: CARDINAL; low: GName; d: ARRAY [0 .. 255] OF CHAR;
  BEGIN
    path[0] := CHR(0);
    LowerCopy(name, low);
    (* -I directories take precedence; the target's own directory is a
       fallback (important when a runtime and a host copy share a name). *)
    i := 0;
    WHILE i < nIncDirs DO
      StrCopy(incDirs[i], d);
      IF TryDef(d, name, ".def", path) THEN RETURN TRUE END;
      IF TryDef(d, name, ".DEF", path) THEN RETURN TRUE END;
      IF TryDef(d, low, ".def", path) THEN RETURN TRUE END;
      IF TryDef(d, low, ".DEF", path) THEN RETURN TRUE END;
      INC(i)
    END;
    IF TryDef(targetDir, name, ".def", path) THEN RETURN TRUE END;
    IF TryDef(targetDir, name, ".DEF", path) THEN RETURN TRUE END;
    IF TryDef(targetDir, low, ".def", path) THEN RETURN TRUE END;
    IF TryDef(targetDir, low, ".DEF", path) THEN RETURN TRUE END;
    RETURN FALSE
  END FindDef;

  PROCEDURE IsNameChar (ch: CHAR): BOOLEAN;
  BEGIN
    RETURN ((ch >= "A") AND (ch <= "Z"))
        OR ((ch >= "a") AND (ch <= "z"))
        OR ((ch >= "0") AND (ch <= "9"))
        OR (ch = "_")
  END IsNameChar;

  PROCEDURE AddScanMod (name: ARRAY OF CHAR);
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nScanMods DO
      IF EqNm(scanMods[i], name) THEN RETURN END;
      INC(i)
    END;
    IF nScanMods <= HIGH(scanMods) THEN
      StrCopy(name, scanMods[nScanMods]); INC(nScanMods)
    END
  END AddScanMod;

  PROCEDURE HandleScanTok (tok: GName);
    VAR wantFrom, fromSeen, importing: BOOLEAN;
  BEGIN
    (* These flags live in ScanFileImports's caller-visible globals. *)
    IF EqNmCI(tok, "FROM") THEN
      scanWantFrom := TRUE; scanFromSeen := FALSE; scanImporting := FALSE
    ELSIF EqNmCI(tok, "IMPORT") THEN
      IF scanFromSeen THEN scanImporting := FALSE
      ELSE scanImporting := TRUE
      END;
      scanWantFrom := FALSE
    ELSIF scanWantFrom THEN
      AddScanMod(tok);
      scanWantFrom := FALSE; scanFromSeen := TRUE
    ELSIF scanImporting THEN
      AddScanMod(tok)
    END
  END HandleScanTok;

  PROCEDURE ScanFileImports (path: ARRAY OF CHAR);
    VAR f: FileIO.File; nRead, i, start: CARDINAL;
        ch, quote: CHAR; cmt: CARDINAL; tok: GName;
  BEGIN
    nScanMods := 0;
    FileIO.Open(f, path, FALSE);
    IF NOT FileIO.Okay THEN RETURN END;
    nRead := HIGH(scanBuf) + 1;
    FileIO.ReadBytes(f, scanBuf, nRead);
    FileIO.Close(f);
    cmt := 0; quote := CHR(0);
    scanWantFrom := FALSE; scanFromSeen := FALSE; scanImporting := FALSE;
    i := 0;
    WHILE i < nRead DO
      ch := scanBuf[i];
      IF cmt > 0 THEN
        IF (ch = "(") AND (i + 1 < nRead) AND (scanBuf[i + 1] = "*") THEN
          INC(cmt); INC(i, 2)
        ELSIF (ch = "*") AND (i + 1 < nRead) AND (scanBuf[i + 1] = ")") THEN
          DEC(cmt); INC(i, 2)
        ELSE INC(i)
        END
      ELSIF quote # CHR(0) THEN
        IF ch = quote THEN
          IF (i + 1 < nRead) AND (scanBuf[i + 1] = quote) THEN INC(i, 2)
          ELSE quote := CHR(0); INC(i)
          END
        ELSE INC(i)
        END
      ELSIF (ch = "(") AND (i + 1 < nRead) AND (scanBuf[i + 1] = "*") THEN
        cmt := 1; INC(i, 2)
      ELSIF (ch = "/") AND (i + 1 < nRead) AND (scanBuf[i + 1] = "/") THEN
        WHILE (i < nRead) AND (scanBuf[i] # CHR(10)) DO INC(i) END
      ELSIF (ch = "'") OR (ch = '"') THEN
        quote := ch; INC(i)
      ELSIF (ch = ";") THEN
        scanWantFrom := FALSE; scanFromSeen := FALSE; scanImporting := FALSE;
        INC(i)
      ELSIF IsNameChar(ch) THEN
        start := i;
        WHILE (i < nRead) AND IsNameChar(scanBuf[i]) DO INC(i) END;
        IF i - start <= HIGH(tok) THEN
          CopySlice(scanBuf, start, i - start, tok);
          HandleScanTok(tok)
        END
      ELSE INC(i)
      END
    END
  END ScanFileImports;

  PROCEDURE FindSep (name: ARRAY OF CHAR): INTEGER;
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nSep DO
      IF EqNm(sepNames[i], name) THEN RETURN VAL(INTEGER, i) END;
      INC(i)
    END;
    RETURN -1
  END FindSep;

  PROCEDURE ResolveModule (name: ARRAY OF CHAR): BOOLEAN; FORWARD;

  PROCEDURE AddDefPath (path, name: ARRAY OF CHAR): BOOLEAN;
    VAR idx, j: INTEGER; pend: ARRAY [0 .. 127] OF GName; pn: CARDINAL;
  BEGIN
    idx := FindSep(name);
    IF idx >= 0 THEN RETURN TRUE END;
    IF nSep > HIGH(sepNames) THEN RETURN FALSE END;
    idx := VAL(INTEGER, nSep);
    StrCopy(name, sepNames[nSep]); StrCopy(path, sepPaths[nSep]);
    sepState[nSep] := 1; INC(nSep);
    ScanFileImports(path);
    pn := nScanMods;
    j := 0;
    WHILE j < VAL(INTEGER, pn) DO
      StrCopy(scanMods[j], pend[j]); INC(j)
    END;
    j := 0;
    WHILE j < VAL(INTEGER, pn) DO
      IF NOT ResolveModule(pend[j]) THEN END;
      INC(j)
    END;
    sepState[VAL(CARDINAL, idx)] := 2;
    IF nSepOrder <= HIGH(sepOrder) THEN
      sepOrder[nSepOrder] := VAL(CARDINAL, idx); INC(nSepOrder)
    END;
    RETURN TRUE
  END AddDefPath;

  PROCEDURE ResolveModule (name: ARRAY OF CHAR): BOOLEAN;
    VAR path: ARRAY [0 .. 255] OF CHAR; idx: INTEGER;
  BEGIN
    IF EqNm(name, "SYSTEM") OR EqNm(name, "libc") THEN RETURN TRUE END;
    idx := FindSep(name);
    IF idx >= 0 THEN RETURN TRUE END;
    IF NOT FindDef(name, scanDir, path) THEN RETURN FALSE END;
    RETURN AddDefPath(path, name)
  END ResolveModule;

  PROCEDURE ResolveFileImports (path: ARRAY OF CHAR);
    VAR j: INTEGER; pend: ARRAY [0 .. 127] OF GName; pn: CARDINAL;
  BEGIN
    ScanFileImports(path);
    pn := nScanMods;
    j := 0;
    WHILE j < VAL(INTEGER, pn) DO
      StrCopy(scanMods[j], pend[j]); INC(j)
    END;
    j := 0;
    WHILE j < VAL(INTEGER, pn) DO
      IF NOT ResolveModule(pend[j]) THEN END;
      INC(j)
    END
  END ResolveFileImports;

  PROCEDURE AddIncDir (s: ARRAY OF CHAR);
    VAR start, i: CARDINAL; d: ARRAY [0 .. 255] OF CHAR;
  BEGIN
    start := 0; i := 0;
    LOOP
      IF (i > HIGH(s)) OR (s[i] = CHR(0)) OR (s[i] = ":") THEN
        IF i > start THEN
          CopySlice(s, start, i - start, d);
          IF nIncDirs <= HIGH(incDirs) THEN
            StrCopy(d, incDirs[nIncDirs]); INC(nIncDirs)
          END
        END;
        IF (i > HIGH(s)) OR (s[i] = CHR(0)) THEN EXIT END;
        start := i + 1
      END;
      INC(i)
    END
  END AddIncDir;

  PROCEDURE PrepareSeparate (target: ARRAY OF CHAR);
    VAR j: CARDINAL; own: ARRAY [0 .. 255] OF CHAR; nm: GName;
  BEGIN
    nSep := 0; nSepOrder := 0;
    DirOfPath(target, scanDir);
    (* the target's own interface supplies exported globals/consts *)
    ChangeExtension(target, ".def", own);
    IF (NOT EqNm(target, own)) AND FileExists(own) THEN
      BaseName(own, nm);
      IF NOT AddDefPath(own, nm) THEN END
    END;
    ResolveFileImports(target);
    IF nSepOrder + 1 <= HIGH(files) THEN
      StrCopy(target, files[nSepOrder]);
      j := 0;
      WHILE j < nSepOrder DO
        StrCopy(sepPaths[sepOrder[j]], files[j]); INC(j)
      END;
      nFiles := nSepOrder + 1
    END
  END PrepareSeparate;

  PROCEDURE NoteGen (name: ARRAY OF CHAR; isD: BOOLEAN;
                     path: ARRAY OF CHAR);
    VAR i: CARDINAL;
  BEGIN
    IF isD THEN
      IF nGenDef <= HIGH(genDefNm) THEN
        i := 0;
        WHILE (i <= HIGH(genDefNm[nGenDef])) AND (name[i] # CHR(0)) DO
          genDefNm[nGenDef][i] := name[i]; INC(i)
        END;
        genDefNm[nGenDef][i] := CHR(0);
        i := 0;
        WHILE (i <= HIGH(genDefPth[nGenDef])) AND (path[i] # CHR(0)) DO
          genDefPth[nGenDef][i] := path[i]; INC(i)
        END;
        genDefPth[nGenDef][i] := CHR(0);
        INC(nGenDef)
      END
    ELSE
      IF nGenImp <= HIGH(genImpNm) THEN
        i := 0;
        WHILE (i <= HIGH(genImpNm[nGenImp])) AND (name[i] # CHR(0)) DO
          genImpNm[nGenImp][i] := name[i]; INC(i)
        END;
        genImpNm[nGenImp][i] := CHR(0);
        i := 0;
        WHILE (i <= HIGH(genImpPth[nGenImp])) AND (path[i] # CHR(0)) DO
          genImpPth[nGenImp][i] := path[i]; INC(i)
        END;
        genImpPth[nGenImp][i] := CHR(0);
        INC(nGenImp)
      END
    END
  END NoteGen;

  PROCEDURE FindGenIdx (name: ARRAY OF CHAR; isD: BOOLEAN): INTEGER;
  (* Index of the generic module's file in the registry, or -1. *)
    VAR i: CARDINAL;
  BEGIN
    i := 0;
    IF isD THEN
      WHILE i < nGenDef DO
        IF EqNm(genDefNm[i], name) THEN RETURN VAL(INTEGER, i) END;
        INC(i)
      END
    ELSE
      WHILE i < nGenImp DO
        IF EqNm(genImpNm[i], name) THEN RETURN VAL(INTEGER, i) END;
        INC(i)
      END
    END;
    RETURN -1
  END FindGenIdx;

  PROCEDURE DoInst (isTarget: BOOLEAN);
  (* Re-parse the generic's source with the instance name and the
     actuals bound.  In separate mode only the target unit is lowered;
     imported instance implementations are parsed for their symbols but
     left out of this object. *)
    VAR j: CARDINAL;
      gi: INTEGER;
      saved: FileIO.File;
  BEGIN
    RefineInst(iname); RefineGen(gname); isDef := RefineIsDef();
    gi := FindGenIdx(gname, isDef);
    IF gi < 0 THEN
      FileIO.WriteString(FileIO.StdOut, "generic not found: ");
      FileIO.WriteString(FileIO.StdOut, gname);
      FileIO.WriteLn(FileIO.StdOut);
      RETURN
    END;
    IF isDef THEN
      j := 0;
      WHILE (j <= HIGH(gpath)) AND (genDefPth[gi][j] # CHR(0)) DO
        gpath[j] := genDefPth[gi][j]; INC(j)
      END;
      gpath[j] := CHR(0)
    ELSE
      j := 0;
      WHILE (j <= HIGH(gpath)) AND (genImpPth[gi][j] # CHR(0)) DO
        gpath[j] := genImpPth[gi][j]; INC(j)
      END;
      gpath[j] := CHR(0)
    END;
    saved := src;
    FileIO.Open(src, gpath, FALSE);
    IF NOT FileIO.Okay THEN src := saved; RETURN END;
    SetFileName(gpath);
    ResetErrors;
    InstBegin(iname);
    j := 0;
    WHILE j < RefineActualCount() DO
      RefineActualVal(j, iname);
      RefineActualMod(j, gname);
      InstAddActual(RefineActualKind(j), RefineActualGet(j), iname, gname); INC(j)
    END;
    AST.Init;
    Lower.BeginUnit;
    SetTwoPhase(doTwoPhase);
    Parse;
    InstEnd;
    IF (NOT separate) OR isTarget THEN
      IF separate THEN Lower.SetDefUnit(isDef) END;
      Lower.LowerUnitNow(GetUnit(), FALSE);
      IF separate THEN Lower.SetDefUnit(FALSE) END
    END;
    IF (src # FileIO.StdIn) & (src # FileIO.StdOut) THEN
      FileIO.Close(src)
    END;
    src := saved
  END DoInst;

  BEGIN
    (* Bootstrap compatibility: compiler units may use the legacy 1-D
       open ABI while user programs use pointer-based views. *)
    FileIO.GetEnv("V3_LEGACY_OPEN1D", bootstrapEnv);
    IF bootstrapEnv[0] = "1" THEN Lower.SetLegacyOpen1D END;
    (* collect the session's source files (program module last) *)
    nFiles := 0;
    separate := FALSE;
    nDefNames := 0;
    doTwoPhase := TRUE;   (* two-phase parse on by default (-notwophase off) *)
    LOOP
      FileIO.NextParameter(sourceName);
      IF (sourceName[0] = CHR(0)) OR (nFiles > HIGH(files)) THEN EXIT END;
      IF IsOpt(sourceName, "-notwophase") THEN
        doTwoPhase := FALSE
      ELSIF IsOpt(sourceName, "-legacyopen1d") THEN
        Lower.SetLegacyOpen1D
      ELSIF IsOpt(sourceName, "-c") THEN
        separate := TRUE
      ELSIF IsOpt(sourceName, "-I") THEN
        FileIO.NextParameter(tmpCmd);
        IF tmpCmd[0] = CHR(0) THEN
          FileIO.WriteString(FileIO.StdOut, "-I expects a directory");
          FileIO.WriteLn(FileIO.StdOut);
          exit(2)
        END;
        AddIncDir(tmpCmd)
      ELSE
        Strings.Assign(sourceName, files[nFiles]);
        INC(nFiles)
      END
    END;
    IF nFiles = 0 THEN
      FileIO.WriteString(FileIO.StdOut, "No input file specified");
      FileIO.WriteLn(FileIO.StdOut);
      exit(2)
    END;

    (* M2 -c Foo.mod: resolve Foo.def and its import interfaces through
       -I directories.  Explicit interface lists keep the old path. *)
    IF separate AND (nFiles = 1) THEN
      PrepareSeparate(files[0])
    END;
    BaseName(files[nFiles - 1], progName);
    SymTab.Init;
    QbeGen.OpenModule(progName);
    IF separate THEN
      Lower.SetSeparate(TRUE);
      QbeGen.SetSeparateMode(TRUE)
    END;
    Lower.BeginSession(progName);
    Error := StoreError;

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

      FileIO.WriteString(FileIO.StdOut, "Parsing");
      FileIO.WriteLn(FileIO.StdOut);
      AST.Init;
      Lower.BeginUnit;
      SetTwoPhase(doTwoPhase);
      Parse;
      UnitNameGet(uname);
      IF RefineSeen() THEN
        DoInst(f = nFiles - 1)
      ELSIF UnitIsGeneric() THEN
        (* record the generic's source for later instantiation; do not
           emit the abstract template *)
        NoteGen(uname, UnitIsDefModule(), sourceName)
      ELSIF separate AND UnitIsDefModule() AND (f < nFiles - 1) THEN
        (* Interfaces are type-checking only, except the target's own
           .def: lower that one to emit its exported globals/consts. *)
        IF nDefNames <= HIGH(defNames) THEN
          Strings.Assign(uname, defNames[nDefNames]);
          INC(nDefNames)
        END;
        ChangeExtension(files[nFiles - 1], ".def", tmpCmd);
        IF EqNm(sourceName, tmpCmd) THEN
          Lower.SetDefUnit(TRUE);
          Lower.LowerUnitNow(GetUnit(), FALSE);
          Lower.SetDefUnit(FALSE)
        ELSIF NOT SymTab.ModForeign(uname) THEN
          (* a FOR "C" interface has no Modula-2 init object *)
          QbeGen.NoteExternalInit(uname)
        END
      ELSE
        IF separate THEN
          progIsProgram := SymTab.HaveProgram();
          Lower.LowerUnitNow(GetUnit(), progIsProgram)
        ELSE
          Lower.LowerUnitNow(GetUnit(), f = nFiles - 1)
        END
      END;
      PrintListing;
      IF lst # FileIO.StdOut THEN FileIO.Close(lst) END;
      IF NOT Successful() THEN
        PrintConsoleErrors(sourceName);
        bad := TRUE
      END;
      (* Release the source handle before the next file: the host
         FileIO caps open files at BitSetSize (16), and a session may
         compile more sources than that. *)
      IF (src # FileIO.StdIn) & (src # FileIO.StdOut) THEN
        FileIO.Close(src)
      END;
      INC(f)
    END;

    IF separate THEN
      QbeGen.SetProgramMode(SymTab.HaveProgram())
    END;
    Lower.EndSession;

    IF bad OR (NOT separate AND NOT SymTab.HaveProgram()) THEN
      FileIO.WriteString(FileIO.StdOut, "Incorrect source");
      FileIO.WriteLn(FileIO.StdOut);
      exit(1)
    ELSE
      FileIO.WriteString(FileIO.StdOut, "Parsed correctly");
      FileIO.WriteLn(FileIO.StdOut);
      exit(0)
    END
  END -->Grammar.