MODULE DswMakeMain;

  IMPORT Kernel, Files, Log, Strings, DswOpts, DswProcs, DswDocuments, DevCPM, DevCPT, DevCPR, DevCPS;

  CONST
    maxImps = 127;
    maxJobs = maxImps;

    (* symbol values *)
    null = 0; times = 1; slash = 2; div = 3; mod = 4;
    and = 5; plus = 6; minus = 7; or = 8; eql = 9;
    neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
    in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
    comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
    rbrace = 25; of = 26; then = 27; do = 28; to = 29;
    by = 30; not = 33;
    lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
    number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
    bar = 50; end = 51; else = 52; elsif = 53; until = 54;
    if = 55; case = 56; while = 57; repeat = 58; for = 59;
    loop = 60; with = 61; exit = 62; return = 63; array = 64;
    record = 65; pointer = 66; begin = 67; const = 68; type = 69;
    var = 70; out = 71; procedure = 72; close = 73; import = 74;
    module = 75; eof = 76;

    (* module state flags *)
    imported = 0; trace = 1; hasObj = 2; hasSym = 3; hasErrors = 4; library = 5;

    debugImport = FALSE;
    debugOrder = FALSE;
    debugJobs = FALSE;

  TYPE
    String = POINTER TO ARRAY OF CHAR;

    Selector = POINTER TO RECORD
      name: DevCPT.Name;
      value: BOOLEAN;
      next: Selector
    END;

    Module = POINTER TO RECORD
      name: DevCPT.Name;
      path: Files.Name;
      selectors: Selector; (* with head, list of selectors for this module *)
      depth: INTEGER; (* 0: leaf, MAX: root *)
      mno: INTEGER;
      imp: ARRAY maxImps OF Module;
      flags: SET;
      worker: DswProcs.Process;
    END;

  VAR
    err: INTEGER;
    mno, rno: INTEGER; (* num modules *)
    modList, lnkList, cmpList: ARRAY maxImps OF Module;
    def: Selector; (* with head, global list of selectors *)
    auto: INTEGER;
    jobs: INTEGER;
    exe: String;

  (* --------- options --------- *)

  PROCEDURE IdentLen (IN s: ARRAY OF CHAR): INTEGER;
    VAR i: INTEGER;
  BEGIN
    i := 0;
    IF Strings.IsIdentStart(s[0]) THEN
      REPEAT INC(i) UNTIL ~Strings.IsIdent(s[i])
    END;
    RETURN i
  END IdentLen;

  PROCEDURE Define (n: ARRAY OF CHAR);
    VAR i: INTEGER; v: BOOLEAN; s: Selector;
  BEGIN
    i := IdentLen(n);
    IF i # 0 THEN
      IF ~((n[i] = 0X) OR (((n[i] = "+") OR (n[i] = "-")) & (n[i + 1] = 0X))) THEN
        Log.String("option -D expect + or - after identifier"); Log.Ln; INC(err)
      END;
      v := n[i] # "-"; n[i] := 0X; s := def;
      WHILE (s.next # NIL) & (s.next.name$ # n$) DO s := s.next END;
      IF s.next = NIL THEN
        NEW(s.next);
        Strings.StringToUtf8(n, s.next.name, i);
        ASSERT(i = 0)
      END;
      s.next.value := v
    ELSE
      Log.String("option -D expect identifier"); Log.Ln; INC(err)
    END
  END Define;

  PROCEDURE Undefine (IN n: ARRAY OF CHAR);
    VAR i: INTEGER; s: Selector;
  BEGIN
    i := IdentLen(n);
    IF (i # 0) & (n[i] = 0X) THEN
      s := def;
      WHILE (s.next # NIL) & (s.next.name$ # n$) DO s := s.next END;
      IF s.next # NIL THEN s.next := s.next.next END
    ELSE
      Log.String("option -U expect identifier"); Log.Ln; INC(err)
    END
  END Undefine;

  PROCEDURE CopySelectorList (base: Selector): Selector;
    VAR s, t, x: Selector;
  BEGIN
    ASSERT(base # NIL, 20);
    s := base; NEW(t); x := t;
    WHILE s # NIL DO
      x^ := s^;
      IF s.next # NIL THEN NEW(x.next); x := x.next END;
      s := s.next
    END;
    RETURN t
  END CopySelectorList;

  PROCEDURE AddModule (IN n: ARRAY OF CHAR; selectors: Selector);
    VAR i, res: INTEGER; m: Module;
  BEGIN
    i := IdentLen(n);
    IF (i # 0) & (n[i] = 0X) THEN
      i := 0;
      WHILE (i < mno) & (modList[i].name$ # n$) DO INC(i) END;
      IF i >= mno THEN
        NEW(m);
        Strings.StringToUtf8(n, m.name, res);
        ASSERT(res = 0);
        m.selectors := CopySelectorList(selectors);
        modList[i] := m;
        INC(mno)
      END
    ELSE
      Log.String("module name must be identifier"); Log.Ln; INC(err)
    END
  END AddModule;

  PROCEDURE StrToInt (IN s: ARRAY OF CHAR; def: INTEGER): INTEGER;
    VAR x, res: INTEGER;
  BEGIN
    Strings.StringToInt(s, x, res);
    IF res # 0 THEN
      Log.String("expected integer"); Log.Ln; INC(err);
      x := def
    END;
    RETURN x
  END StrToInt;

  PROCEDURE ParseArgs;
  BEGIN
    jobs := 1;
    LOOP
      CASE DswOpts.GetOpt("ao:j:D:U:") OF
      | "a": INC(auto)
      | "o": exe := DswOpts.str
      | "j": IF DswOpts.str = NIL THEN jobs := maxJobs ELSE jobs := MIN(MAX(StrToInt(DswOpts.str, 0), 1), maxJobs) END
      | "D": Define(DswOpts.str)
      | "U": Undefine(DswOpts.str)
      | ":": Log.String("missing argument for option -"); Log.String(DswOpts.str); Log.Ln; INC(err)
      | "?": Log.String("unknown option -"); Log.String(DswOpts.str); Log.Ln; INC(err)
      | "$": AddModule(DswOpts.str, def)
      | 0X: EXIT
      END
    END
  END ParseArgs;

  (* --------- loader --------- *)

  PROCEDURE Import (m: Module; IN name: DevCPT.Name);
    VAR i, j: INTEGER; imp: Module;
  BEGIN
    ASSERT(m # NIL, 20);
    ASSERT(name # "", 21);
    IF debugImport THEN Log.String("  import "); Log.String(name$) END;
    IF name = "SYSTEM" THEN INCL(DevCPM.options, DevCPM.sysImp)
    ELSIF name = "COM" THEN INCL(DevCPM.options, DevCPM.com)
    ELSIF name = "JAVA" THEN INCL(DevCPM.options, DevCPM.java)
    ELSE
      IF debugImport THEN Log.Char(" ") END;
      i := 0; (* find module in local list *)
      WHILE (i < m.mno) & (m.imp[i].name$ # name$) DO INC(i) END;
      IF i >= m.mno THEN
        j := 0; (* find module in global list *)
        WHILE (j < mno) & (modList[j].name$ # name$) DO INC(j) END;
        IF j >= mno THEN
          NEW(imp); imp.name := name$; imp.selectors := CopySelectorList(m.selectors);
          modList[mno] := imp; INC(mno)
        ELSE
          imp := modList[j]
        END;
        m.imp[m.mno] := imp; INC(m.mno)
      ELSE DevCPM.err(1)
      END
    END;
    IF debugImport THEN Log.Ln END;
  END Import;

  PROCEDURE ParseModule (m: Module);
    VAR sym: BYTE; SelfName, impName, aliasName: DevCPT.Name;

    PROCEDURE err (n: SHORTINT);
    BEGIN DevCPM.err(n)
    END err;

    PROCEDURE CheckSym(s: SHORTINT);
    BEGIN
      IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END
    END CheckSym;

  BEGIN
    IF debugImport THEN Log.String("module " + m.name); Log.Ln END;
    DevCPS.Init; DevCPS.Get(sym);
    IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END;
    IF sym = ident THEN
      SelfName := DevCPS.name$; DevCPS.Get(sym);
      IF sym = lbrak THEN
        INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym);
        IF sym = eql THEN DevCPS.Get(sym)
        ELSE INCL(DevCPM.options, DevCPM.noCode)
        END;
        IF sym = string THEN INCL(m.flags, library); DevCPS.Get(sym)
        ELSE err(string)
        END;
        CheckSym(rbrak)
      END;
      CheckSym(semicolon);
      IF sym = import THEN DevCPS.Get(sym);
        LOOP
          IF sym = ident THEN
            aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym);
            IF sym = becomes THEN DevCPS.Get(sym);
              IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END
            END;
            Import(m, impName)
          ELSE err(ident)
          END;
          IF sym = comma THEN DevCPS.Get(sym)
          ELSIF sym = ident THEN err(comma)
          ELSE EXIT
          END
        END;
        CheckSym(semicolon)
      END
    ELSE err(ident)
    END;
    DevCPS.str := NIL
  END ParseModule;

  PROCEDURE CheckModule (m: Module; source: String; OUT ok: BOOLEAN);
    VAR s: Selector;
  BEGIN
    DevCPM.Init(source);
(*
    DevCPM.symList := m.insym;
    DevCPM.codePath := m.outcode;
    DevCPM.symPath := m.outsym;
*)
    DevCPM.name := m.name$;
(*
    IF m.found THEN INCL(DevCPM.options, DevCPM.comAware) END;
    IF errorTrap IN m.opts THEN INCL(DevCPM.options, DevCPM.trap) END;
    IF oberon IN m.opts THEN INCL(DevCPM.options, DevCPM.oberon) END;
*)
    DevCPR.Init;
    s := m.selectors.next;
    WHILE s # NIL DO
      DevCPR.Set(s.name, s.value);
      s := s.next
    END;
    ParseModule(m);
    DevCPR.Check;
    ok := DevCPM.noerr;
    DevCPR.Close;
    DevCPM.InsertMarks;
    DevCPM.Close;
    Kernel.FastCollect
  END CheckModule;

  PROCEDURE GetSource (IN modName: ARRAY OF CHAR; OUT path: Files.Name; OUT s: String);
    CONST modDir = "Mod"; sysDir = "System";
    VAR dir, name: Files.Name; loc: Files.Locator;
      text: DswDocuments.Model; r: DswDocuments.Reader; i, res: INTEGER;

    PROCEDURE MakePath (dir, name: Files.Name; type: Files.Type; OUT path: Files.Name);
    BEGIN
      ASSERT(name # "", 21);
      IF dir = "" THEN path := modDir + "/" + name
      ELSE path := dir + "/" + modDir + "/" + name
      END;
      Kernel.MakeFileName(path, type)
    END MakePath;

  BEGIN
    s := NIL; path := "";
    Kernel.SplitName(modName, dir, name);
    loc := Files.dir.This(dir).This(modDir);
    (* --> Kernel.MakeFileName(name, Kernel.docType); <-- *)
    MakePath(dir, name, "cp", path);
    DswDocuments.Open(loc, name + ".cp", text, res);
    IF text = NIL THEN
      MakePath(dir, name, "odc", path);
      DswDocuments.Open(loc, name + ".odc", text, res);
      IF (text = NIL) & (dir = "") THEN
        MakePath(sysDir, name, "cp", path);
        loc := Files.dir.This(sysDir).This(modDir);
        DswDocuments.Open(loc, name + ".cp", text, res);
        IF text = NIL THEN
          MakePath(sysDir, name, "odc", path);
          DswDocuments.Open(loc, name + ".odc", text, res);
          IF text = NIL THEN
            path := ""
          END
        END
      END
    END;
    IF text # NIL THEN
      NEW(s, text.Length() + 1);
      IF s # NIL THEN
        r := text.NewReader(NIL);
        FOR i := 0 TO text.Length() - 1 DO
          r.Read; s[i] := r.char
        END
      END
    END
  END GetSource;

  PROCEDURE Trace (m, parent: Module; VAR lno: INTEGER);
    VAR i: INTEGER;
  BEGIN
    IF ~(trace IN m.flags) THEN
      INCL(m.flags, trace);
      FOR i := 0 TO m.mno - 1 DO
        Trace(m.imp[i], m, lno);
        m.depth := MAX(m.depth, m.imp[i].depth + 1)
      END;
      IF ~(imported IN m.flags) THEN
        INCL(m.flags, imported);
        lnkList[lno] := m;
        INC(lno)
      END;
      EXCL(m.flags, trace)
    ELSE
      Log.String("recursive import of " + m.name + " in " + parent.name); Log.Ln; INC(err)
    END
  END Trace;

  PROCEDURE Sort;
    VAR i, j: INTEGER; m: Module;
  BEGIN
    ASSERT((mno = 0) OR (lnkList[0] # NIL), 20);
    cmpList := lnkList;
    i := 1;
    WHILE i < mno DO
      m := cmpList[i];
      j := i - 1;
      WHILE (j >= 0) & (cmpList[j].depth > m.depth) DO
        cmpList[j + 1] := cmpList[j];
        DEC(j)
      END;
      cmpList[j + 1] := m;
      INC(i)
    END
  END Sort;

  PROCEDURE CheckDeps;
    VAR i, j, num: INTEGER; m: Module; s: String; ok: BOOLEAN;
  BEGIN
    i := 0; rno := mno;
    WHILE (err = 0) & (i < mno) DO
      m := modList[i];
      GetSource(m.name$, m.path, s);
      IF s # NIL THEN
        CheckModule(m, s, ok);
        IF ~ok THEN INC(err) END
      ELSE
        Log.String("unable to open module " + m.name); Log.Ln; INC(err)
      END;
      INC(i)
    END;
    num := 0;
    FOR i := 0 TO rno - 1 DO
      Trace(modList[i], modList[i], num)
    END;
    ASSERT((err # 0) OR (num = mno), 100);
    Sort;
    IF debugOrder THEN
      Log.String("Parallel depth:"); Log.Ln;
      FOR i := 0 TO mno - 1 DO
        Log.String("  " + cmpList[i].name); Log.Int(cmpList[i].depth); Log.Ln;
      END
    END
  END CheckDeps;

  PROCEDURE IsCompiled (m: Module): BOOLEAN;
    CONST target = {hasSym, hasObj};
    VAR i: INTEGER; ready: BOOLEAN;
  BEGIN
    ASSERT(m # NIL, 20);
    i := 0;
    ready := ~(hasErrors IN m.flags) & (m.flags * target = target);
    WHILE ready & (i < m.mno) DO
      ready := IsCompiled(m.imp[i]);
      INC(i)
    END;
    RETURN ready
  END IsCompiled;

  PROCEDURE Ready (m: Module): BOOLEAN;
    CONST target = {hasSym, hasObj};
    VAR i: INTEGER; ready: BOOLEAN;
  BEGIN
    i := 0;
    ready := ~(hasErrors IN m.flags) & (m.flags * target # target) & (m.worker = NIL);
    WHILE ready & (i < m.mno) DO
      ready := IsCompiled(m.imp[i]);
      INC(i)
    END;
    RETURN ready
  END Ready;

  PROCEDURE ExecuteCompiler (m: Module): DswProcs.Process;
    VAR w: DswProcs.Process; ok: BOOLEAN;
  BEGIN
    ASSERT(m # NIL, 20);
    ASSERT(m.path # "", 21);
    ASSERT(m.worker = NIL, 22);
    w := DswProcs.dir.New();
    w.Program("cpc486");
    w.PutParam("-legacy");
    w.PutParam(m.path);
    w.Execute(ok);
    IF ok THEN
      Log.String("Compile " + m.name + " (" + m.path + ")"); Log.Ln;
    ELSE
      w := NIL
    END;
    RETURN w
  END ExecuteCompiler;

  PROCEDURE Compile;
    VAR i, j, num: INTEGER; ok: BOOLEAN; m: Module; w: DswProcs.Process;
  BEGIN
    IF mno = 0 THEN RETURN END;
    num := 0; j := 0;
    WHILE (err = 0) & (num < mno) OR (j > 0) DO
      i := 0;
      WHILE (err = 0) & (i < mno) & (j < jobs) DO
        m := cmpList[i];
        IF Ready(m) THEN
          w := ExecuteCompiler(m);
          IF debugJobs THEN Log.String("Start job " + m.name) END;
          IF w # NIL THEN
            IF debugJobs THEN Log.String(" ok") END;
            m.worker := w;
            INC(j)
          ELSE
            IF debugJobs THEN Log.String(" fail") END;
            INCL(m.flags, hasErrors);
            INC(err)
          END;
          IF debugJobs THEN Log.Ln END
        END;
        INC(i)
      END;
      WHILE (err = 0) & (j >= jobs) OR (j > 0) DO
        i := 0;
        WHILE (j > 0) & (i < mno) DO
          m := cmpList[i];
          w := m.worker;
          IF (w # NIL) & w.IsTerminated() THEN
            IF debugJobs THEN Log.String("Stop job " + m.name); Log.Int(w.Result()); Log.Ln END;
            IF w.Result() = 0 THEN
              INCL(m.flags, hasObj);
              INCL(m.flags, hasSym);
              INC(num)
            ELSE
              INCL(m.flags, hasErrors);
              INC(err)
            END;
            m.worker := NIL;
            DEC(j)
          END;
          INC(i)
        END
      END
    END
  END Compile;

  PROCEDURE Link;
    VAR p: DswProcs.Process; i: INTEGER; ok: BOOLEAN;
  BEGIN
    ASSERT(exe # NIL, 20);
    ASSERT(exe^ # "", 21);
    p := DswProcs.dir.New();
    p.Program("cpl486");
    p.PutParam("-os");
    p.PutParam("linux");
    p.PutParam("-kernel");
    p.PutParam("Kernel");
    p.PutParam("-main");
    p.PutParam("Kernel");
    p.PutParam("-legacycodedir");
    p.PutParam(".");
    p.PutParam("-o");
    p.PutParam(exe);
    i := 0;
    WHILE i < mno DO
      IF ~(library IN lnkList[i].flags) THEN
        p.PutParam(lnkList[i].name$)
      END;
      INC(i)
    END;
    p.Execute(ok);
    IF ok THEN
      i := p.Result();
      IF i # 0 THEN
        Log.String("linker terminated with error"); Log.Int(i); Log.Ln;
        INC(err)
      END
    ELSE
      Log.String("unable to execute linker"); Log.Int(i); Log.Ln;
      INC(err)
    END
  END Link;

  PROCEDURE Main;
    VAR m: Module; s: Selector; p: DswProcs.Process; ok: BOOLEAN; i, res: INTEGER;
  BEGIN
    IF Kernel.trapCount # 0 THEN Kernel.Quit(1) END;
    ParseArgs;
    IF err = 0 THEN
      CheckDeps;
      IF err = 0 THEN
        Compile;
        IF err = 0 THEN
          IF exe # NIL THEN Link END;
        END
      END
    END;
    IF err = 0 THEN Kernel.Quit(0)
    ELSE Kernel.Quit(1)
    END;
  END Main;

BEGIN
  NEW(def);
  Kernel.Start(Main)
END DswMakeMain.

==============================

SYNTAX
  cpmake {options module}

OPTIONS
  -a                         Enable automatic dependency resolution
  -o name                    Generate executable file
  -j num                     Specifies the number of jobs to run simultaneously
  -D ident["+"|"-"]          Add preprocessor selector
  -U ident                   Remove proprocessor selector